Extract All Emails from Outlook Folder (Does not handle Duplicates) (Public)


Thu Aug 05 2021 23:05:34 GMT+0000 (Coordinated Universal Time)

Saved by @cnewnham #vba

Dim strAttachmentFolder As String 


Sub ExtractAttachmentsFromEmailsStoredinWindowsFolder() 'Does not handle duplicates this one 

    Dim objShell, objWindowsFolder As Object 


    'Select a Windows folder 

    Set objShell = CreateObject("Shell.Application") 

    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows Folder:", 0, "") 


    If Not objWindowsFolder Is Nothing Then 

       'Create a new folder for saving extracted attachments 

       strAttachmentFolder = "C:\Users\cnewnham\Downloads\attachments-" & Format(Now, "MMDDHHMMSS") & "\" 

       MkDir (strAttachmentFolder) 

       Call ProcessFolders(objWindowsFolder.Self.Path & "\") 

       MsgBox "Completed!", vbInformation + vbOKOnly 

    End If 

End Sub 


Sub ProcessFolders(StrFolderPath As String) 

    Dim objFileSystem As Object 

    Dim objFolder As Object 

    Dim objFiles As Object 

    Dim objFile As Object 

    Dim objItem As Object 

    Dim i As Long 

    Dim objSubfolder As Object 


    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    Set objFolder = objFileSystem.GetFolder(StrFolderPath) 

    Set objFiles = objFolder.Files 


    For Each objFile In objFiles 

        If objFileSystem.GetExtensionName(objFile) = "msg" Then 

           'Open the Outlook emails stored in Windows folder 

           Set objItem = Session.OpenSharedItem(objFile.Path) 


           If TypeName(objItem) = "MailItem" Then 

              If objItem.Attachments.Count > 0 Then 

                 'Extract attachments 

                 For i = objItem.Attachments.Count To 1 Step -1 

                     objItem.Attachments(i).SaveAsFile strAttachmentFolder & objItem.Attachments(i).FileName 


              End If 

           End If 

        End If 



    'Process all subfolders recursively 

    If objFolder.SubFolders.Count > 0 Then 

       For Each objSubfolder In objFolder.SubFolders 

           If ((objSubfolder.Attributes And 2) = 0) And ((objSubfolder.Attributes And 4) = 0) Then 

              Call ProcessFolders(objSubfolder.Path) 

           End If 


    End If 

End Sub