measuring print job time programmatically - vbscript

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

Related

Why can't I copy a file to a location using an environment variable?

I have this code that copies outlook PST files, and when used with the full location file path it runs perfectly fine. I've added a method to run %UserProfile% in the first line as this needs to be run in a domain context from GPO and doing it individually is non-feasible. This runs and closes outlook and reopens it at the appropriate time except one thing is amiss.
It is no longer copying the appropriate files. I echoed the initial %userprofile% sections and it is reading the correctly as "drive letter"\users\userprofile. I'm not sure where this is breaking or how to identify it.
'===================BEGIN MODIFY====================================
Set objShell = CreateObject("WScript.Shell")
userProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")
'Set the amount of pst-files you want to copy. Start counting at 0!
ReDim pst(1)
'Define the location of each pst-file to backup. Increase the counter!
pst(0) = "%UserProfile%\AppData\Local\Microsoft\Outlook\PST\Outlook Data File - mike.pst"
pst(1) = "%UserProfile%\AppData\Local\Microsoft\Outlook\PST\Archive.pst"
'Define your backup location
BackupPath = "%UserProfile%\Documents\Outlook Backups\"
'Keep old backups? TRUE/FALSE
KeepHistory = FALSE
'Maximum time in milliseconds for Outlook to close on its own
delay = 30000 'It is not recommended to set this below 8000
'Start Outlook again afterwards? TRUE/FALSE
start = TRUE
'===================STOP MODIFY====================================
'Close Outlook
Call CloseOutlook(delay)
'Outlook is closed, so we can start the backup
Call BackupPST(pst, BackupPath, KeepHistory)
'Open Outlook again when desired.
If start = TRUE Then
Call OpenOutlook()
End If
Sub CloseOutlook(delay)
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
'If Outlook is running, let it quit on its own.
For Each Process in objWMIService.InstancesOf("Win32_Process")
If StrComp(Process.Name,"OUTLOOK.EXE",vbTextCompare) = 0 Then
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Quit
WScript.Sleep delay
Exit For
End If
Next
'Make sure Outlook is closed and otherwise force it.
Set colProcessList = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'Outlook.exe'")
For Each objProcess in colProcessList
objProcess.Terminate()
Next
Set objWMIService = Nothing
Set objOutlook = Nothing
set colProcessList = Nothing
End Sub
Sub BackupPST(pst, BackupPath, KeepHistory)
Set fso = CreateObject("Scripting.FileSystemObject")
If KeepHistory = True Then
ArchiveFolder = Year(Now) & "-" & Month(Now) & "-" & Day(Now)
BackupPath = BackupPath & ArchiveFolder & "\"
End If
For Each pstPath in pst
If fso.FileExists(pstPath) Then
fso.CopyFile pstPath, BackupPath, True
End If
Next
Set fso = Nothing
End Sub
Sub OpenOutlook()
Set objShell = CreateObject("WScript.Shell")
objShell.Run "Outlook.exe"
End Sub
When you declared userProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%"), you put the path of %UserProfile% in the variable named userProfilePath, but afterward you don't use this variable. That's a problem, because a few lines down, what you end up doing is declaring pst(#) with %userprofile% as a string, which doesn't work.
In other words, the %UserProfile% environment path/string needs to be expanded before being used as a path.
Your code would work if you used the userProfilePath variable you declared:
'Define the location of each pst-file to backup. Increase the counter!
pst(0) = userProfilePath+"\AppData\Local\Microsoft\Outlook\PST\Outlook Data File - mike.pst"
pst(1) = userProfilePath+"\AppData\Local\Microsoft\Outlook\PST\Archive.pst"
'Define your backup location
BackupPath = userProfilePath"\Documents\Outlook Backups\"
instead of
'Define the location of each pst-file to backup. Increase the counter!
pst(0) = "%UserProfile%\AppData\Local\Microsoft\Outlook\PST\Outlook Data File - mike.pst"
pst(1) = "%UserProfile%\AppData\Local\Microsoft\Outlook\PST\Archive.pst"
'Define your backup location
BackupPath = "%UserProfile%\Documents\Outlook Backups\"

VBScript inconsistent Column count

