Compressing files

[Darren Bartrup]

This code and problem aren't specific to Access, but I'm writing it in Access so thought this would be the best place to post...

I'm importing multiple Excel files into an Access database and to keep things tidy I'm zipping the files afterwards based on the date in the file name. Everything works perfectly except when the file compression takes too long - I then get a 'Compressed (zipped) Folders Error' stating 'Missing or empty Zip file.' or in some cases 'Cannot create output file' (I've highlighted the problem code in red below).

When I pause my code with one of these errors it's always on the DoEvents line near the bottom of the procedure - and when I press F8 to step through it starts the procedure again.

Sometimes the code works fine, at others it stops at a seemingly random file.
I've had a look at Ron De Bruins site, but have had no joy in sorting the problem.

Public Sub Import_All_Reports()

    Dim rstParentFolder As DAO.Recordset
    Dim rstProcedure As DAO.Recordset
    Dim sParentFolder As String
    Dim vFolder As Variant
    Dim vFileName As Variant
    Dim sZipFile As String
    Dim iFile As Integer
    Dim I As Long
    Dim WaitUntil As Date
    Dim ONameSpace As Object 'Shell32.Folder
    
    Dim colReportFolders As Collection
    Dim colFiles As Collection
    Dim oApp As Object
    
    Set rstParentFolder = CurrentDb.OpenRecordset( _
        "SELECT sVALUE FROM tbl_SYS_System " & _
        "WHERE sDescription = 'ReportLocation'")
        
    With rstParentFolder
    
        If Not .EOF And Not .BOF Then
        
            ''''''''''''''''''''''''''''''''''''''''''''
            'Get all folders within the parent folder. '
            ''''''''''''''''''''''''''''''''''''''''''''
            sParentFolder = .Fields("sValue")
            Set colReportFolders = New Collection
            EnumerateFolders rstParentFolder.Fields("sValue"), colReportFolders
            
            For Each vFolder In colReportFolders
            
                Set rstProcedure = CurrentDb.OpenRecordset( _
                    "SELECT sSubDescription " & _
                    "FROM tbl_SYS_System " & _
                    "WHERE sDescription = 'ReportName' AND " & _
                    "sValue = '" & Mid(vFolder, InStrRev(vFolder, "\") + 1, Len(vFolder)) & "'")
            
                '''''''''''''''''''''''''''''''''''
                'Get all files within the folder. '
                '''''''''''''''''''''''''''''''''''
                Set colFiles = New Collection
                EnumerateFiles CStr(vFolder), "*.xls*", colFiles
                I = 0
                For Each vFileName In colFiles
                
                    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                    'Process each file according to its import instructions. '
                    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                    'Application.Run rstProcedure.Fields(0), vFileName
                    I = I + 1
                    
                    '''''''''''''''''''''''''''''''''''''''''''''
                    'Archive the file.                          '
                    'Year, month number and month name of file. '
                    '''''''''''''''''''''''''''''''''''''''''''''
                    sZipFile = vFolder & "\" & "20" & Mid(vFileName, InStrRev(CStr(vFileName), ".") - 8, 2) & " " & _
                        Mid(vFileName, InStrRev(CStr(vFileName), ".") - 5, 2) & " " & _
                        Format("01/" & Mid(vFileName, InStrRev(CStr(vFileName), ".") - 5, 2) & "00", "mmmm") & ".zip"


                    '''''''''''''''''''''''''''''''''''''''''''''''''''
                    'Create the zip file if it doesn't already exist. '
                    '''''''''''''''''''''''''''''''''''''''''''''''''''
                    If (Len(Dir(sZipFile, vbDirectory + vbHidden + vbSystem)) = 0) Then
                    
                        Debug.Print "Creating zip file: " & sZipFile
                        
                        iFile = FreeFile
                        
                        Open sZipFile For Output As #iFile
                            Print #iFile, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
                        Close #iFile
                    End If
                    
                    Set ONameSpace = CreateObject("Shell.Application").Namespace(CVar(sZipFile))
                    ONameSpace.CopyHere CStr(vFileName)
                    
                    Debug.Print "Zipping file: " & CStr(vFileName)
                    
                    '''''''''''''''''''''''''''''''''''''''''''''''''
                    'Keep script waiting until Compressing is done. '
                    '''''''''''''''''''''''''''''''''''''''''''''''''
                    On Error Resume Next
                    Do Until ONameSpace.items.Count = I
                        WaitUntil = Now + TimeValue("00:00:01")
                        Do
                           DoEvents
                        Loop Until Now >= WaitUntil
                    Loop
                    On Error GoTo 0
                    
                    Debug.Print "Done"
                    
                    Set ONameSpace = Nothing
                    
                Next vFileName
                Debug.Print vFolder & " : " & I
            Next vFolder
        Else
            '''''''''''''''''''''''''''''''''''''''''''''''''
            'No value has been returned, so exit procedure. '
            '''''''''''''''''''''''''''''''''''''''''''''''''
            
            'TO DO
        
        End If
    
    End With


    rstParentFolder.Close
    Set rstParentFolder = Nothing
    
End Sub

Any help greatly appreciated as usual.