Public Sub SaveMessagesAndAttachments() Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem 'Object Dim objAttachments As Outlook.Attachments Dim i As Long Dim lngCount As Long Dim StrFile As String Dim StrName As String Dim StrFolderPath As String Dim strPath As String Dim sFileType As String Dim FSO As Object Dim oldName Set FSO = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set objOL = CreateObject("Outlook.Application") Set objMsg = objOL.ActiveExplorer.Selection.Item(1) StrName = objMsg.subject StrName = Left(StrName, 6) ' quoteID number is 6 characters. StrFolderPath = BrowseForFolder("C:\Users\cnewnham\Desktop\Output") StrFolderPath = StrFolderPath & "\" & StrName & "\" ' create folder if doesn't exist If Not FSO.FolderExists(StrFolderPath) Then FSO.CreateFolder (StrFolderPath) End If ' Save message as msg file type objMsg.SaveAs StrFolderPath & StrName & ".msg", olMSG 'save any attachments Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then For i = lngCount To 1 Step -1 StrFile = objAttachments.Item(i).FileName Debug.Print StrFile StrFile = StrFolderPath & StrFile objAttachments.Item(i).SaveAsFile StrFile Next i End If ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing 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