Being I'm a novice at VBS, I'm have a hard time determining why this short script is not returning a column count of 193, One time I'll get the correct count and others I get 0.
Thank you in advance for any and all suggestions.
OldCityCat
Sub VerifyOrders
Dim Results
Dim objFSO, objTextFile, objReadFile, Contents, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile("C:\TestFileWith_194_characters.csv")
Set objTextFile = objFSO.OpenTextFile("C:\TestFileWith_194_characters.csv")
Set objReadFile = objFSO.OpenTextFile("C:\TestFileWith_194_characters.csv",1)
objReadFile.ReadAll
Contents = objReadFile.Column -1
WScript.Echo Contents
If Contents < 194 Then
Results = "No Orders"
Else
Results = "Has Orders"
End if
objReadFile.Close
If Results = "No Orders" Then
Call NoOrders
Else
Call OpenAccess
End If
End Sub
'/ If no orders the send email end script. Else If orders process them
Sub NoOrders
If Results = "No Orders" Then
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
objMail.Display
objMail.Recipients.Add ("gchichester#wilk.us.com")
objMail.Subject = "No Sales Orders to Process"
objMail.Body = "Respect didn't receive any orders for Pine Castle"
objMail.Send
objOutlook.Quit
Set objMail = Nothing
Set objOutlook = Nothing
End If
End Sub
Sub OpenAccess
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Exec("C:\Program Files (x86)\Microsoft Office\Office14\MSACCESS.EXE "&" C:\DropBox\Inflow\DrugSales.accdb /x OnOpen")
WScript.Sleep 60000
WshShell.SendKeys "%{F4}"
End Sub
You are getting 0 when the contents of the text file you're reading from has written a newline character, but nothing else.
From the Microsoft documentation:
After a newline character has been written, but before any other character is written, Column is equal to 1.
Throughly examine the contents of the text file before you attempt to read it in as a text stream.
Of note but not relevant to my answer above: you do not need to declare or set objFile or objTextFile since you are using objReadFile. Suggest removing both the declaration and set operations for both of those variables.

replacing XML values in For-Each and returning in function

The script I have here is attempting to do recurse through an XML file, storing each RegEx match (stored in a search array) into 2 result arrays; 1 for start date, 1 for end date.
Ubounds of both arrays are checked for equality then the text is passed to a function that uses XMLDOM to find the End_Date node in each parent node, then passes that text to another function, adding 30 days and then passing it back, replacing the previous value. Then it's supposed to write back the contents to the file and save it.
I've got a few problems here. 1. I can't get the +30 day value to be passed back to anything past the first parent node--memory space seems to retain the +30 day value from previous For-Each iteration. 2. I can't write anything back to the file.
I was initially writing for text files, but the format changed to XML as the requirements changed on our project.
I'd love to be able to do this all in XMLDOM in vbscript and just use functions to do specific data changes. But my main concern is my sloppy script not doing the basics.
Can anyone help me by pointing out the flaws in the loops I'm running? I've hit a wall and just can't seem to make any more progress!
Here's the XML file I'm reading(shortened to 2 Ad nodes w/ a ton of child nodes removed):
<?xml version="1.0" encoding="utf-8"?>
<XMLFeederRoot>
<ADS_CREATE_TIME>2016-06-07T01:35:39</ADS_CREATE_TIME>
<Ad>
<Ad_Number>d00524224</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-08-20T00:00:00</End_Date>
<Status>Run</Status>
</Ad><Ad>
<Ad_Number>d00524225</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-08-20T00:00:00</End_Date>
<Status>Run</Status>
</Ad>
</XMLFeederRoot>
Here's the script:
'Setting the Regular Expression object and setting occurrences to all in strings searched.
Set objRegEx= CreateObject("VBScript.RegExp")
objRegEx.Global= True
set Shell= createobject("wscript.shell")
Dim FSO, FLD, FIL, TS, strDate, strEDat, i, d, c
Dim strFolder, strContent, strPath
Const ForReading= 1, ForWriting= 2
strFolder= "C:\Scripts\Run"
Set FSO= CreateObject("Scripting.FileSystemObject")
'Get a reference to the folder you want to search
set FLD= FSO.GetFolder(strFolder)
'loop through the folder and get the files
For Each Fil In FLD.Files
'Open the file to read
Set TS= FSO.OpenTextFile(fil.Path, ForReading)
'Read the contents into a variable
strContent= TS.ReadAll
'Close the file
TS.Close
reDim arrMR(1,1)
arrMR(0,0)= "(\s+)(<Start_Date>(.*?)<\/Start_Date>)"
arrMR(1,0)= "(\s+)(<End_Date>(.*?)<\/End_Date>)"
For i= 0 to Ubound(arrMR)
objRegEx.Pattern= arrMR(i,0)
Set objMatches= objRegEx.Execute(strContent)
d=0
For Each objMatch in objMatches
If i= 0 Then
If d>0 Then
reDim Preserve arrStart(d)
Else
reDim arrStart(d)
End If
arrStart(d)= objMatches.Item(d).SubMatches(2)
'Wscript.Echo arrStart(d)
ElseIf i<> 0 Then
If d>0 Then
reDim Preserve arrEnd(d)
ReDim Preserve arrMatch1(d)
Else
reDim arrEnd(d)
ReDim arrMatch1(d)
End If
arrEnd(d)= objMatches.Item(d).SubMatches(2)
arrMatch1(d)= objMatches.Item(d).SubMatches(1)
End If
If objRegEx.Pattern<> arrMR(0,0) Then
If (ubound(arrStart)= ubound(arrEnd)) Then
'Wscript.Echo "Ubounds Match"
Parse strContent
strContent= Parse(strContent)
Else
'Wscript.Echo "Start & End Dates do not match"
End If
End If
d= d+ 1 'increment to next match
Next
Next
'Close the file
TS.Close
'Open the file to overwrite the contents
Set TS= FSO.OpenTextFile(fil.Path, ForWriting)
'Write the contents back
TS.Write strContent
'Close the current file
TS.Close
Next
'Clean up
Set TS= Nothing
Set FLD= Nothing
Set FSO= Nothing
Function Parse(ParseContent)
'Dim sFSpec : sFSpec = FSO.GetAbsolutePathName("C:\Users\j.levine\Desktop\XML Feeder Scripts\Test_Files\monvid.txt")
Dim oXML : Set oXML = CreateObject("Msxml2.DOMDocument.6.0")
Dim strXMLSDat, strXMLarrStartD, XMLEDat
oXML.setProperty "SelectionLanguage", "XPath"
oXML.async = False
oXML.loadXML(ParseContent)
If 0 = oXML.parseError Then
Dim sXPath3 : sXPath3 = "//XMLFeederRoot/Ad[End_Date=Start_Date]"
Dim ndlFnd : Set ndlFnd = oXML.selectNodes(sXPath3)
If 0 = ndlFnd.length Then
WScript.Echo sXPath, "not found"
ElseIf 0<> ndlFnd.length Then
'WScript.Echo "found", ndlFnd.length, "nodes for", sXPath
Dim ndCur, oldNode
For Each ndCur In ndlFnd
oldNode = oXML.selectsinglenode("//End_Date").text
oldNode= XMLSplitArray(oldNode) 'Pass current Date into Array and add 30 days & return as node text
Set newNode= oXML.selectSingleNode("//End_Date")
newNode.text= oldNode
WScript.Echo ndCur.xml
Next
'WScript.Echo "We have nothing to replace"
End If
Else
WScript.Echo oXML.parseError.reason
End If
Parse= ParseContent
End Function
Function XMLSplitArray(strval1)
dim XmlSA, XmlSA2, XMLEDat
XmlSA = split(strval1, "-")
XmlSA(2) = Left(XmlSA(2), 2)
strXMLDate = XmlSA(1) & "/" & XmlSA(2) & "/" & XmlSA(0)
strXMLDate30 = DateAdd("d", 30, strXMLDate)
XmlSA2 = split(strXMLDate30, "/")
'Add zero to the left
XmlSA2(0)= Right("0" & XmlSA2(0), 2)
XmlSA2(1)= Right("0" & XmlSA2(1), 2)
XmlSA2(1) = XmlSA2(1) & "T00:00:00"
XMLEDat = XmlSA2(2) & "-" & XmlSA2(0) & "-" & XmlSA2(1)
XMLSplitArray= XMLEDat
End Function
Thomas was right w/ the KISS method. I took a big step back, and started over.
Here's what I've come up with. It does what I need regarding the Date+30 and writing back to a file. I think this method is cleaner and will allow me to run my other text massaging through functions.
My questions about this new script are:
1. can this be done without having to write to a new file? Keeping to 1 file is easier.
2. Can I avoid cloning the node and deleting the original one and directly change the original node's value?
3. I seem to be missing how to get that last node <Status> onto it's own line.
Script:
Dim xmlDoc: Set xmlDoc = CreateObject("Msxml2.DOMDocument")
xmlDoc.Async = False
xmlDoc.load "C:\Scripts\Run\MonVid-SHORT.xml"
Dim xmldoc2: set xmldoc2 = CreateObject("Msxml2.DOMDocument")
Dim strSkeleton : strSkeleton= "<?xml version=""1.0"" encoding=""utf-8""?>" & _
"<XMLFeederRoot>" & _
"</XMLFeederRoot>"
xmldoc2.loadXML(strSkeleton)
xmldoc2.save "C:\Scripts\Copy\New_MonVid-Short.xml"
xmlDoc2.async = False
xmlDoc2.load "C:\Scripts\Copy\New_MonVid-Short.xml"
Dim sXPath : sXPath = "/XMLFeederRoot/Ad[Start_Date=End_Date]"
For Each n In XMLDoc.SelectNodes(sXpath)
set l = n.cloneNode(True)
q= l.selectSingleNode("/End_Date").text
strSDat=SplitArray(q)
l.removeChild(l.childNodes.item(2))
set Stat= l.selectSingleNode("/Status")
set Parent= Stat.parentNode
set EDate= xmlDoc2.createElement("End_Date")
EDate.appendChild xmlDoc2.createTextNode(strSDat)
Parent.insertBefore EDate, Stat
xmldoc2.documentElement.appendChild parent
Next
xmlDoc2.save xmldoc2.url
Function SplitArray(strval1)
dim SplitArray1, SplitArray2, strSDat
splitArray1 = split(strval1, "-")
splitArray1(2) = left(splitArray1(2), 2)
strDate1 = SplitArray1(1) & "/" & SplitArray1(2) & "/" & SplitArray1(0)
strDate30 = DateAdd("d", 30, strDate1)
SplitArray2 = split(strDate30, "/")
'Add zero to the left
If Len(SplitArray2(0))<2 Then
SplitArray2(0)= Right("0" & SplitArray2(0), 2)
End If
If Len(SplitArray2(1))<2 Then
SplitArray2(1)= Right("0" & SplitArray2(1), 2)
End If
SplitArray2(1) = splitArray2(1) & "T00:00:00"
strSDat = SplitArray2(2) & "-" & SplitArray2(0) & "-" & SplitArray2(1)
SplitArray= strSDat
End Function
Output File:
<?xml version="1.0" encoding="utf-8"?>
<XMLFeederRoot><Ad>
<Ad_Number>d00524224</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-09-19T00:00:00</End_Date><Status>Run</Status>
</Ad><Ad>
<Ad_Number>d00524225</Ad_Number>
<Start_Date>2016-08-20T00:00:00</Start_Date>
<End_Date>2016-09-19T00:00:00</End_Date><Status>Run</Status>
</Ad>
</XMLFeederRoot>
Since Text and XML files don't use file locks by default just overwrite the original file using xmlDoc.Save monvidPath.
Sub setAdEndDate(monvidPath)
Const sXPath = "/XMLFeederRoot/Ad/End_Date"
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.Async = "False"
xmlDoc.Load(monvidPath)
Set colNodes=xmlDoc.selectNodes(sXPath)
For Each n In colNodes
n.Text = SplitArray(n.Text)
Next
xmlDoc.Save monvidPath
End Sub
Function SplitArray(strval1)
Dim SplitArray1, SplitArray2, strSDat
splitArray1 = Split(strval1, "-")
splitArray1(2) = Left(splitArray1(2), 2)
strDate1 = SplitArray1(1) & "/" & SplitArray1(2) & "/" & SplitArray1(0)
strDate30 = DateAdd("d", 30, strDate1)
SplitArray2 = Split(strDate30, "/")
'Add zero to the left
If Len(SplitArray2(0))<2 Then
SplitArray2(0)= Right("0" & SplitArray2(0), 2)
End If
If Len(SplitArray2(1))<2 Then
SplitArray2(1)= Right("0" & SplitArray2(1), 2)
End If
SplitArray2(1) = splitArray2(1) & "T00:00:00"
strSDat = SplitArray2(2) & "-" & SplitArray2(0) & "-" & SplitArray2(1)
SplitArray= strSDat
End Function

