Kibo …

This macro for Outlook 2002 will traverse every folder in your “Inbox” and then save any attachments to a location you speficy, mirroring the structure of your Inbox. Once saved, the attachments are removed from the email message. A note is added to the top of affected messages to indicate where the attachment has been saved.

NOTE: This macro will remove all attachments from your email messages.

Dim AttachmentStore As String

 

Sub SaveAttachments()

Dim oApp As Application

Dim oNS As NameSpace

Dim oMsg As Object

Dim oAttachments As Outlook.Attachments

Set oApp = New Outlook.Application

Set oNS = oApp.GetNamespace(”MAPI”)

 

‘ Set the following variable to specify the target location

AttachmentStore = “C:\Data\EMail Attachments\”

ProcessFolder oNS.GetDefaultFolder(olFolderInbox)

End Sub

 

Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)

Dim i As Long

Dim olNewFolder As Outlook.MAPIFolder

Dim olTempItem As Object

If Replace(CurrentFolder.FolderPath, “\\Personal Folders\Inbox”, “”) <> “” Then

On Error Resume Next

MkDir AttachmentStore & Replace(CurrentFolder.FolderPath, “\\Personal Folders\Inbox”, “”)

End If

For Each oMsg In CurrentFolder.Items

With oMsg

If .Attachments.Count > 0 Then

AttachmentInfo = “”

For x = .Attachments.Count To 1 Step -1

.Attachments.Item(x).SaveAsFile AttachmentStore & Replace(CurrentFolder.FolderPath, “\\Personal Folders\Inbox”, “”) & “\” & .Attachments.Item(x).FileName

AttachmentInfo = AttachmentInfo & “Attachment saved to: ” & AttachmentStore & “\” & Replace(CurrentFolder.FolderPath, “\\Personal Folders\Inbox”, “”) & “\” & .Attachments.Item(x).FileName & vbCrLf

 

‘ Comment this line for testing

.Attachments.Remove x

.Save

Next

.Body = AttachmentInfo & “—–” & vbCrLf & vbCrLf & .Body

.Save

End If

End With

Next

 

For Each olNewFolder In CurrentFolder.Folders

If olNewFolder.Name <> “Deleted Items” Then

ProcessFolder olNewFolder

End If

Next

End Sub