Write to file using CopyHere without using WScript

Question

I've written a small VBScript to creates a .zip file and then copies the contents of a specified folder into that .zip file.

I copy the files over one by one for a reason (I know I can do the whole lot at once). However my problem is when I try to copy them one by one without a WScript.Sleep between each loop iteration I get a "File not found or no read permission." error; if I place a WScript.Sleep 200 after each write it works but not 100% of the time.

Pretty much I'd like to get rid of the Sleep function and not rely on that because depending on the file size it may take longer to write therefore 200 milliseconds may not be enough etc.

As you can see with the small piece of code below, I loop through the files, then if they match the extension I place them into the .zip (zipFile)

For Each file In folderToZip.Items
    For Each extension In fileExtensions
        if (InStr(file, extension)) Then
            zipFile.CopyHere(file)
            WScript.Sleep 200
            Exit For
        End If
    Next
Next

Any suggestions on how I can stop relying on the Sleep function?

Thanks

Answer 1

This is how we do it in VB6. After calling CopyHere on the zip we wait for async compression to complete like this

    Call Sleep(100)
    Do
        Do While Not pvCanOpenExclusive(sZipFile)
            Call Sleep(100)
        Loop
        Call Sleep(100)
    Loop While Not pvCanOpenExclusive(sZipFile)

where the helper function looks like this

Private Function pvCanOpenExclusive(sFile As String) As Boolean
    Dim nFile       As Integer

    nFile = FreeFile
    On Error GoTo QH
    Open sFile For Binary Access Read Lock Write As nFile
    Close nFile
    pvCanOpenExclusive = True
QH:
End Function

Nice side-effect is that even if zipping fails this will not end up in infinite loop.

The trouble comes when accessing the zip-file when it's closed by zipfldr.dll, that is when pvCanOpenExclusive returns true.

Answer 2

Here is a trick I used in VB; get the length of the zip file before the change and wait for it to change - then wait another second or two. I only needed two specific files but you could make a loop out of this.

Dim s As String
Dim F As Object 'Shell32.Folder
Dim h As Object 'Shell32.Folder
Dim g As Object 'Shell32.Folder
Dim Flen As Long, cntr As Long, TimerInt As Long
Err.Clear
s = "F:\.zip"
NewZipFolder s
Flen = FileLen(s)
Set F = CreateObject("Shell.Application").namespace(CVar(s))
TimerInt = FileLen("F:\MyBigFile.txt") / 100000000  'set the loop longer for bigger files
F.CopyHere "F:\DataSk\DemoData2010\Test.mdf"
Do
    cntr = Timer + TimerInt
    Do
        DoEvents: DoEvents
    Loop While cntr > Timer
    Debug.Print Flen
Loop While Flen = FileLen(s)
    cntr = Timer + (TimerInt / 2)
    Do
        DoEvents: DoEvents
    Loop While cntr > Timer
Set F = Nothing
Set F = CreateObject("Shell.Application").namespace(CVar(s))


F.CopyHere "F:\MynextFile.txt"

MsgBox "Done!"

Answer 3

The solution we used after much debugging and QA on various windows flavours, including fast and slow machines and machines under heavy CPU load was the following snippet.

Critique and improvements welcome.

We were not able to find a way of doing this without a loop, that is, if you wanted to do some validation or post zipping work.

The goal was to build something that ran reliably on as many windows flavours as possible. Ideally as natively as possible too.

Be advised that this code is still is NOT 100% reliable but its seems to be ~99%. As stable as we could get it with the dev and QA time available. Its possible that increasing iSleepTime could make it 100%

Points of note:

• The unconditional sleep seems to be the most reliable and compatible approach we found
• The iSleepTime should not be reduced, it seems the more frequently the loop runs, the higher the probability of an error, seemingly related to the internal operations of the zip/copy process
• iFiles is the source file count
• The more simplistic the loop was, the better, for example outputting oZippp.Items().Count in the loop caused inexplicable errors that looked like they could be related to file access/sharing/locking violations. We didn't spend time tracing to find out.
• It seems on Windows 7 anyway, that the internals of the zipping process use a temp file located in the cwd of the compressed zip folder, you can see this during long running zips by refreshing your explorer window or listing dir with cmd
• We had success with this code on Windows 2000, XP, 2003, Vista, 7

