Scriptanpassung VBA mit Outlook-Excel Anhänge versenden

Hallo zusammen, ich bin noch recht frisch in VBA und versuche hier und da hinzuzulernen.

Leider kann ich VBA noch nicht so richtig mit mehreren Programmen verwenden.

IN OUTLOOK hab ich derzeit dieses Script:

Private m_Send as String
Private m_Done as String
Private m_To as String

Public Sub SendSingleFiles()
  Dim Files As VBA.Collection
  Dim File As Scripting.File
  Dim Mail As Outlook.MailItem
  Dim Atts As Outlook.Attachments
  
  'Send the files of this directory  
  m_Send = "C:/Sample/"  
  
  'Move send files here  
  m_Done = "C:/Sample/Sent/"  
  
  'Recipient  
  m_To = ""  
  
  Set Files = GetFiles
  If Files.Count Then
    Set Mail = Application.CreateItem(olMailItem)
    Set Atts = Mail.Attachments
    For Each File In Files
      Atts.Add File.Path
      File.Move m_Done & File.Name
    Next
    Mail.To = m_To
    Mail.Subject = "xxx"  
    Mail.Display
  End If
End Sub

Private Function GetFiles() As VBA.Collection
  Dim Folder As Scripting.Folder
  Dim Fso As Scripting.FileSystemObject
  Dim Files As Scripting.Files
  Dim File As Scripting.File
  Dim List As VBA.Collection
  
  Set List = New VBA.Collection
  Set Fso = New Scripting.FileSystemObject
  Set Folder = Fso.GetFolder(m_Send)
  Set Files = Folder.Files
  For Each File In Files
    'return only those files that are not hidden  
    If (File.Attributes Or Hidden) <> File.Attributes Then
      List.Add File
    End If
  Next
  Set GetFiles = List
End Function

am laufen. Die Problematik ist das ich viele Empfänger habe und versucht habe Variablen für den Pfad und den Empfänger zu setzen. Das Script macht folgendes:
Es holt aus einem vordefinierten Ordner die Anhänge, versieht diese mit einem Email-Scripttext und versendet dies.

An sich wünsche ich mir dass ich in einer Excel-Tabelle einen Empfänger und die dahinterstehende Email verwendet wird um dann den Anhang zu versenden. Bisher habe ich das einfach durch Wiederholgen der IF-Anweisung gemacht und manuellem eintragen des Empfängers sowie der Route auf der Festplatte.

Mein Verständnisproblem liegt darin wie ich Outlook die "Cell" oder "Range" Anweisung beibringe. Ich hab schon einiges versucht aber Excel will ums Verrecken die Variablen nicht einfach als String übergeben. Schön wäre auch einfach ein Loop für das ganze, aber damit hab ich mich auf Grund der Excel Problematik noch nicht befasst.

Excel hatte ich bereits als oBJECT, mit set die Range übergeben. Nix klappt.

Weiter hatte ich bereits folgendes angepasst bekomme aber die Anhänge nicht dran: (IN EXCEL STATT IN OUTLOOK!)

Public Sub Anlagen_verschicken()
    
    Dim MyOutApp As Object
    Dim MyMessage As Object
    Dim i As Variant
    Dim Pfad As String
    Dim fs
    Dim PfadAnhang As Object
    Dim Anhang As Object
    Dim Anhangdatei As Object
    
    
    
    'Start der Sendeschleife an 300 Empfänger  
