Zip All Emails in a Folder (Public)

PHOTO EMBED

Fri Aug 06 2021 07:02:46 GMT+0000 (Coordinated Universal Time)

Saved by @cnewnham #vba

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 
content_copyCOPY