VBScript - Error 0x80041017 (null) - vbscript

IMPORTANT UPDATE:
As Cheran S stated below, it's a good idea to avoid using "taskmgr" for this script. I'm not going to edit the code, as I feel it's best to maintain the original question as much as possible since doing so would partially invalidate & obfuscate Cheran's answer & comment.
A good alternative to "taskmgr" would be "CharMap" (for simple & fast testing).
Running Windows XP Professional (32-bit) and I've got this script that's throwing up this error:
Script: C:\test.vbs
Line: 40
Char: 3
Error: 0x80041017
Code: 80041017
Source: (null)
Here's the code:
Set objWshShell = Wscript.CreateObject("Wscript.Shell")
Set objWshNet = CreateObject("Wscript.Network")
strComputer = objWshNet.ComputerName
Set objWMIService = GetObject("winmgmts:" & _
"{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Dim arrWinTitle(2)
arrWinTitle(0) = "My Documents"
arrWinTitle(1) = "Control Panel"
Dim arrProcName(3)
arrProcName(0) = "'taskmgr.exe'"
arrProcName(1) = "'calc.exe'"
arrProcName(2) = "'notepad.exe'"
Sub srBlockWindow(strWinTitle, intWinTitle, strProcName, intProcName)
i = 0
Do While i = 0
If objWshShell.AppActivate(strWinTitle(intWinTitle)) Then
objWshShell.AppActivate(strWinTitle(intWinTitle))
Wscript.Sleep 100
objWshShell.SendKeys "%{F4}"
Wscript.Sleep 100
End If
If intWinTitle = 0 Then
intWinTitle = intWinTitle + 1
Else
intWinTitle = 0
End If
Wscript.Sleep 100
Set colProcesses = objWMIService.ExecQuery _
("SELECT * FROM Win32_Process WHERE NAME = " & strProcName(intProcName))
For Each objProcess In colProcesses
objProcess.Terminate()
Next
If intProcName >= 0 Then
intProcName = intProcName + 1
ElseIf intProcName >= 5 Then
intProcName = 0
End If
Set colProcesses = Nothing
Loop
End Sub
Call srBlockWindow(arrWinTitle, 0, arrProcName, 0)
I've reviewed this, but I believe my script doesn't have any issues with the quotes. For the sake of clarity, I'm getting the error at the start of the "For Each ..." string.
What's peculiar is that it will run fine the first time, but once it loops, that's when I get the error. So, it will close all the desired Windows/Applications, but once it goes through it's second iteration, I get the error. I've inserted "On Error Resume Next", but that doesn't resolve it (I will add it later, since it's required to resolve the conflict when the Window/Process Starts simultaneously with Close/End/Stop attempts made by the Script).
I think it's because I should be conditionally checking if the process exists; problem is, I'm not quite sure how to do that with this code (I've never been good with Collections). Anybody have suggestions on how to do it with this code specifically?
I reviewed this and tried to write a quick alternative script, but it didn't really work. Here's the code:
Set service = GetObject("winmgmts:")
Dim arrProcName(3)
arrProcName(0) = "'taskmgr.exe'"
arrProcName(1) = "'calc.exe'"
arrProcName(2) = "'notepad.exe'"
Sub srTest(strProc, intProc)
i = 0
Do While i = 0
For Each Process In Service.InstancesOf("Win32_Process")
If Process.Name = strProc(intProc) Then
Process.Name.Terminate
Process.Terminate
End If
Next
If intProc = 0 Then
intProc = intProc + 1
ElseIf intProc >= 3 Then
intProc = 0
End If
Loop
End Sub
Call srTest(arrProcName, 0)
As you can see, I tried both "Process.Terminate" & "Process.Name.Terminate", but neither yielded anything (not even an error). I further tested it with "Wscript.Echo Process.Name" & "Wscript.Echo strProc(intProc)", but neither of these worked too.
Now that I've failed at this alternative solution, I'm feeling that I'm wildly stabbing in the dark for solutions, so I'll defer these esoteric challenges to the community that is vastly superior to me.
There might be a few here who are reading this and wondering why I'm targeting My Documents, Control Panel, taskmgr.exe, calc.exe, & notepad.exe. Almost everybody reading this will probably be able to extrapolate on their own, but I'll make sure I'm clear on this for those who need it. I'm doing this because it makes it easier to test, since all of these can be accessed simply by using the "Run" shortcut (Windows Key + R) & then entering the following strings (one at a time, of course):
My Documents
Control
taskmgr
calc
notepad
You likely knew the keywords, but I just wanted to highlight why I'm using these specific ones (speed & simplicity).
I'll remove this if Cheran adds the final code to the answer posted
Final Solution:
Set objWshShell = Wscript.CreateObject("Wscript.Shell")
Set objWshNet = CreateObject("Wscript.Network")
strComputer = objWshNet.ComputerName
Set objWMIService = GetObject("winmgmts:" & _
"{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Dim arrWinTitle
arrWinTitle = Array("My Documents", "Control Panel")
Dim arrProcName
arrProcName = Array("'charmap.exe'", "'calc.exe'", "'notepad.exe'")
Sub srBlockWindow(strWinTitle, intWinTitle, strProcName, intProcName)
i = 0
Do While i = 0
On Error Resume Next
' In the Event of Conflict w/Initiation of Window or Process
If objWshShell.AppActivate(strWinTitle(intWinTitle)) Then
objWshShell.AppActivate(strWinTitle(intWinTitle))
Wscript.Sleep 100
objWshShell.SendKeys "%{F4}"
Wscript.Sleep 100
End If
intWinTitle = (intWinTitle + 1) Mod (UBound(strWinTitle) + 1)
Wscript.Sleep 100
Set colProcesses = objWMIService.ExecQuery _
("SELECT * FROM Win32_Process WHERE NAME = " & strProcName(intProcName))
For Each objProcess In colProcesses
objProcess.Terminate()
Next
intProcName = (intProcName + 1) Mod (UBound(strProcName) + 1)
Set colProcesses = Nothing
Loop
End Sub
Call srBlockWindow(arrWinTitle, 0, arrProcName, 0)
Here's a quick script I threw together to test it against:
Set objWshShell = Wscript.CreateObject("Wscript.Shell")
i = 0
Do While i = 0
objWshShell.Run "explorer.exe /e, C:\Documents and Settings\User\My Documents"
Wscript.Sleep 200
objWshShell.Run "CharMap.exe"
Wscript.Sleep 200
objWshShell.Run "Control.exe"
Wscript.Sleep 200
objWshShell.Run "calc.exe"
Wscript.Sleep 200
objWshShell.Run "notepad.exe"
Wscript.Sleep 200
Loop
BE CAREFUL! Adjust the timings so that you can end "Wscript.exe" without too many problems. Best to run both scripts simultaneously to see how it works.

Two big issues I found:
The main problem here is in the way you define your arrays. The number you specify in the array declaration is the largest array subscript. Since VBScript arrays are always indexed starting at 0, you actually need to specify one less than the number of elements in the array.
' This is wrong:
Dim arrWinTitle(2)
Dim arrProcName(3)
' Should be:
Dim arrWinTitle(1)
Dim arrProcName(2)
You could also use the Array function to initialize your array, assuming that you know beforehand how many elements are in it. In that case, you would just declare arrWinTitle as a Variant and not as an array:
Dim arrWinTitle
arrWinTitle = Array("My Documents", "Control Panel")
If you make that change and try to run the script, you'll still get a "Subscript out of range" error. That error is caused by this block:
If intProcName >= 0 Then
intProcName = intProcName + 1
ElseIf intProcName >= 5 Then
intProcName = 0
End If
First off, the maximum subscript should be 2 for strProcName, and not 5. Even then, this code won't work. It seems like what you're trying to do is loop through the elements of array, then start over back at 0. A better of doing this is with the Mod operator:
intProcName = (intProcName + 1) Mod (UBound(strProcName) + 1)
Notice also how I use the UBound function to avoid hard-coding the actual length of the array.
I won't spend too much time analyzing your second example, since it was just an attempt to make the first example work. I will note, however, that in your arrProcName array, the process names still have the single quotes around them, which is one reason why that script didn't work either.

Related

QTP-UFT-Weblist selection by sendkeys-How to keep control key pressed while selecting multiple values

Wsh.SendKeys "^"&a(i) is not holding the control down. Something like micCtrldown and micctrlup before and after sending the values would be helpful But not sure about the syntax
Set Wsh = CreateObject("Wscript.Shell")
a = Split(Datatable.Value("AssignedTerminal", dtlocalsheet),",")
b = ubound(a)
wait 3
Browser("P&D Routing -Estes").Page("P&D Routing Estes").WebList("addAssignedTerminal_Add").Click
Setting.WebPackage("ReplayType") = 2
Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys "{DOWN}"
For i = 0 To b
Wsh.SendKeys "^"&a(i)
Next
Set WshShell = Nothing
Setting.WebPackage("ReplayType") = 1
Are we sure the SendKeys function supports the concatenated string you are sending it?
For i = 0 To b
Wsh.SendKeys "^"&a(i)
Next
Try to use a predefined string to send to SendKeys instead of building it inline.

measuring print job time programmatically

I need to measure print job time, which means time between 'send print command' and 'print job disappear from the print queue'
so I am trying to do these things by script
search all pdf files
print a file
get the print time (as above)
go to next file and do all above for all files
this is my work so far(i omit some parts)
For Each file In objFolder.Items
' check for the extension
if objFSO.GetExtensionName(file.name) = "pdf" then
' invoke to print
file.InvokeVerbEx( "Print" )
' select print jobs
Set Printers = objWMIService.ExecQuery _
("Select * from Win32_PrintJob")
For Each objPrinter in Printers
DateTime.Value = objPrinter.TimeSubmitted
TimeinQueue = DateDiff("n", actualTime, Now)
Wscript.Echo TimeinQueue
Next
end if
next
mainly i need to ask how can i get the time when print job disappear from the print queue.
And I need to keep next job till one print job ends.
any ideas ?
There's no simple way to obtain that information from inside your script, because when the job is removed from the print queue it's gone. You could set up an event monitor for the print spooler like this:
Set wmi = GetObject("winmgmts://./root/cimv2")
Set wbemDateTime = CreateObject("WbemScripting.SWbemDateTime")
qry = "SELECT * FROM __InstanceOperationEvent WITHIN 1 " & _
"WHERE TargetInstance ISA 'Win32_PrintJob'"
Set mon = wmi.ExecNotificationQuery(qry)
Do
Set evt = mon.NextEvent
If evt.Path_.Class = "__InstanceDeletionEvent" Then
wbemDateTime.Value = evt.TargetInstance.TimeSubmitted
WScript.Echo evt.TargetInstance.Document & ": " & _
DateDiff("n", wbemDateTime.GetVarDate, Now)
End If
Loop
However, you'd have to run that from a different script, because VBScript doesn't support multi-threading (i.e. running things in parallel), so the event handler loop would block the rest of your script operations.
If you want a rough value from within your script, you could try something like this, but don't expect queue times to be very accurate:
'singleton SWbemDateTime instance for time conversions
Set wbemDateTime = CreateObject("WbemScripting.SWbemDateTime")
'global list to keep track of printing documents
'MUST NOT BE MODIFIED FROM ANYWHERE EXCEPT CheckPrintQueue!
Set printingDocs = CreateObject("Scripting.Dictionary")
Function CheckPrintQueue
Set printJobs = objWMIService.ExecQuery("SELECT * FROM Win32_PrintJob")
Set currentDocs = CreateObject("Scripting.Dictionary")
'get currently printing jobs from queue
For Each job In printJobs
currentDocs.Add job.Document, job.TimeSubmitted
Next
'compare global list to current list, print the queue time for documents
'that are no longer queued, and remove them from the global list
For Each doc In printingDocs.Keys
If Not currentDocs.Exists(doc) Then
wbemDateTime.Value = printingDocs(doc)
WScript.Echo doc & ": " & DateDiff("n", wbemDateTime.GetVarDate, Now)
printingDocs.Remove doc
End If
Next
'add new documents to global list
For Each doc In currentDocs.Keys
If Not printingDocs.Exists(doc) Then printingDocs.Add doc, currentDocs(doc)
Next
CheckPrintQueue = printJobs.Count
End Function
For Each file In objFolder.Items
If objFSO.GetExtensionName(file.name) = "pdf" Then
file.InvokeVerbEx "Print"
CheckPrintQueue
End If
Next
'wait until all jobs finished printing
Do While CheckPrintQueue > 0
WScript.Sleep 100
Loop
I was looking for exact thing and I simply summurized ansgar's script to get what I want.
its take every pdf files and print 5 times each(so i can get a avarage which better) while getting the time.finally print them in to a csv file. and untill one going to desapear from the print queue others wait waits. Not 100% acuurate but enough for the perfomance comparision
may be it may usefull (please correct my mistakes if any)
Dim objFSO, outFile
const forAppending = 8
const useDefault = -2
'Output File name
fileName = ".\output.csv"
Set objFSO = CreateObject("Scripting.FileSystemObject")
set outFile = objFSO.OpenTextFile(fileName, forAppending, true, useDefault)
'write heading to output file
outFile.WriteLine("Filename,1,2,3,4,5")
'get current Folder
strFolder = Replace(wscript.scriptfullname,wscript.scriptname,".\")
strFolder = objFSO.getFolder(strFolder)
'Open the Shell Folders object
Set objShell = CreateObject( "Shell.Application" )
'Create an object for the specified file's parent folder
Set objFolder = objShell.Namespace( strFolder )
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
For Each file In objFolder.Items
If objFSO.GetExtensionName(file.name) = "pdf" Then
'write in to out file
outFile.write(file.name)
outFile.writeLine ""
'outer loop for 5 times per each file
index = 0
do while index < 5
'if already doing a printing do not start a new one
if CheckPrintQueue() = 0 then
file.InvokeVerbEx "Print"
startTime = timer
waitTostart
'if first time on outer loop it should be empty queue
else
if index = 0 then
wscript.echo "queue doesnt empty"
finish
end if
end if
'wait until all jobs finished printing
waitToEnd
'count time
ellapsTime = timer - startTime
'write in to out file
outFile.write(",")
outFile.Write(ellapsTime)
index = index + 1
loop
End If
Next
outFile.Close
'----------------function CheckPrintQueue-----------------------
Function CheckPrintQueue()
Set printJobs = objWMIService.ExecQuery("SELECT * FROM Win32_PrintJob")
Set currentDocs = CreateObject("Scripting.Dictionary")
CheckPrintQueue = printJobs.Count
End Function
'----------------end of function-----------------
sub waitTostart
Do
WScript.Sleep 100
'check print queue
printJobCount = CheckPrintQueue()
Loop until printJobCount > 0
end sub
sub waitToEnd
Do
WScript.Sleep 100
'check print queue
printJobCount = CheckPrintQueue()
Loop until printJobCount = 0
end sub
sub finish
outFile.Close
objFSO = nothing
objFolder = nothing
objShell = nothing
objWMIService = nothing
wscript.quit 1
end sub

For each loop syntax error

There is a problem with this Windows Installer package. A program run as part of the setup did not finish as expected. Contact your support personnel or package vendor
Hey I wrote this script delete shares of a computer but when I run my script it repeats the same wscript.echo statating the share being deleted. Why does my code never end when run How do I fix that.
My fumction:
'The function that is called to run the command Line that deletes a specific share from a pc
Function DeleteThisShare(Share)
Dim objShell
'Logging The deleted Approved Shares
objDeletedFile.WriteLine (Now & " - Removed share " & Trim(Share))
DeleteThisShare = "net share " & chr(34) & Share & chr(34) &" /DELETE"
Wscript.echo DeleteThisShare
Set objShell = CreateObject("Wscript.Shell")
objShell.Run DeleteThisShare
End Function
My loops:
'Compares The UnApproved Shares to the Current Shares
For Each objItem In colItems
Dim StrNonUnapprovedShares, Item
StrCurrentShares = objItem.name
if instr(AdminShares,lcase(objitem.name)) > 0 or mid(objitem.name,2,1) = "$" or left(lcase(objitem.name),10) = "pkgsvrhost" then
'Skipping known admin share
Else
For each Item in arrUnApprovedLines
If Lcase(Item) = Lcase(strCurrentShares) Then
StrNonUnapprovedShares = (StrNonUnapprovedShares & strCurrentShares & vbCrLf)
End If
Next
End If
Next
Dim notUnapprovedShares, notUnapprovedLines
notUnapprovedLines = StrNonUnapprovedShares
notUnapprovedLines = Split(notUnapprovedLines, vbCrLf)
Dim y, Line2
For y = 0 to uBound(notUnapprovedLines)
Line2 = Trim(notUnapprovedLines(y))
If len(Line2) > 0 Then
DeleteThisShare(Line2)
End If
Next
I think the problem is caused by using the function name as a variable. That's okay with VB that you're compiling, but I don't think VBScript recognizes it in the same way. Use a separate variable name in place of DeleteThisShare, e.g. strDeleteThisShare.
If I had to guess it's because you're creating a recursive loop by having your script echo the DeleteThisShare function. The function gets to that line and is called again before it's able to carry on.
Try to only assign values to the result of the function and use local variables to store any other debugging / temporary values.

VBScript: how to inspect validity of SWbemObjectSet?

I have the following VBScript:
SET Wmi = GetObject("winmgmts:\\.\root\cimv2")
SET QR = Wmi.ExecQuery("SELECT * FROM Win32_Processor")
MsgBox("" & QR.Count)
Which works perfectly fine. However, when I query something which doesn't exist:
SET Wmi = GetObject("winmgmts:\\.\root\cimv2")
SET QR = Wmi.ExecQuery("SELECT * FROM Win32_DoesNotExist")
MsgBox("" & QR.Count)
I get the following error message:
Script: E:\test.vbs
Line: 3
Char: 1
Error: Invalid class
Code: 80041010
Source: SWbemObjectSet
How can I know whether the QR object is valid?
If I call TypeName(QR), it will say SWbemObjectSet, but as soon as I try to query one of its properties, it fails with the above message.
I've googled for this error, and most pages seem to say something to the effect of "just don't do that query". This is not an option, unfortunately, because I want to run the same script on multiple versions of Windows, and Microsoft occasionally deprecates WMI classes in new versions of Windows. I want my script to handle that gracefully.
Edit;
.Count seems to work for a schema query;
dim testNs: testNs = "Win32_DoesNotExist"
dim colClasses: set colClasses = Wmi.ExecQuery("Select * From Meta_Class where __Class = """ & testNs & """")
msgbox colClasses.count
You could wrap-n-trap the access error;
SET QR = Wmi.ExecQuery("SELECT * FROM Win32_DoesNotExist")
dim i: i = getCount(QR)
if (i < 0) then
msgbox "oopsy"
else
msgbox "count is " & i
end if
function getCount(wmiCol)
on error resume next
getCount = QR.Count
if (err.number <> 0) then getCount = (-1)
on error goto 0
end function

Write to file using CopyHere without using WScript.Sleep

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
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.
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
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
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
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!"

Resources