Makroudfordring i Outlook

Jeg ved der findes et program der hedder outlook attachment sniffer. Den kan ekstrakte vedhæftede filer.
Du kan se mere her: http://www.rsbr.de

Gemmedelen er ikke så svær - nedenstående har selv jeg kunnet finde ud af at tage fra nettet og tilrette. Den kan gemme og fjerne eller kun fjerne. Men jeg afvikler den med tryk på en knap:

Sub GemEllerSlet()
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Tryk ""Ja"" for både at gemme og fjerne vedhæftede filer." & vbCrLf & vbCrLf & _
"Tryk ""Nej"" for kun at fjerne vedhæftede filer."    ' Define message.
Style = vbYesNo + vbQuestion + vbDefaultButton1    ' Define buttons.
Title = "Gem og fjern eller kun fjern"

svar = MsgBox(Msg, Style, Title)
If svar = vbYes Then
Msg = "De vedhæftede filer gemmes i mappen:" & vbCrLf & vbCrLf & _
"C:\XX\XXXX\"    ' Define message.
Style = vbOKCancel + vbInformation + vbDefaultButton1    ' Define buttons.
Title = "Gemmeoplysninger "

svar = MsgBox(Msg, Style, Title)

If svar = vbOK Then
SaveAttachment
Else
GoTo Slut
End If
Else
RemoveAttachment
End If
Slut:
End Sub

Private 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
    Dim fs
    Dim fejl As String
         
   
    'Ask for destination folder
Retry:
    myOrt = "C:\XX\XXXX\"
       
    On Error Resume Next
   
    'Does the folderpath exists
'    Set fs = CreateObject("Scripting.FileSystemObject")
'    If fs.FolderExists(myOrt) = False Then
'    fejl = MsgBox("Stien eksisterer ikke." & vbCrLf & _
'    "Tryk ""OK"" og angiv en korrekt sti." & vbCrLf & _
'    "Tryk ""Annuler"" for at afbryde.", vbOKCancel + vbCritical + vbDefaultButton1, "Fejl i sti!")
'    If fejl = vbOK Then
'    GoTo Retry
'    Else
'    GoTo Slut
'    'Exit Sub
'    End If
'    End If
   
    'work on selected items
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
       
    'for all items do...
    For Each myItem In myOlSel
   
    Set myItem.BodyFormat = olFormatRichText
   
        'point on attachments
        Set myAttachments = myItem.Attachments
       
       
        'if there are some...
        If myAttachments.Count > 0 Then
       
            'add remark to message text
            myItem.Body = myItem.Body & vbCrLf & _
                "Vedhæftede fjernet:" & vbCrLf
               
            '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 = myItem.Body & _
                    "Fil: " & myAttachments(i).DisplayName & vbCrLf
                   
            Next i
           
            'for all attachments do...
            While myAttachments.Count > 0
           
                'remove it (use this method in Outlook XP)
                'myAttachments.Remove 1
               
                'remove it (use this method in Outlook 2000)
                myAttachments(1).Delete
               
            Wend
           
            'save item without attachments
'            With myItem
'            .BodyFormat = olFormatRichText
'            .Display
'            .Save
'            End With
           
            myItem.Save
        End If
       
    Next

Slut:
   
    'free variables
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
   
MsgBox "De fjernede filers navne er indsat i emnet.", vbOKOnly + vbInformation, "Vedhæftede filer fjernet!"
   
End Sub

Private Sub RemoveAttachment()

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

    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
   
    Set myItem.BodyFormat = olFormatRichText
   
        'point on attachments
        Set myAttachments = myItem.Attachments
       
        'if there are some...
        If myAttachments.Count > 0 Then
       
            'add remark to message text
            myItem.Body = myItem.Body & vbCrLf & _
                "Vedhæftede fjernet:" & vbCrLf
               
            'for all attachments do...
            For i = 1 To myAttachments.Count

                'add name and destination to message text
                myItem.Body = myItem.Body & _
                    "Fil: " & myAttachments(i).DisplayName & vbCrLf
                   
            Next i
           
            'for all attachments do...
            While myAttachments.Count > 0
           
                'remove it (use this method in Outlook XP)
                'myAttachments.Remove 1
               
                'remove it (use this method in Outlook 2000)
                myAttachments(1).Delete
               
            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
   
    MsgBox "De fjernede filers navne er indsat i emnet.", vbOKOnly + vbInformation, "Vedhæftede filer fjernet!"
   
End Sub