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 




Set objAttachments = Nothing 

Set objMsg = Nothing 

Set objSelection = Nothing 

Set objOL = Nothing 

End Sub 
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