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
Preview:
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