title: Extracting all attachments, including attachments inside .msg attachments, from selected Outlook mail
body: <p>The following VBA code, by Microsoft Thechnet, saves email attachments.</p>
  
  <p>If the files are inside another attachment, usually a .msg attachment, the script is unable to get them.</p>
  
  <pre><code>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 &lt;&gt; 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 &lt;&gt; 0 Then
              MsgBox "Run-time error '" &amp; CStr(Err.Number) &amp; " (0x" &amp; CStr(Hex(Err.Number)) &amp; ")':" &amp; vbNewLine &amp; _
                     Err.Description &amp; ".", 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 &gt; 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 &amp; atmt.FileName
  
                          ' /* If the length of the saving path is not larger than 260 characters.*/
                          If Len(strAtmtPath) &lt;= 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) &amp; _
                                                    Format(Now, "_mmddhhmmss") &amp; _
                                                    Format(Timer * 1000 Mod 1000, "000")
                                  strAtmtPath = strFolderPath &amp; strAtmtNameTemp &amp; "." &amp; strAtmtName(1)
  
                                  ' /* If the length of the saving path is over 260 characters.*/
                                  If Len(strAtmtPath) &gt; 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) &lt;&gt; "\" Then Path = Path &amp; "\"
  CGPath = Path
  End Function
  
  ' ######################################
  ' Run this macro for saving attachments.
  ' ######################################
  Public Sub ExecuteSaving()
  Dim lNum As Long
  
  lNum = SaveAttachmentsFromSelection
  
  If lNum &gt; 0 Then
      MsgBox CStr(lNum) &amp; " 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
  </code></pre>
  
  <p>How do I make this work if there is a .msg attachment with an attachment?</p>
  
  <p>I found a VBScript by Rafa Vargas.</p>
  
  <pre><code> '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 "==&gt; "&amp; 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 &gt; 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 &amp;" -&gt; "&amp; msg.Attachments(i).FileName
                  'Saving the attachment
                  msg.Attachments(i).SaveAsFile destPath &amp;"\"&amp; 
    msg.Attachments(i).FileName
              End If
          Next
      End If
  End If
    Next
    MsgBox "Anexos extraidos com sucesso!"
  </code></pre>
  
  <p>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?<br>
  2- Can I call the script from the VBA code posted earlier?</p>