Native Windows Zip

I've been looking for some code for a while now that would allow me to create ZIP files using the native windows compression (compressed folders, etc.).  Well I found a function on Rob Van Der Woude's page that does this.  I am posting it here after some slight modifications.  For the original, go to http://www.robvanderwoude.com/vbstech_files_zip.html.
 

 Function fZip(sSourceFolder,sTargetZIPFile)
 'This function will add all of the files in a source folder to a ZIP file
 'using Windows' native folder ZIP capability.
  Dim oShellApp, oFSO, iErr, sErrSource, sErrDescription
  Set oShellApp = CreateObject("Shell.Application")
  Set oFSO = CreateObject("Scripting.FileSystemObject")
   'The source folder needs to have a \ on the End
   If Right(sSourceFolder,1) <> "\" Then sSourceFolder = sSourceFolder & "\"
  On Error Resume Next 
    'If a target ZIP exists already, delete it
    If oFSO.FileExists(sTargetZIPFile) Then oFSO.DeleteFile sTargetZIPFile,True 
   iErr = Err.Number
   sErrSource = Err.Source
   sErrDescription = Err.Description
  On Error GoTo 0
   If iErr <> 0 Then   
    fZip = Array(iErr,sErrSource,sErrDescription)
    Exit Function
   End If
  On Error Resume Next
   'Write the fileheader for a blank zipfile.
   oFSO.OpenTextFile(sTargetZIPFile, 2, True).Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0))
   iErr = Err.Number
   sErrSource = Err.Source
   sErrDescription = Err.Description
  On Error GoTo 0
   If iErr <> 0 Then   
    fZip = Array(iErr,sErrSource,sErrDescription)
    Exit Function
   End If
  On Error Resume Next 
   'Start copying files into the zip from the source folder.
   oShellApp.NameSpace(sTargetZIPFile).CopyHere oShellApp.NameSpace(sSourceFolder).Items
   iErr = Err.Number
   sErrSource = Err.Source
   sErrDescription = Err.Description
  On Error GoTo 0
   If iErr <> 0 Then   
    fZip = Array(iErr,sErrSource,sErrDescription)
    Exit Function
   End If
    'Because the copying occurs in a separate process, the script will just continue.  Run a DO...LOOP to prevent the function
    'from exiting until the file is finished zipping.
    Do Until oShellApp.NameSpace(sTargetZIPFile).Items.Count = oShellApp.NameSpace(sSourceFolder).Items.Count
     WScript.Sleep 500
    Loop
  fZip = Array(0,"","")
 End Function 
 

 

Very neat! I have one that uses Shell.Application too, but this is better since you can specify the zip file name.

Nice job.
I tried to copy individual files excluding folders into zip file instead of copy all at once.
Most of the time it works, but sometimes I get error: Error 424: Object required
 
Would you know how to fix that error (424)?
 
part of script:
'Start copying files into the zip from the source folder.
   Dim colItems
   Dim objItem
   Dim numFolders  
  
   numFolders = 0
   Set colItems = objShellApp.NameSpace(strSourceFolder).Items
   For Each objItem In colItems
   If (objItem.IsFolder) Then
    numFolders = numFolders + 1
   Else
    objShellApp.NameSpace(strDestinationZipFile).CopyHere objItem, PROGRESS_BOX_OFF
   End If
  Next
 
-----
PROGRESS_BOX_OFF is 4,