Saving attachments from current email to a derived folder. - vba

Question

I'm looking for a starting point here, so no code to post I'm afraid !
I would like (if possible) to be able to open an email in Outlook (in the normal way, from the front-end), and then click a button to run a macro, which will extract the attachments from this email and save them to a directory path (derived from the subject).
Sound do-able ?
Any pointers, links code snippets welcome !

Answer 1

Okay, I got as far as the saving to local folder and deleting from message. I haven't worked out buttons yet, but I'm sure it's not the hardest thing in the world...
So I would check out the VBA documentation on Attachment Methods, specifically the one on SaveAsFile, as it has a full example that I used to test things out. The two methods available are the exact ones you need:
SaveAsFile
and
Delete
But since VBA makes nothing simple, using those two lines requires 15 others.
Also there is a REALLY great site called outlookcode.com. The site admin is a VBA/Outlook wizard and she will personally answer your questions if they sit on the forums for a more than a day (not a guarantee, just my experience). The site is full of sources and other people's code, etc.
Here is what I wrote to try out what you had in mind, based on the sample from MSDN which I added the delete method, making it a one click save/delete:
Sub getAttatchment()
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myItem = myInspector.CurrentItem
Set myAttachments = myItem.Attachments
If myAttachments.Item(1).DisplayName = "" Then
Set myAttachments.Item(1).DisplayName = myAttachments.Item(1).FileName
End If
myAttachments.Item(1).SaveAsFile Environ("HOMEPATH") _
& "\My Documents\" & myAttachments.Item(1).DisplayName
myAttachments.Item(1).Delete
Else
MsgBox "The item is of the wrong type."
End If
End If
End Sub
Be aware that the original sample has a dialog box to ask the user if they are sure they want to save as it will overwrite any files with the same name. I deleted it to simplify the code a bit.

Answer 2

This subroutine will save all attachments found in a user specified Outlook folder to a user specified directory on the file system. It also updates each message with a link to the purged files.
It contains extra comments to help highlight how the .Delete method will shrink Attachment containers dynamically (search for "~~" in the comments).
This subroutine is only tested on Outlook 2010.
' ------------------------------------------------------------.
' Requires the following references:
' Visual Basic for Applications
' Microsoft Outlook 14.0 Object Library
' OLE Automation
' Microsoft Office 14.0 Object Library
' Microsoft Shell Controls and Automation
' ------------------------------------------------------------.
Public Sub SaveOLFolderAttachments()
' Ask the user to select a file system folder for saving the attachments
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim fsSaveFolder As Object
Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
If fsSaveFolder Is Nothing Then Exit Sub
' Note: BrowseForFolder doesn't add a trailing slash
' Ask the user to select an Outlook folder to process
Dim olPurgeFolder As Outlook.MAPIFolder
Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
If olPurgeFolder Is Nothing Then Exit Sub
' Iteration variables
Dim msg As Outlook.MailItem
Dim att As Outlook.attachment
Dim sSavePathFS As String
Dim sDelAtts as String
For Each msg In olPurgeFolder.Items
sDelAtts = ""
' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
' on our olPurgeFolder.Items collection. The collection returned by the Restrict method
' will be dynamically updated each time we remove an attachment. Each update will
' reindex the collection. As a result, it does not provide a reliable means for iteration.
' This is why the For Each style loops will not work. ~~
If msg.Attachments.Count > 0 Then
' This While loop is controlled via the .Delete method which
' will decrement msg.Attachments.Count by one each time. ~~
While msg.Attachments.Count > 0
' Save the attachment to the file system
sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Attachments(1).FileName
msg.Attachments(1).SaveAsFile sSavePathFS
' Build up a string to denote the file system save path(s)
' Format the string according to the msg.BodyFormat.
If msg.BodyFormat <> olFormatHTML Then
sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
Else
sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
End If
' Delete the current attachment. We use a "1" here instead of an "i"
' because the .Delete method will shrink the size of the msg.Attachments
' collection for us. Use some well placed Debug.Print statements to see
' the behavior. ~~
msg.Attachments(1).Delete
Wend
' Modify the body of the msg to show the file system location of
' the deleted attachments.
If msg.BodyFormat <> olFormatHTML Then
msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts
Else
msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>"
End If
' Save the edits to the msg. If you forget this line, the attachments will not be deleted. ~~
msg.Save
End If
Next
End Sub