Consulting

Results 1 to 3 of 3

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

  1. #1
    VBAX Regular
    Joined
    Jun 2006
    Posts
    17
    Location

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

    Hi

    I'm justing the macro code from https://www.datanumen.com/blogs/quic...lder-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!

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Regular
    Joined
    Jun 2006
    Posts
    17
    Location
    Thank you so much for your help. The macro works wonderfully!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •