Zip All Email Attachments In A Outlook Folder
Thu Aug 05 2021 02:45:15 GMT+0000 (UTC)
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
Outlook
Comments