Extract Attachments Macro in Outlook

[davysewell]

Eveing everyone,

I know this message board is supposed to be about Excel only but I can't find anyone else who can help me.

I'm looking for a macro for Outlook 2003 that will save all of the attachments to the current folder in Outllook and then move the original mail in to a folder call "Done"

I'm brand new to Outlook and there aren't many guides so I am not sure if this is possible.

If someone could help me I'd be eternally grateful!

Sorry for bending the rules!

Dave

 

[nirvana_]

Try this script. All attachments will be saved to C:\temp folder. Original mails will be moved subfolder under inbox called Done.

I think you need to put this script into Outlook rather than Excel. But you can try both ways.

Sub SaveAllAttachments()
Const olFolderInbox = 6
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
'Link to subfolder called Done under Inbox.
Set MyDestFolder = objFolder.Folders("Done")
Set colItems = objFolder.Items
For Each objmessage In colItems
    intCount = objmessage.Attachments.Count
    If intCount > 0 Then
        For i = 1 To intCount
            objmessage.Attachments.Item(i).SaveAsFile "C:\Temp\" & _
                objmessage.Attachments.Item(i).Filename
        Next
        objmessage.Move MyDestFolder
    End If
Next
End Sub