VBA Access - Mails aus Ordner XXX mit bestimmtem Datei per Mail versenden

Hallo,

leider drehe ich mich ein wenig im Kreis

Folgendes soll passieren.

1. Aus einem Ordner c:\temp\ sollten alle Anhange mit dem Teilstring *errorpage* per Mail an einem bestimmtem Empfänger gesendet werden (.Display, und Aufbau der eigentlichen Mail.. hier weis mir zu helfen
2. Kleiner Knackpunkt, da es immer unterschiedlich viele Anhänge sind soll hier eine Schleife eingebaut werden, das maximal 30 Dokumente in eine Email als Anhang eingebunden werden und der rest auf andere Mails verteilt.
3. im Anschluss sollen die Anhänge ( Dateien ) verschoben werden c:\temp\erfolgreich_versendet

Vielleicht kann mir hier jemand weiterhelfen. Sicherlich für euch trivial.

Please also mark the comments that contributed to the solution of the article

Content-Key: 347724

Url: https://administrator.de/contentid/347724

Printed on: April 23, 2024 at 14:04 o'clock

2 Comments

Latest comment

Servus @thomas1972,
persönlich würde die Files zwar alle zippen statt sie aufzuteilen, aber wenn so sein soll, hier dein Beispiel:

Dim fso As Object

' ---> Start-Procedure  
Sub CreateMailsWithAttachments()
    ' maximale Anzahl an Anlagen pro Mail  
    Const MAXATTACH = 30
    ' Ordner mit den Attachments  
    Const ATTACHMENTFOLDER = "C:\temp"  
    ' Archivordner  
    Const ARCHIVEFOLDER = "c:\temp\erfolgreich_versendet"  
    ' Suchwort für Dateien  
    Const SEARCHTERM = "errorpage"  
    '--------------------------  
    ' counter für Attachments  
    Dim cnt As Integer: cnt = 0
    Dim colAttachments As Collection
    
    ' Filesystemobject  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    'Neue Mail nach Vorgabe erstellen  
    Set mail = CreateMailTemplate
    ' Attachments suchen ...  
    Set colAttachments = SearchFilesInFolder(ATTACHMENTFOLDER, SEARCHTERM)
    'Wenn Attachments da ...  
    If colAttachments.Count > 0 Then
        ' Für jedes Attachment  
        For Each file In colAttachments
            ' Wenn max. Attachment-Anzahl erreicht zeige mail und erstelle eine neue  
            If cnt > 0 And (cnt Mod MAXATTACH) = 0 Then
                mail.Display
                Set mail = CreateMailTemplate
            End If
            'Attachment hinzufügen  
            mail.Attachments.Add file
            'counter erhöhen  
            cnt = cnt + 1
        Next
        ' Mail Anzeigen  
        mail.Display
        
        ' Dateien in Archivordner verschieben  
        For Each file In colAttachments
            fso.MoveFile file, ARCHIVEFOLDER & "\"  
        Next
    Else
        ' Keine Attachments gefunden  
        MsgBox "Keine Attachments für Suchwort gefunden!", vbExclamation  
    End If
    'Cleanup  
    Set fso = Nothing
End Sub

' Mail nach Vorgabe erstellen  
Function CreateMailTemplate() As Object
    Dim objOl As Object, mail As Object
    Set objOl = CreateObject("Outlook.Application")  
    Set mail = objOl.CreateItem(0)
    With mail
        .Subject = "Testmail"  
        .To = "user@domain.de"  
        .Body = "Anbei die Anlagen"  
    End With
    Set CreateMailTemplate = mail
End Function

'Suche Dateien mit String im Namen (case insensitive)  
Function SearchFilesInFolder(strFolder As String, strSearch As String) As Collection
    Dim col As New Collection
    For Each file In fso.GetFolder(strFolder).Files
        If InStr(1, LCase(file.Name), LCase(strSearch), vbTextCompare) > 0 Then
            col.Add file.Path
        End If
    Next
    Set SearchFilesInFolder = col
End Function