Outlook Save Attachment

Sub SaveAttachment()

    'Declaration
    Dim myItems, myItem, myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection

    'Set for dumpfolder
    myOrt = "D:\MailDump\"

'    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

        'point on attachments
        Set myAttachments = myItem.Attachments

        'if there are some...
        If myAttachments.Count > 0 Then

            myItem.Body = "****************************************" & vbCrLf & _
                          myItem.Body

            'for all attachments do...
            For i = 1 To myAttachments.Count

                'save them to destination
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName

                'add name and destination to message text
                myItem.Body = "*   " & myAttachments(i).DisplayName & vbCrLf & myItem.Body

            Next i

            'add remark to message text
            myItem.Body = "****************************************" & vbCrLf & _
                          "* Attachments verwijderd:" & vbCrLf & _
                          myItem.Body

            'for all attachments do...
            While myAttachments.Count > 0

                'remove it (use this method in Outlook XP)
                myAttachments.Remove 1

            Wend

            'save item without attachments
            myItem.Save
        End If

    Next

    'free variables
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing

End Sub