Outlook Anhang speichern und löschen

Sub AnhangSpeichern()
 
    'Declaration  
    Dim myItems, myItem As MailItem, myAttachments, att As Outlook.Attachment
    Dim myOrt As String, strBody As String, strPath As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
     
    'Ask for destination folder  
    myOrt = InputBox("Destination", "Save Attachments", "D:\")  
    
    ' FSO Object  
    Set fso = CreateObject("Scripting.FileSystemObject")  
 
    'On Error Resume Next  
     
    'work on selected items  
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
     
    'for all items do...  
    For Each myItem In myOlSel
        Dim colRemove As New Collection
        With myItem
            'if there are some...  
            If .Attachments.Count > 0 Then
                
                strBody = IIf(.BodyFormat = olFormatHTML, .HTMLBody, .Body)
                
                'add remark to message text  
                strText = "<p style=""font-family:sans-serif;font-size:0.7em;font-style:italic"">Entfernte Anhänge:<br/>"  
                
                For Each att In .Attachments
                    ' If attachment is not inline  
                    If IsRealAttachment(att) Then
                        ' build save path  
                        strPath = fso.BuildPath(myOrt, att.FileName)
                        ' if file already exists build new name with unique id  
                        While fso.FileExists(strPath)
                            strPath = fso.BuildPath(myOrt, fso.GetBasename(att.FileName) & "_" & createUniqueID() & "." & fso.GetExtensionName(att.FileName))  
                        Wend
                        'save them to destination  
                        att.SaveAsFile strPath
                        ' add attachment to collection  
                        colRemove.Add att
                        'add name and destination to message text  
                        strText = strText & "Datei: <a href=""file:///" & strPath & """>" & strPath & "</a><br/>"  
                    End If
                Next
                ' if there are attachments to remove  
                If colRemove.Count > 0 Then
                    ' remove attachments  
                    For i = 1 To colRemove.Count
                        colRemove.Item(i).Delete
                    Next
                    ' set new mail body  
                    .HTMLBody = strText & "</p><hr/>" & strBody  
                    'save item  attachments  
                    .Save
                End If
            End If
        End With
    Next
     
    'free variables  
    Set myItems = Nothing
    Set myItem = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
    Set fso = Nothing
End Sub

Function IsRealAttachment(ByVal att As Attachment) As Boolean
    IsRealAttachment = False
    If att.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E") = "" And att.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x37140003") <> 4 Then  
        IsRealAttachment = True
    End If
End Function

Function createUniqueID()
    number = CLng((Now - #1/1/1970#) * 86400)
    Dim cList
    cList = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"  
    Dim finalString
    While Not number = 0
        If CInt(number Mod 36) = 0 Then
            finalString = finalString & Mid(cList, 1, 1)
        Else
            finalString = finalString & Mid(cList, (number Mod 36), 1)
        End If
        number = Round(number / 36)
    Wend
    createUniqueID = finalString
End Function