• You'd probably want to add a timeout in the loop, to avoid infinite loops

  'Copy the files to the compressed folder
  oZippp.CopyHere oFolder.Items()
  iSleeps = 0
  iSleepTime = 5
  On Error Resume Next
  Do
      iSleeps = iSleeps + 1
      wScript.Sleep (iSleepTime * 1000)
  Loop Until oZippp.Items().Count = iFiles
  On Error GoTo 0
  
  
  If iFiles <> oZippp.Items().Count Then
      ' some action to handle this error case
  Else
      ' some action to handle success
  End If
  

Answer 4

You are correct, CopyHere is asynchronous. When I do this in a vbscript, I sleep until the count of files in the zip, is greater than or equal to the count of files copied in.

Sub NewZip(pathToZipFile)

   WScript.Echo "Newing up a zip file (" & pathToZipFile & ") "

   Dim fso
   Set fso = CreateObject("Scripting.FileSystemObject")
   Dim file
   Set file = fso.CreateTextFile(pathToZipFile)

   file.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)

   file.Close
   Set fso = Nothing
   Set file = Nothing

   WScript.Sleep 500

End Sub



Sub CreateZip(pathToZipFile, dirToZip)

   WScript.Echo "Creating zip  (" & pathToZipFile & ") from (" & dirToZip & ")"

   Dim fso
   Set fso= Wscript.CreateObject("Scripting.FileSystemObject")

   If fso.FileExists(pathToZipFile) Then
       WScript.Echo "That zip file already exists - deleting it."
       fso.DeleteFile pathToZipFile
   End If

   If Not fso.FolderExists(dirToZip) Then
       WScript.Echo "The directory to zip does not exist."
       Exit Sub
   End If

   NewZip pathToZipFile

   dim sa
   set sa = CreateObject("Shell.Application")

   Dim zip
   Set zip = sa.NameSpace(pathToZipFile)

   WScript.Echo "opening dir  (" & dirToZip & ")"

   Dim d
   Set d = sa.NameSpace(dirToZip)

   ' for diagnostic purposes only
   For Each s In d.items
       WScript.Echo  s
   Next


   ' http://msdn.microsoft.com/en-us/library/bb787866(VS.85).aspx
   ' ===============================================================
   ' 4 = do not display a progress box
   ' 16 = Respond with "Yes to All" for any dialog box that is displayed.
   ' 128 = Perform the operation on files only if a wildcard file name (*.*) is specified. 
   ' 256 = Display a progress dialog box but do not show the file names.
   ' 2048 = Version 4.71. Do not copy the security attributes of the file.
   ' 4096 = Only operate in the local directory. Don't operate recursively into subdirectories.

   WScript.Echo "copying files..."

   zip.CopyHere d.items, 4

   Do Until d.Items.Count <= zip.Items.Count
       Wscript.Sleep(200)
   Loop

End Sub

Answer 5

You can try accessing the file you've just copied, for example with an "exists" check:

For Each file In folderToZip.Items
    For Each extension In fileExtensions
        If LCase(oFSo.GetExtensionName(file)) = LCase(extension) Then
            zipFile.CopyHere(file)
            Dim i: i = 0
            Dim target: target = oFSO.BuildPath(zipFile, oFSO.GetFileName(file))
            While i < 100 And Not oFSO.FileExists(target) 
              i = i + 1
              WScript.Sleep 10
            Wend
            Exit For
        End If
    Next
Next

I'm not sure if target is calculated correctly for this use context, but you get the idea. I'm a bit surprised that this error occurs in the first place... FileSystemObject should be strictly synchronous.

If all else fails, do this:

For Each file In folderToZip.Items
    For Each extension In fileExtensions
        If LCase(oFSo.GetExtensionName(file)) = LCase(extension) Then
            CompressFailsafe zipFile, file
            Exit For
        End If
    Next
Next

Sub CompressFailsafe(zipFile, file)
  Dim i: i = 0
  Const MAX = 100

  On Error Resume Next
  While i < MAX
    zipFile.CopyHere(file)
    If Err.Number = 0 Then 
      i = MAX
    ElseIf Err.Number = xxx ''# use the actual error number!
      Err.Clear
      WScript.Sleep 100
      i = i + 1
    Else 
      ''# react to unexpected error
    End Of
  Wend
  On Error GoTo 0
End Sub