Zipping a large folder fails - vbscript

Question

I am trying to archive logs to capture an intermittent fault where my logs are regularly overwritten. I wish to archive the logs to ensure I capture the required event.
I have written what appears to be funcional code to perform this, however if the folder is very large, the zip fails. If I point it to a smaller directory, it works without issue.
There is no error generated, and I would appreciate any assistance in identifying the cause.
As I have never programmed in VBS before, I apologise in advance if this seems a simple question.
Option Explicit
dim objFSO, objFolder, FolderToZip, ziptoFile
dim ShellApp, eFile, oNewZip, strZipHeader
dim ZipName, Folder, i, Zip
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("D:\Program Files\afolder")
Wscript.Sleep 2000
Set oNewZip = objFSO.OpenTextFile("C:\Archive\logs_" & day(date) & month(Date) & Year(date)& ".zip", 8, True)
strZipHeader = "PK" & Chr(5) & Chr(6)
For i = 0 to 17
strZipHeader = strZipHeader & Chr(0)
Next
oNewZip.Write strZipHeader
oNewZip.Close
Set oNewZip = Nothing
WScript.Sleep 5000
FolderToZip = "D:\Program Files\afolder"
ZipToFile = "C:\Archive\logs_" & day(date) & month(Date) & Year(date)& ".zip"
Set ShellApp = CreateObject("Shell.Application")
Set Zip= ShellApp.NameSpace(ZipToFile)
Set Folder= ShellApp.NameSpace(FolderToZip)
Zip.CopyHere(FolderToZip)
WScript.Sleep 2000

Answer 1

Your code is a little more complicated than it needs to be, but it works in principle. What's causing the failures you're experiencing with large folders is the fixed 2 second delay at the end:
WScript.Sleep 2000
CopyHere runs asynchronously, meaning that it runs in the background while the script continues. However, after 2 seconds delay the script terminates (and the Shell.Application instance with it), whether CopyHere has finished or not. When you have numerous/large files the processing may well take more than 2 seconds.
That's why your script works fine for small folders, but not for large ones. The copying simply isn't finished when the script terminates after 2 seconds.
To avoid this, replace the fixed delay with a check that compares the number of processed files to the total file count:
Set fso = CreateObject("Scripting.FileSystemObject")
Set app = CreateObject("Shell.Application")
zipfile = "C:\Temp\logs_" & Day(Date) & Month(Date) & Year(Date) & ".zip"
fldr = "C:\Temp\sample"
cnt = fso.GetFolder(fldr).Files.Count
'create a new empty zip file
fso.OpenTextFile(zipfile, 2, True).Write "PK" & Chr(5) & Chr(6) _
& String(18, Chr(0))
'start copying the files from the source folder to the zip file
Set zip = app.NameSpace(zipfile)
zip.CopyHere app.NameSpace(fldr).Items '<- runs asynchronously!
'wait for CopyHere to finish
Do
WScript.Sleep 100
Loop Until zip.Items.Count = cnt