Extracting all attachments, including attachments inside .msg attachments, from selected Outlook mail

Question

The following VBA code, by Microsoft Thechnet, saves email attachments.

If the files are inside another attachment, usually a .msg attachment, the script is unable to get them.

Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO              As Object       ' Computer's file system object.
Dim objShell            As Object       ' Windows Shell application object.
Dim objFolder           As Object       ' The selected folder object from Browse for Folder dialog box.
Dim objItem             As Object       ' A specific member of a Collection object either by position or by key.
Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.
Dim atmt                As Attachment   ' A document or link to a document contained in an Outlook item.
Dim strAtmtPath         As String       ' The full saving path of the attachment.
Dim strAtmtFullName     As String       ' The full name of an attachment.
Dim strAtmtName(1)      As String       ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
Dim strAtmtNameTemp     As String       ' To save a temporary attachment file name.
Dim intDotPosition      As Integer      ' The dot position in an attachment name.
Dim atmts               As Attachments  ' A set of Attachment objects that represent the attachments in an Outlook item.
Dim lCountEachItem      As Long         ' The number of attachments in each Outlook item.
Dim lCountAllItems      As Long         ' The number of attachments in all Outlook items.
Dim strFolderPath       As String       ' The selected folder path.
Dim blnIsEnd            As Boolean      ' End all code execution.
Dim blnIsSave           As Boolean      ' Consider if it is need to save.

blnIsEnd = False
blnIsSave = False
lCountAllItems = 0

On Error Resume Next

Set selItems = ActiveExplorer.Selection

If Err.Number = 0 Then

    ' Get the handle of Outlook window.
    lHwnd = FindWindow(olAppCLSN, vbNullString)

    If lHwnd <> 0 Then

        ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
        Set objShell = CreateObject("Shell.Application")
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
                                                 BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)

        ' /* Failed to create the Shell application. */
        If Err.Number <> 0 Then
            MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
                   Err.Description & ".", vbCritical, "Error from Attachment Saver"
            blnIsEnd = True
            GoTo PROC_EXIT
        End If

        If objFolder Is Nothing Then
            strFolderPath = ""
            blnIsEnd = True
            GoTo PROC_EXIT
        Else
            strFolderPath = CGPath(objFolder.Self.Path)

            ' /* Go through each item in the selection. */
            For Each objItem In selItems
                lCountEachItem = objItem.Attachments.Count

                ' /* If the current item contains attachments. */
                If lCountEachItem > 0 Then
                    Set atmts = objItem.Attachments

                    ' /* Go through each attachment in the current item. */
                    For Each atmt In atmts

                        ' Get the full name of the current attachment.
                        strAtmtFullName = atmt.FileName

                        ' Find the dot postion in atmtFullName.
                        intDotPosition = InStrRev(strAtmtFullName, ".")

                        ' Get the name.
                        strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
                        ' Get the file extension.
                        strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                        ' Get the full saving path of the current attachment.
                        strAtmtPath = strFolderPath & atmt.FileName

                        ' /* If the length of the saving path is not larger than 260 characters.*/
                        If Len(strAtmtPath) <= MAX_PATH Then
                            ' True: This attachment can be saved.
                            blnIsSave = True

                            ' /* Loop until getting the file name which does not exist in the folder. */
                            Do While objFSO.FileExists(strAtmtPath)
                                strAtmtNameTemp = strAtmtName(0) & _
                                                  Format(Now, "_mmddhhmmss") & _
                                                  Format(Timer * 1000 Mod 1000, "000")
                                strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)

                                ' /* If the length of the saving path is over 260 characters.*/
                                If Len(strAtmtPath) > MAX_PATH Then
                                    lCountEachItem = lCountEachItem - 1
                                    ' False: This attachment cannot be saved.
                                    blnIsSave = False
                                    Exit Do
                                End If
                            Loop

                            ' /* Save the current attachment if it is a valid file name. */
                            If blnIsSave Then atmt.SaveAsFile strAtmtPath
                        Else
                            lCountEachItem = lCountEachItem - 1
                        End If
                    Next
                End If

                ' Count the number of attachments in all Outlook items.
                lCountAllItems = lCountAllItems + lCountEachItem
            Next
        End If
    Else
        MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
        blnIsEnd = True
        GoTo PROC_EXIT
    End If

' /* For run-time error:
'    The Explorer has been closed and cannot be used for further operations.
'    Review your code and restart Outlook. */
Else
    MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
    blnIsEnd = True
End If

PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems

' /* Release memory. */
If Not (objFSO Is Nothing) Then Set objFSO = Nothing
If Not (objItem Is Nothing) Then Set objItem = Nothing
If Not (selItems Is Nothing) Then Set selItems = Nothing
If Not (atmt Is Nothing) Then Set atmt = Nothing
If Not (atmts Is Nothing) Then Set atmts = Nothing

' /* End all code execution if the value of blnIsEnd is True. */
If blnIsEnd Then End
End Function

' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "\" Then Path = Path & "\"
CGPath = Path
End Function

' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
Dim lNum As Long

lNum = SaveAttachmentsFromSelection

If lNum > 0 Then
    MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
Else
    MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
End If
End Sub

How do I make this work if there is a .msg attachment with an attachment?

