@Nepumuk:E-Mail mit allen Dateien senden

Public Sub ZusendungUnterlagenRemoteberatung() Dim strFolder As String, strFilename As String Dim oApp As Object Set oApp = CreateObject("Outlook.Application") strFolder = Worksheets("Tabelle1").Cells(8, 2).Value If Left$(strFolder, 1) "\" Then strFolder = strFolder & "\" With oApp.CreateItem(0) .Sensitivity = 3 .To = Range("B7") .Subject = "Betreff" .Body = Worksheets("Tabelle1").Range("G6") & vbCr & vbCr & _ "Text." & vbCr & vbCr & _ "Text" & vbCr & vbCr & _ "Text" & vbCr & _ "Text" & vbCr strFilename = Dir$(strFolder & "*") Do Until strFilename = vbNullString Call .Attachments.Add(strFolder & strFilename) strFilename = Dir$ Loop .Display End With Set oApp = Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sergej,
beispielsweise so:

Option Explicit

Public Sub ZusendungUnterlagenRemoteberatung()
    Dim astrFolder(2) As String, strFilename As String
    Dim astrExtention(2) As String
    Dim ialngIndex As Long
    Dim oApp As Object

    Set oApp = CreateObject("Outlook.Application")

    astrFolder(0) = Worksheets("Tabelle1").Cells(8, 2).Value
    If Left$(astrFolder(0), 1) <> "\" Then astrFolder(0) = astrFolder(0) & "\"

    astrFolder(1) = Worksheets("Tabelle1").Cells(9, 2).Value
    If Left$(astrFolder(1), 1) <> "\" Then astrFolder(1) = astrFolder(1) & "\"

    astrFolder(2) = Worksheets("Tabelle1").Cells(10, 2).Value
    If Left$(astrFolder(2), 1) <> "\" Then astrFolder(2) = astrFolder(2) & "\"

    astrExtention(0) = "*.xls*"
    astrExtention(1) = "*.doc*"
    astrExtention(2) = "*.pdf"

    With oApp.CreateItem(0)

        .Sensitivity = 3
        .To = Range("B7").Value
        .Subject = "Betreff"
        .Body = Worksheets("Tabelle1").Range("G6").Value & vbCr & vbCr & _
            "Text." & vbCr & vbCr & _
            "Text" & vbCr & vbCr & _
            "Text" & vbCr & _
            "Text" & vbCr

        For ialngIndex = 0 To 2

            strFilename = Dir$(astrFolder(ialngIndex) & astrExtention(ialngIndex))

            Do Until strFilename = vbNullString

                Call .Attachments.Add(astrFolder(ialngIndex) & strFilename)

                .Body = .Body & astrFolder(ialngIndex) & strFilename & vbLf

                strFilename = Dir$

            Loop
        Next

        .Display

    End With
    Set oApp = Nothing
End Sub

Gruß
Nepumuk

Hallo Sergej,
dann so:

Option Explicit

Public Sub ZusendungUnterlagenRemoteberatung()
    Dim astrFolder(2) As String, strFilename As String
    Dim avntExtention(2) As Variant
    Dim ialngIndex As Long, ialngExtension As Long
    Dim oApp As Object

    Set oApp = CreateObject("Outlook.Application")

    astrFolder(0) = Worksheets("Tabelle1").Cells(8, 2).Value
    If Left$(astrFolder(0), 1) <> "\" Then astrFolder(0) = astrFolder(0) & "\"

    astrFolder(1) = Worksheets("Tabelle1").Cells(9, 2).Value
    If Left$(astrFolder(1), 1) <> "\" Then astrFolder(1) = astrFolder(1) & "\"

    astrFolder(2) = Worksheets("Tabelle1").Cells(10, 2).Value
    If Left$(astrFolder(2), 1) <> "\" Then astrFolder(2) = astrFolder(2) & "\"

    avntExtention(0) = Array("*.xls*", "*.nwd", "*.mp3")
    avntExtention(1) = Array("*.doc*", "*.mvp")
    avntExtention(2) = Array("*.pdf")

    With oApp.CreateItem(0)

        .Sensitivity = 3
        .To = Range("B7").Value
        .Subject = "Betreff"
        .Body = Worksheets("Tabelle1").Range("G6").Value & vbCr & vbCr & _
            "Text." & vbCr & vbCr & _
            "Text" & vbCr & vbCr & _
            "Text" & vbCr & _
            "Text" & vbCr

        For ialngIndex = 0 To 2

            For ialngExtension = LBound(avntExtention(ialngIndex)) To UBound(avntExtention(ialngIndex))

                strFilename = Dir$(astrFolder(ialngIndex) & avntExtention(ialngIndex)(ialngExtension))

                Do Until strFilename = vbNullString

                    Call .Attachments.Add(astrFolder(ialngIndex) & strFilename)

                    .Body = .Body & astrFolder(ialngIndex) & strFilename & vbLf

                    strFilename = Dir$

                Loop
            Next
        Next

        .Display

    End With
    Set oApp = Nothing
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

@Nepumuk:E-Mail mit allen Dateien senden

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread