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 



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


       On Error GoTo 0 


       Set objMail = Application.CreateItem(olMailItem) 


       'Add the zip attachment to a new email 

       With objMail 

            .Attachments.Add varZipFile 


       End With 

    End If 

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