Sub ZipAllEmailsInAFolder() Dim objFolder As Outlook.Folder Dim objItem As Object Dim objMail As Outlook.MailItem Dim strSubject As String Dim varTempFolder As Variant Dim varZipFile As Variant Dim objShell As Object Dim objFileSystem As Object 'Select an Outlook Folder Set objFolder = Outlook.Application.Session.PickFolder If Not (objFolder Is Nothing) Then 'Create a temp folder varTempFolder = "C:\Users\cnewnham\Desktop\2\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS") MkDir (varTempFolder) varTempFolder = varTempFolder & "\" 'Save each email as msg file For Each objItem In objFolder.Items If TypeOf objItem Is MailItem Then Set objMail = objItem strSubject = objMail.subject strSubject = Replace(strSubject, "/", " ") strSubject = Replace(strSubject, "\", " ") strSubject = Replace(strSubject, ":", "") strSubject = Replace(strSubject, "?", " ") strSubject = Replace(strSubject, Chr(34), " ") objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG End If Next 'Create a new ZIP file varZipFile = "C:\Users\cnewnham\Desktop\2\" & objFolder.Name & " Emails.zip" Open varZipFile For Output As #1 Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) Close #1 'Add the exported msg files to the ZIP file Set objShell = CreateObject("Shell.Application") objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 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 'Delete the temp folder Set objFileSystem = CreateObject("Scripting.FileSystemObject") objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1) 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