Extract Attachments From Single Message (Public)

PHOTO EMBED

Fri Aug 06 2021 06:57:14 GMT+0000 (Coordinated Universal Time)

Saved by @cnewnham #vba

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 

           

ExitSub: 

  

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, "") 

        

ExitFunction: 

    Set RegX = Nothing 

        

End Function 
content_copyCOPY