Help with macro code not working correctly - Zipping folders in Outlook

[DaveR]

Hi

I'm justing the macro code from https://www.datanumen.com/blogs/quickly-compress-emails-outlook-folder-zip-file/

and there is an error whereby everything works as required, yet the macro always misses one of the emails contained in the Outlook folder.

What can I do to fix this as apart from these minor points, this effectively does what I want it to do?

Thanks in advance!

[gmayor]

The most likely reasons are that some of your messages have the same derived filenames and thus are overwritten. The following should address that. It is also possible that some of your items are not mail items and they will be omitted. The macro does not take account of all possible illegal filename characters. The following addresses that also.


Option Explicit

Sub ZipAllEmailsInAFolder()
'Graham Mayor - https://www.gmayor.com - Last updated - 05 Apr 2019
Dim objFolder As Outlook.Folder
Dim objItem As Object
Dim strSubject As String
Dim varTempFolder As Variant
Dim varZipFile As Variant
Dim objShell As Object
Dim objFileSystem As Object
Dim iCount As Integer

'Select an Outlook Folder
Set objFolder = Outlook.Application.Session.PickFolder

If Not (objFolder Is Nothing) Then
'Create a temp folder
varTempFolder = "E:\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS")
MkDir (varTempFolder)
varTempFolder = varTempFolder & "\"

'Save each email as msg file
For iCount = objFolder.Items.Count To 1 Step -1
Set objItem = objFolder.Items(iCount)
'If TypeOf objItem Is MailItem Then 'optional
strSubject = CleanFileName(objItem.Subject)
SaveUnique objItem, CStr(varTempFolder), strSubject
'End If 'optional with above IF statement
DoEvents
Next iCount

'Create a new ZIP file
varZipFile = "E:\" & 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

Private Function CleanFileName(strFileName As String) As String
'Graham Mayor - https://www.gmayor.com
'Replaces illegal filename characters
Dim arrInvalid() As String
Dim lng_Index As Long
'Define illegal characters (by ASCII CharNum)
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
'Remove any illegal filename characters
CleanFileName = strFileName
For lng_Index = 0 To UBound(arrInvalid)
CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
Next lng_Index
lbl_Exit:
Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'Graham Mayor - https://www.gmayor.com - Last updated - 05 Apr 2019
'Ensures that filenames are not overwritten
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
lngF = 1
lngName = Len(strFileName)
Do While fso.FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg", olMsg
lbl_Exit:
Exit Function
End Function

[DaveR]

Thank you so much for your help. The macro works wonderfully!