Dim strAttachmentFolder As String Sub ExtractAttachmentsFromEmailsStoredinWindowsFolder() 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
Preview:
downloadDownload PNG
downloadDownload JPEG
downloadDownload SVG
Tip: You can change the style, width & colours of the snippet with the inspect tool before clicking Download!
Click to optimize width for Twitter