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

PHOTO EMBED

Thu Aug 05 2021 23:05:34 GMT+0000 (UTC)

Saved by @Darkleech #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 

                 Next 

              End If 

           End If 

        End If 

    Next 

  

    '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 

       Next 

    End If 

End Sub 
content_copyCOPY