Open any Email Attachment, functionized

In the comments for Open Any Email Attachment In Outlook I promised a functionized version of the code from so you can specify the folder where you would like to save the file. So a year later, here it is.

I reused the code from Post Email Data to the Web to encapsulate the function that retrieves the selected or open email message. The GetMessage function will either return a reference to an opened email (it should error if you have multiple emails open) or the first (if you have multiple) selected email in an Explorer view. Otherwise the function is the same; just call it with the name of the folder you want to use to save the attachment. If the folder doesn't exist, it will be created.

Function OpenAttachmentInNativeApp(folderName As String)
' based on code posted by Sue Mosher: http://tinyurl.com/684zg4
' See http://www.jpsoftwaretech.com/blog/2008/05/open-any-email-attachment-from-outlook/ for sub procedure

Dim myShell As Object
Dim MyItem As Outlook.MailItem
Dim myAttachments As Outlook.attachments
Dim i As Long
Dim Att As String

' check for valid folder name
If Right$(folderName, 1) <> "\" Then
  folderName = folderName & "\"
End If

' create folder if it doesn't exist
If Dir(folderName, vbDirectory) = "" Then
  MkDir folderName
End If

Set MyItem = GetMessage
If MyItem Is Nothing Then Exit Sub

Set myAttachments = MyItem.attachments

If myAttachments.Count > 0 Then
    For i = 1 To myAttachments.Count
        Att = myAttachments.item(i).DisplayName
        ' delete just in case it exists from before
       On Error Resume Next
        Kill folderName & Att
        On Error GoTo 0

        myAttachments.item(i).SaveAsFile folderName & Att
    Next i
End If

' Windows Script Host Object
Set myShell = CreateObject("WScript.Shell")
myShell.Run folderName & Att

End Function

Function GetMessage() As Outlook.MailItem
' returns MailItem object reference to open/selected mail item
' from http://www.jpsoftwaretech.com/blog/2009/04/post-email-data-to-the-web/

' if any error occurs, just exit
On Error GoTo ExitProc
Select Case TypeName(Application.ActiveWindow)
    Case "Explorer"
        Set GetMessage = ActiveExplorer.Selection.item(1)
    Case "Inspector"
        Set GetMessage = ActiveInspector.currentItem
    Case Else
End Select

ExitProc:
End Function

Usage:

Sub SaveMyAttachment()
  Call OpenAttachmentInNativeApp("C:\MyFiles")
End Sub

Related Articles:

• December 17, 2010 -- Creating UNC paths