Outlook Anhänge speichern

Sub SaveCSVOnHarddrive



    Dim myAttachments     As Outlook.Attachments

    Dim olMailItem        As Outlook.MailItem

    

    Dim lngAttachCount    As Long

    

    Dim strAttach         As String

    Dim strPath           As String

    

    'Wenn Ordner nicht vorhanden, wird erstellt

    Dim ordner As String

    'Dim pfad As String



    ordner = Year(Date)   'Year(a)



    strPath = "T:\Finanzbuchhaltung\TEST\" & ordner



    If Dir(strPath, vbDirectory) = ordner Then

        'MsgBox "Das Verzeichnis existiert bereits!"

    Else

        MkDir strPath

        'MsgBox "Verzeichnis erstellt."

    End If



   

    ' Aktive Mail setzen

    Select Case True

           Case TypeOf Application.ActiveWindow Is Outlook.Inspector

                Set olMailItem = Application.ActiveInspector.CurrentItem

           Case Else

                With Application.ActiveExplorer.Selection

                     If .Count Then Set olMailItem = .Item(1)

                End With

                If olMailItem Is Nothing Then Exit Sub

           End Select

      

       ' Anhangobjekt erstellen

        Set myAttachments = olMailItem.Attachments

        

        ' Anhänge prüfen und speichern. Nur Dateien vom Typ csv und pdf wird gespeichert

        If myAttachments.Count > 0 Then

           For lngAttachCount = myAttachments.Count To 1 Step -1

               If Right(myAttachments(lngAttachCount).DisplayName, 3) = "csv" Or _

                 Right(myAttachments(lngAttachCount).DisplayName, 3) = "pdf" Then

                  olMailItem.Attachments.Item(lngAttachCount).SaveAsFile strPath & _

                  olMailItem.Attachments.Item(lngAttachCount).FileName

               End If

           Next lngAttachCount

       End If

End Sub