Zip All Email Attachments to Temporary Folder (Public)

PHOTO EMBED

Thu Aug 05 2021 22:40:12 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:\Temp\" & 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:\Temp\" & 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 

 

 

 

 

 

 

Sub ZipAttachments() 

    Dim objMail As Outlook.MailItem 

    Dim objAttachments As Outlook.Attachments 

    Dim objAttachment As Outlook.Attachment 

    Dim objFileSystem As Object 

    Dim objShell As Object 

    Dim varTempFolder As Variant 

    Dim varZipFile As Variant 

  

    'Save the attachments to Temporary folder 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    varTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-") 

    MkDir (varTempFolder) 

    varTempFolder = varTempFolder & "\" 

  

    Set objMail = Outlook.Application.ActiveInspector.CurrentItem 

    Set objAttachments = objMail.Attachments 

    For Each objAttachment In objAttachments 

        objAttachment.SaveAsFile (varTempFolder & objAttachment.FileName) 

    Next 

  

    'Create a new zip file 

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

    varZipFile = objFileSystem.GetSpecialFolder(2).Path & "\" & 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 attachments 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 

  

     'Delete all the attachments 

     Set objAttachments = objMail.Attachments 

     While objAttachments.Count > 0 

           objAttachments.Item(1).Delete 

     Wend 

  

     'Add the new zip file to the current email 

     objMail.Attachments.Add varZipFile 

  

    'Prompt 

    MsgBox ("Complete!") 

End Sub 
content_copyCOPY