I found a VBScript by Rafa Vargas.

 'Variables
  Dim ol, fso, folderPath, destPath, f, msg, i
 'Loading objects
  Set ol  = CreateObject("Outlook.Application")
  Set fso = CreateObject("Scripting.FileSystemObject")
  'Setting MSG files path
  folderPath = fso.GetParentFolderName(WScript.ScriptFullName)
  'Setting destination path
  destPath = folderPath   '* I am using the same 
  WScript.Echo "==> "& folderPath
  'Looping for files
  For Each f In fso.GetFolder(folderPath).Files
   'Filtering only MSG files
    If LCase(fso.GetExtensionName(f)) = "msg" Then
    'Opening the file
    Set msg = ol.CreateItemFromTemplate(f.Path)
    'Checking if there are attachments
    If msg.Attachments.Count > 0 Then
        'Looping for attachments
        For i = 1 To msg.Attachments.Count
            'Checking if is a PDF file
            If LCase(Mid(msg.Attachments(i).FileName, 
  InStrRev(msg.Attachments(i).FileName, ".") + 1 , 3)) = "xls" Then
                WScript.Echo f.Name &" -> "& msg.Attachments(i).FileName
                'Saving the attachment
                msg.Attachments(i).SaveAsFile destPath &"\"& 
  msg.Attachments(i).FileName
            End If
        Next
    End If
End If
  Next
  MsgBox "Anexos extraidos com sucesso!"

1- How can I delete the .msg files after extract and how do I make sure it doesn't overwrite files with the same name?
2- Can I call the script from the VBA code posted earlier?

Answer 1

OOM does allow to directly access embedded message attachments. On the Extended MAPI level (C++ or Delphi), you can open the attachment as IMessage - IAttach::OpenProperty(PR_ATTACH_DATA_OBJ, IID_IMssage, ...).

If using Redemption (any language, I am its author) is an option, it exposes EmbeddedMsg property on the attachments (RDOAttachment object).

Answer 2

My technique is slightly different to Eugene’s. I do not know which is the better technique so I will leave you to test the different approaches.

I have not attempted to update your macro. Instead I have created a small macro to demonstrate my technique. TestNewMacro is my test harness and SaveAttachmentsOfAttachedMsg is my demonstration macro.

You allow the user to select the save folder for attachments, I save to the desktop. I save MSG attachments in Window’s temporary folder and delete them after extracting their attachments. SaveAsFile overwrites any existing file with the same name without warning. I have not provided code to check for existing files. I have not checked for nested MSG attachments on the assumption that that is not needed. Any signatures or logos will be listed as attachments. I have made not attempt to ignore them.

Sub TestNewMacro()

  ' Skeleton for testing a new mail item processing macro using Inspector
  ' Replace statement marked ##### with call of new macro.
  ' Add code to create parameters for new test macro and remove any code to
  ' create parameters for old test macro.

  Dim Exp As Explorer
  Dim ItemCrnt As MailItem
  Dim PathSave As String

  ' Technique for locating desktop from answer by Kyle:
  '                     http://stackoverflow.com/a/17551579/973283
  PathSave = CreateObject("WScript.Shell").specialfolders("Desktop")

  Set Exp = Outlook.Application.ActiveExplorer

  If Exp.Selection.Count = 0 Then
    Call MsgBox("Please select one or more emails then try again", vbOKOnly)
    Exit Sub
  Else
    For Each ItemCrnt In Exp.Selection
      Call SaveAttachmentsOfAttachedMsg(ItemCrnt, PathSave)  ' #####
    Next
  End If

End Sub
Sub SaveAttachmentsOfAttachedMsg(ByRef ItemCrnt As MailItem, ByVal PathSave As String)

  ' If ItemCrnt has a MSG attachment, save that attachment and then
  ' save any attachments of the MSG file.

  ' Requires reference to "Microsoft Scripting Runtime"

  ' A MSG attachment is saved in Window's temporary folder.
  ' The MSG file is opened and checked for attachments.
  ' Any attachments found are saved in folder PathSave. Warning: Files with
  ' the same name as the attachment will be overwritten without warning.
  ' The MSG attachment is deleted from Window's temporary folder.

  Dim FileName As String
  Dim Fso As New FileSystemObject
  Dim InxA1 As Long
  Dim InxA2 As Long
  Dim ItemNew As MailItem
  Dim PathFileMsg As String
  Dim PathTemp As String

  PathTemp = Fso.GetSpecialFolder(TemporaryFolder)

  ' Examine any attachments of ItemCrnt
  For InxA1 = 1 To ItemCrnt.Attachments.Count
    FileName = ItemCrnt.Attachments(InxA1).FileName
    If LCase(Right$(FileName, 4)) = ".msg" Then
      PathFileMsg = PathTemp & "\" & FileName
      ' Save MSG attachment to termporary folder
      ItemCrnt.Attachments(InxA1).SaveAsFile PathFileMsg
      ' Open MSG file
      Set ItemNew = Application.CreateItemFromTemplate(PathFileMsg)
      ' Examine any attachments of ItemNew
      For InxA2 = 1 To ItemNew.Attachments.Count
        FileName = ItemNew.Attachments(InxA2).FileName
        ' Save attachment of MSG attachment to save folder
        ItemNew.Attachments(InxA2).SaveAsFile PathSave & "\" & FileName
      Next
      Set ItemNew = Nothing
      ' Delete MSG file
      Kill PathFileMsg
    End If
  Next

  Set Fso = Nothing

End Sub

Answer 3

The Outlook object model doesn't provide any property or method for opening an attached item out of the box. You need to save attached messages to the disk and then open them by calling Process.Run and passing the file path as an argument. They will be opened in the same instance of Outlook (the same process) because only one Outlook instance can run at the same time. Outlook is a singleton. Following that way you can handle NewInspector and Activate events where you may get a copy of the attached item and process attachments further.