VBS Object required error, 800A01A8

Hello I'm trying to debug this script that I inherited below. The error is on line 71 char 6. Object required 'oFile'
I don't have any vbs experience so please be gentle. This script takes a scan and uploads it to a doc archive server, gives it unique filename etc. I haven't figured out what 'ofile' is yet :/
'Feb 18, 2005
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
hiddenCount = 0
'Wscript.Echo Wscript.Arguments(0)
If Wscript.Arguments.Count = 1 And oFSO.FolderExists(Wscript.Arguments(0)) Then
Set scanFiles = oFSO.GetFolder(Wscript.Arguments(0)).Files
For Each oFile In scanFiles
If oFile.Attributes and 2 Then
hiddenCount = hiddenCount + 1
End If
Next
Else
Set scanFiles = WScript.Arguments
End If
fileCount = scanFiles.Count - hiddenCount
'Wscript.Echo hiddenCount
'WScript.Echo fileCount
'WScript.Quit()
Set oIE = WScript.CreateObject("InternetExplorer.Application")
oIE.left=50 ' window position
oIE.top = 100 ' and other properties
oIE.height = 300
oIE.width = 350
oIE.menubar = 0 ' no menu
oIE.toolbar = 0
oIE.statusbar = 1
oIE.navigate "http://gisweb/apps/doc_archive/scan_login.php?file_count="&fileCount
'WScript.Echo fileCount
oIE.visible = 1
' Important: wait till MSIE is ready
Do While (oIE.Busy)
Loop
' Wait till the user clicks the OK button
' Use the CheckVal function
' Attention: Thanks to a note from M. Harris, we can make
' the script a bit more fool proof. We need to catch the case
' that the user closes the form without clicking the OK button.
On Error Resume Next
Do ' Wait till OK button is clicked
WScript.Sleep 400
Loop While (oIE.document.script.CheckVal()=0)
' If an error occur, because the form is closed, quit the
' script
If err <> 0 Then
WScript.Echo "Sorry, a run-time error occured during checking" & _
" the OK button " & vbCRLF & _
"Error: " & err.number & " " & _
"I guess the form was getting closed..."
WScript.Quit ' end script
End if
On Error Goto 0 ' switch error handling off
' User has clicked the OK button, retrieve the values
docList = oIE.Document.ValidForm.doc_id_list.Value
'MsgBox doc_id
For i = 0 To 100000
x = 1
Next
oIE.Quit() ' close Internet Explorer
Set oIE = Nothing ' reset object variable
docArray = Split(docList,",")
i = 0
For Each oFile In scanFiles
If Not oFile.Attributes And 2 Then **ERROR HERE**
ext = oFSO.GetExtensionName(oFile)
filename = "p"&right("000000"&docArray(i),6)&"."&ext
base = Int(docArray(i) / 500) * 500
subdir = "d"&right("000000"&base,6)
oFSO.CopyFile oFile, "\\ditgis02\Enterprise_GIS\doc_archive\raw\"&subdir&"\"&filename, True
i = i + 1
End If
Next
If Wscript.Arguments.Count = 1 And oFSO.FolderExists(Wscript.Arguments(0)) Then
Set WshShell = WScript.CreateObject("WScript.Shell")
intButton = WshShell.Popup (fileCount&" file(s) logged and copied! Do you want to delete temporary scan files?",0,"Done!",4)
If intButton = 6 Then
For Each oFile In scanFiles
oFile.Delete
Next
End If
Else
WScript.Echo(fileCount&" file(s) logged and copied!")
End If
WScript.Quit() ' Ready
' End
It looks the problem may arise if your initial test fails:
If Wscript.Arguments.Count = 1 And oFSO.FolderExists(Wscript.Arguments(0)) Then
...
Else
Set scanFiles = WScript.Arguments
End If
You're setting the scanFiles variable to a collection of arguments, not files. Later on, near line 71 (where your error occurs), you're treating scanFiles as if it's a Files collection and attempting to access the Attributes property of one of its File objects:
For Each oFile In scanFiles
If Not oFile.Attributes And 2 Then **ERROR HERE**
...
Next
This won't be possible since scanFiles is an Arguments collection instead. So I think you need to fix your initial Else clause to either terminate your script or provide some kind of "default" Files collection.

