Public Sub SaveMessagesAndAttachments() ' Export for Single Message 

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 strDeletedFiles As String 

 Dim sFileType As String 

Dim enviro As String 

enviro = CStr(Environ("USERPROFILE")) 


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 = StripIllegalChar(objMsg.subject) 


StrFolderPath = enviro & "\Documents\" & StrName & "\" 

If Not FSO.FolderExists(StrFolderPath) Then 

    FSO.CreateFolder (StrFolderPath) 

End If 


 objMsg.SaveAs StrFolderPath & StrName & ".htm", olHTML 


    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 


Function StripIllegalChar(StrInput) 

    Dim RegX            As Object 

    Set RegX = CreateObject("vbscript.regexp") 


    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" 

    RegX.IgnoreCase = True 

    RegX.Global = True 


    StripIllegalChar = RegX.Replace(StrInput, "") 



    Set RegX = Nothing 


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