Start:

    For i = 2 To 300
    If Cells(i, 1) = "" Then GoTo Ende  
    If ".Attachments" = "" Then GoTo Start  
    
        
    Set MyOutApp = CreateObject("Outlook.Application")  
    Set fs = CreateObject("Scripting.FileSystemObject")  
        Set MyMessage = MyOutApp.CreateItem(0)
        With MyMessage
            
            
            
            'Die Empfänger stehen in Spalte A ab Zeile 1  
            .To = Cells(i, 2) 'E-Mail Adresse  
            
            'Der Betreff in Spalte B  
            .Subject = 'Betreff (i, 1)  
            
            'Der zu sendende Text in Spalte C  
            'Maximal 1024 Zeichen  
            'Der Text wird ohne Formatierung übernommen  
            .Body = 'Nachricht  
            
            'Pfad der anzuhängenden Datei festlegen  
            Pfad = ("Z:\" & "\" & Cells(i, 1).Value & "\")  
            MsgBox Pfad
            Set PfadAnhang = fs.Getfolder(Pfad)
            
            'Anhang abholen  
            'If Left(Anhang.Name, 2) <> "X_" Then  
            '    Anhangdatei = Anhang.Name  
            '    .Attachments.Add PfadAnhang & Anhangdatei, olByValue, 1  
            'End If  
            
            'Anhang verschieben  
            fs.MoveFile Pfad & "*.txt", Pfad & "versendet"  
            
            'Hier wird die Mail angezeigt  
            .Display
            
            'Hier wird die Mail gleich in den Postausgang gelegt  
            '.Send  
Ende:
        End With
        
        'Objectvariablen leeren  
        
        Set MyOutApp = Nothing 'CreateObject("Outlook.Application")  
        Set MyMessage = Nothing 'MyOutApp.CreateItem(0)  
        'Sendepause einschalten  
        'Outlook kann die Aufträge nicht schnell genug verarbeiten  
        Application.Wait (Now + TimeValue("0:00:10"))  
    Next i


End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

Das Script schickt eine Email nach vordefinierten Empfängern aus einer Excel-Tabelle. Leider will es in keiner Form auch den vordefinierten Anhang im RELATIVEN PFAD mitsenden. (Es soll im Ordner schauen ob Anhänge da sind und diese Anhängen, ansonsten die Email verwerfen oder gar nicht erst erstellen.)

Hat jemand eine Lösung?

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 382440

Url: https://administrator.de/forum/scriptanpassung-vba-mit-outlook-excel-anhaenge-versenden-382440.html

Ausgedruckt am: 16.03.2025 um 02:03 Uhr

1 Kommentar

Das erste Script habe ich jetzt wie folgt angepasst allerdings hab ich es noch nicht so mit den Objekten:

  
Private m_Send As String
Private m_Done As String
Private m_To As String

Public Sub Versenden()


  Dim Files As VBA.Collection
  Dim File As Scripting.File
  Dim Mail As Outlook.MailItem
  Dim Atts As Outlook.Attachments
  Dim Pfad As String
  Dim oExcl As Object
  Dim oEmpfaenger As String
  Dim oEmail As String
  Dim i As Integer
  
  
  'Adressen aus Excel holen  
  Set oExcl = CreateObject("Excel.Application")  
  
  With Application
        i = i + 1
        .OpenWorkbook("TestSendenEmails.xlsb").Worksheets ("Tabelle1")  
        .ActiveSheet = "Tabelle1"  
        .Cells(i, 1) = oEmpfaenger
        .Cells(i, 2) = oEmail
  End With
  
  If oEmpfaenger = Null Then Exit Sub
  
  
  'Pfad festlegen  
    Pfad = "Z:/" & oEmpfaenger  
  
  'GÜB aus BPOL-Verzeichnis holen und senden  
    m_Send = Pfad

  'GÜB nach Makroausführung in BPOL-Verzeichnis verschieben  
    m_Done = Pfad & "/versendet/"  
  
  'E-Mailadresse   
    m_To = oEmail
      
  Set Files = GetFiles
  If Files.Count Then
    Set Mail = Application.CreateItem(olMailItem)
    Set Atts = Mail.Attachments
    For Each File In Files
      Atts.Add File.Path
      File.Move m_Done & File.Name
    Next
    Mail.To = m_To
    Mail.Subject = "Übersendung von Bescheinigungen der" & oEmpfaenger  
    Mail.Body = "Sehr geehrte Damen und Herren," & Chr(13) & Chr(13) & "als Anlage übersenden wir Ihnen die beigefügte(n) Bescheinigung(en) zur Vervollständigung Ihrer Unterlagen."   

    Mail.Send
    End If
    
End Sub



Private Function GetFiles() As VBA.Collection
  Dim Folder As Scripting.Folder
  Dim Fso As Scripting.FileSystemObject
  Dim Files As Scripting.Files
  Dim File As Scripting.File
  Dim List As VBA.Collection
  
  Set List = New VBA.Collection
  Set Fso = New Scripting.FileSystemObject
  Set Folder = Fso.GetFolder(m_Send)
  Set Files = Folder.Files
  For Each File In Files
    'Nur die Dateien zurückgeben, die nicht versteckt sind  
    If (File.Attributes Or Hidden) <> File.Attributes Then
      List.Add File
    End If
  Next
  Set GetFiles = List
End Function


Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

End Sub