Outlook Replace Attachments

Sub ReplaceAttachments()

  '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\"

  'Create attachment list file
  myAttList = myOrt & "List of removed attachments.txt"

  Set fs = CreateObject("Scripting.FileSystemObject")
  Set fileAttList = fs.CreateTextFile(myAttList, True)
  fileAttList.WriteLine ("Attachments removed:")

  '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

      '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 list
        fileAttList.WriteLine (myAttachments(i).DisplayName)

      Next i

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

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

      Wend

      'save item with new attachment
      myAttachments.Add myAttList
      fileAttList.Close
      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