Save Messages as attachments

PHOTO EMBED

Fri Aug 06 2021 07:01:21 GMT+0000 (Coordinated Universal Time)

Saved by @cnewnham #vba

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 
content_copyCOPY