Outlook-Makro Ergänzungs-Hilfe

Public Sub SaveAttachments()



    Dim objOL As Outlook.Application

    Dim objMsg As Outlook.MailItem

    Dim objAttachments As Outlook.Attachments

    Dim objSelection As Outlook.Selection

    Dim i As Long

    Dim lngCount As Long

    Dim strFile As String

    Dim objFileSystem As Object

    Dim strFolderpath As String

    

    

    ' Outlook Application Objekt instanziieren

    Set objOL = CreateObject("Outlook.Application")

    

    ' Collection der ausgewählten Objekte (E-Mails) ermitteln

    Set objSelection = objOL.ActiveExplorer.Selection

    

    ' Ordner-Pfad festlegen, wo der E-Mail Anhang gespeichert werden soll

    'HIER WIRD DER DATEIPFAD FESTGELEGT

    strFolderpath = "c:Emails"

    Set objFileSystem = CreateObject("Scripting.FileSystemObject")

    

    If Not objFileSystem.FolderExists(strFolderpath) Then

        objFileSystem.CreateFolder (strFolderpath)

    End If

    

    ' Jedes ausgewählten Objekte (E-Mails) prüfen, ob es einen Anhang hat. Wenn Anhang vorhanden,

    ' dann unter dem Ordnerpfad speichern.

    For Each objMsg In objSelection

    

        ' Die Anhänge des ausgewählten Objekts (E-Mail) ermitteln

        Set objAttachments = objMsg.Attachments

        lngCount = objAttachments.Count

    

        If lngCount > 0 Then

    

            ' Wir verwenden hier einen rückwärts gerichteten Zähler; umgekehrt sollte es aber auch funktionieren.

    

            For i = lngCount To 1 Step -1

    

                ' Save attachment before deleting from item.

                ' Dateinamen ermitteln

                strFile = objAttachments.Item(i).FileName

    

                ' Kombiniere Ablagepfad mit dem Dateinamen

                strFile = strFolderpath & strFile

    

                'Datei-Endung überprüfen

                FileExtension = Right$(strFile, Len(strFile) - InStrRev(strFile, "."))

                'HIER WIRD FESTGELEGT, WELCHE DATEIEN GESPEICHERT WERDEN SOLLEN, IN DIESEM BEISPIEL PDFs

                If FileExtension = "pdf" Then

                    ' Anhang als Datei speichern

                    objAttachments.Item(i).SaveAsFile strFile

                End If

    

            Next i

    

        End If

    Next

    

ExitSub:

    Set objAttachments = Nothing

    Set objMsg = Nothing

    Set objSelection = Nothing

    Set objOL = Nothing

End Sub