Forward Multiple Emails As Zip Attachment (Public)

PHOTO EMBED

Fri Aug 06 2021 06:59:52 GMT+0000 (Coordinated Universal Time)

Saved by @cnewnham #vba

Sub ForwardMultipleEmailsAsZipAttachment() 

    Dim objSelection As Outlook.Selection 

    Dim objMail As Outlook.MailItem 

    Dim strSubject As String 

    Dim strTempFolder As String 

    Dim varTempFolder As Variant 

    Dim objShell As Object 

    Dim varZipFile As Variant 

    Dim objForward As Outlook.MailItem 

  

    Set objSelection = Application.ActiveExplorer.Selection 

  

    If Not (objSelection Is Nothing) Then 

  

       'Save selected emails to Temporary folder 

       strTempFolder = CStr(Environ("USERPROFILE")) & "\AppData\Local\Temp" 

       varTempFolder = strTempFolder & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-") 

       MkDir (varTempFolder) 

       varTempFolder = varTempFolder & "\" 

 

       For Each objMail In objSelection 

  

           strSubject = objMail.subject 

  

           'Remove unsupported characters in the subject 

           strSubject = Replace(strSubject, "/", " ") 

           strSubject = Replace(strSubject, "\", " ") 

           strSubject = Replace(strSubject, ":", "") 

           strSubject = Replace(strSubject, "?", " ") 

           strSubject = Replace(strSubject, Chr(34), " ") 

  

           objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG 

       Next 

     

       'Create a new zip file 

       varZipFile = InputBox("Specify a name for the new zip file", "Name Zip File") 

       varZipFile = strTempFolder & "\" & varZipFile & ".zip" 

       Open varZipFile For Output As #1 

       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

       Close #1 

  

       'Copy all the saved emails to the new zip file 

       Set objShell = CreateObject("Shell.Application") 

       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

       'Keep macro running until compressing is done 

       On Error Resume Next 

       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

          Application.Wait (Now + TimeValue("0:00:01")) 

       Loop 

       On Error GoTo 0 

  

       Set objMail = Application.CreateItem(olMailItem) 

  

       'Add the zip attachment to a new email 

       With objMail 

            .Attachments.Add varZipFile 

            .Display 

       End With 

    End If 

End Sub 
content_copyCOPY