VBScript: way to check why the script stopped?

I have this VBScript which runs however, while it is processing, it will randomly stop and require a user to hit the spacebar for it to display the rest of its ongoing output.
How do I figure out why this is happening?
Here is a copy of the script:
'On Error Resume Next
Dim arrFolders()
intSize = 0
Function StampNow()
Dim Hr, Mn, Yr, Mon, Dy, Date1
Date1=Now()
Hr=DatePart("h",Date1)
Mn=DatePart("n",Date1)
Yr = DatePart("yyyy",Date1)
Mon = DatePart("m",Date1)
Dy = DatePart("d",Date1)
StampNow = Yr & "-" & Mon & "-" & Dy
end function
'Output log info.
Function OutputToLog (strToAdd)
Dim strDirectory,strFile,strText, objFile,objFolder,objTextFile,objFSO
strDirectory = "c:\log"
strFile = "\dpadmin_copy2run-"& StampNow & ".bat"
'strText = "dpadmin_copy2"
strText = strToAdd
' Create the File System Object.
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Check that the strDirectory folder exists.
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
'WScript.Echo "Just created " & strDirectory
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
'Wscript.Echo "Just created " & strDirectory & strFile
End If
set objFile = nothing
set objFolder = nothing
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForAppending = 8
Set objTextFile = objFSO.OpenTextFile _
(strDirectory & strFile, ForAppending, True)
' Writes strText every time you run this VBScript.
objTextFile.WriteLine(strText)
objTextFile.Close
End Function
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
strFolderName = "D:\1\production\Openjobs"
Set colSubfolders = objWMIService.ExecQuery _
("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
& "Where AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")
dim diffindates
'Init vars for regex.
Dim retVal, retVal2
Dim Lastprop
Dim objRegExpr 'regex variable
Set objRegExpr = New regexp
Set objRegExprX31 = New regexp
objRegExpr.Pattern = "[0-9][0-9][0-9][0-9][0-9][0-9][A-Z][A-Z][A-Z]"
objRegExprX31.Pattern = "[0-9][0-9][0-9][0-9][0-9][0-9]X31"
objRegExpr.Global = True
objRegExprX31.Global = True
objRegExpr.IgnoreCase = True
objRegExprX31.IgnoreCase = True
'Variables for getting last accessed property.
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
'Current time vars.
Dim currenttime
currenttime = Now()
ParentFolder = "D:\1\Production\Openjobs\ClosedJobs"
For Each objFolder in colSubfolders
intSize = intSize + 1
retVal = objRegExpr.Test(objFolder.Name)
retVal2 = objRegExprX31.Test(objFolder.Name)
if (retVal OR retVal2 ) then
'set filename to array
strFolderName = objFolder.Name
'Get last modified date.
Set f = fs.GetFolder(objFolder.Name)
Lastprop = f.DateLastModified
'MsgBox(Lastprop)
if ( DateDiff("m", f.DateLastModified, Now()) > 4) then
diffindates = DateDiff("m", f.DateLastModified, Now())
Set objShell = CreateObject("Shell.Application")
Set objCopyFolder = objShell.NameSpace(ParentFolder)
OutputToLog("rem " & f.DateLastModified & ":" & objFolder.Name )
outputtolog("move /Y """ & objFolder.Name & """ " & ParentFolder)
wscript.echo(diffindates & ":" & objFolder.Name & vbCr)
end if
end if
Next
Update
It stops at the line:
Set objTextFile = objFSO.OpenTextFile _
(strDirectory & strFile, ForAppending, True)
with the error Microsoft VBScript runtime error: Permission denied
I'm a little confusd by this. The logfile was only 356kb
I was able to run your script several times without it pausing for input. Run your script with the //X flag to start it in the debugger:
>cscript //nologo //X dpadmin_copy2.vbs"
You should be able to then step through the code.
You can also start putting in wscript.echo trace statements everywhere and see if you can narrow down what it's waiting on.
One thing that's gotten me in the past; If your command console is in QuickEdit mode and you accidentally click anywhere in the console window, the console will hang while it waits for you to press a key.
Well the first step is to remove any global On Error Resume Next statements. Better feedback would come if we could see the script.
You usually get an Permission denied when trying to write to a text file when the text file already has an open handle from some other process or because you have previously opened a handle earlier in you code which you have not closed. I haven't tried this but I don't know why this wouldn't work, you can look at using Handle from Sysinternals (Microsoft) to tell you what process has the open handle for the file. Please see here for a further reference of how to use Handle: http://www.orcsweb.com/blog/post/Closing-open-file-handles.aspx You could also write a second script which runs in a loop to monitor the main script. The second script can verify the first script by doing a WMI Process query which returns only processes that match a defined command line. The second script could then restart the main it stops, alert you, log a file, launch a handle search, etc.

Resources