VBS Object required error, 800A01A8 - vbscript

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.

Related

Error Handling in VBScript to check for number of files in a folder

I have written a script to check that 4 files exist in a folder. I need to use the below error handling for this particular small piece of code.
This code checks various folders to see if it contains 4 files. If it does then good if it doesn't then its not good.
Code:
Const intOK = 0
Const intCritical = 2
Const intError = 3
Const ForReading=1,ForWriting=2,ForAppending=8
Dim filename,filenamemov,emailaddr
Dim arrFolders(17)
Dim argcountcommand,dteToday
Dim arg(4)
Dim strMailServer,Verbose,strExt,numfiles,intIndex
Dim intcount : intCount = 0
Dim stroutput
numfiles = 4 'how many minutes old are the files
Verbose = 0 '1 FOR DEBUG MODE, 0 FOR SILENT MODE
arrFolders(0) = "D:\AS2\Inbound\WESSEX"
arrFolders(1) = "D:\AS2\Inbound\EATWELL"
arrFolders(2) = "D:\AS2\Inbound\TURNER\"
For intIndex = 0 To UBound(arrFolders)
pt "Checking folder: " & arrFolders(intIndex)
If arrFolders(intIndex) = "" Then
pt "Empty folder value!"
Exit For
Else
Call checkfiles(arrFolders(intIndex))
End If
Next
If objFolder.Files.Count < 4 Then
WScript.Echo "CRITICAL - " & intCount & " File(s) over " & numfiles & "
minutes in " & stroutput
WScript.Quit(intCritical)
Else
WScript.Echo "OK - No directory contains less than 4 files"
WScript.Quit(intOK)
End If
Sub checkfiles(folderspec)
'check If any files exist on folder
On Error Resume Next
Dim objFso : Set objFso = CreateObject("Scripting.FileSystemObject")
'you can take this as input too using InputBox
'this will error If less than 4 files exist.
Dim objFolder : Set objFolder = objFso.GetFolder(strFolderPath)
If objfolder.Files.Count = 4 Then
MsgBox "This is Correct"
Else
MsgBox "This isnt Correct"
End If
Sub pt(txt)
If Verbose = 1 Then
WScript.Echo txt
End If
End Sub
If i understand your question, you want to
check a set of folders kept in an array for the number of files they contain
if any of the folders has less than 4 files, an error message should be displayed
the folder array CAN contain empty values and the routine should skip those
Apparently you have more plans considering all 'extra' variables you have in your code like Const ForReading=1,ForWriting=2,ForAppending=8 and Dim filename,filenamemov,emailaddr, but I left them out here, because they have nothing to do with the question at hand.
Option Explicit
Const intOK = 0
Const intCritical = 2
Const intError = 3
Dim Verbose, path, fileCount, minCount, intCount, errCount
Dim objFso, objFolder, intResult, strResult
Verbose = 0 '1 FOR DEBUG MODE, 0 FOR SILENT MODE
minCount = 4 'The minimal number of files each folder should have
Dim arrFolders(17)
arrFolders(0) = "D:\AS2\Inbound\WESSEX"
arrFolders(1) = "D:\AS2\Inbound\EATWELL"
arrFolders(2) = "D:\AS2\Inbound\TURNER\"
Set objFso = CreateObject("Scripting.FileSystemObject")
intResult = intOK 'assume all is well
strResult = "" 'to accumulate critical errors for each folder
intCount = 0 'the total running count of folders we have checked
errCount = 0 'the total count of errors (folders with less than 4 files) we have found
For Each path In arrFolders
If Len(path) > 0 Then
intCount = intCount + 1
WScript.Echo "Checking folder: " & path
Set objFolder = objFso.GetFolder(path)
fileCount = objfolder.Files.Count
'considering the "OK - No directory contains less than 4 files" message
'in your original post, this test needs to do a 'Greater Than Or Equal To', so use >=
If fileCount >= minCount Then
WScript.Echo "This is correct: " & path
Else
WScript.Echo "This is NOT correct: " & path
strResult = strResult & vbNewLine & "CRITICAL - " & fileCount & " File(s) in folder " & path
intResult = intCritical
errCount = errCount + 1
End If
End if
Next
'clean up used objects
Set objFolder = Nothing
Set objFso = Nothing
If errCount > 0 Then
'we have folders with errors
WScript.Echo strResult
Else
'This message implies that a folder is also 'Good' when more than 4 files exist
WScript.Echo "OK - All " & intCount & " directories contain at least " & minCount & " files"
End If
WScript.Quit(intResult)

How Can I Determine the Size of the 'My Documents' Folder for every user on a local machine using VBScript?

I am at my wits end into this. Either I am doing it the wrong way or it is not possible.
I need a vb script for the following scenario:
The script is to run on multiple Windows 7 machines (32-Bit & 64-Bit alike).
These are shared workstation i.e. different users login to these machines from time to time.
The objective of this script is to traverse through each User Profile folder and get the size of the 'My Documents' folder within each User Profile folder. This information is to be written to a .CSV file located at C:\Temp directory on the machine.
This script would be pushed to all workstations from SCCM. It would be configured to execute with System Rights
I tried the script detailed at:
http://blogs.technet.com/b/heyscriptingguy/archive/2005/03/31/how-can-i-determine-the-size-of-the-my-documents-folder.aspx
Const MY_DOCUMENTS = &H5&
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(MY_DOCUMENTS)
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Set objFolder = objFSO.GetFolder(strPath)
Wscript.Echo objFolder.Size
The Wscript.Echo objFolder.Size command in the script returned the value as '0' (zero) for the current logged on user. Although the actual size was like 30 MB or so.
I then tried the script at:
http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_27869829.html
This script returns the correct value but only for the current logged-on user.
Const blnShowErrors = False
' Set up filesystem object for usage
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
' Display desired folder sizes
Wscript.Echo "MyDocuments : " & FormatSize(FindFiles(objFSO.GetFolder(objShell.SpecialFolders("MyDocuments"))))
' Recursively tally the size of all files under a folder
' Protect against folders or files that are not accessible
Function FindFiles(objFolder)
On Error Resume Next
' List files
For Each objFile In objFolder.Files
On Error Resume Next
If Err.Number <> 0 Then ShowError "FindFiles:01", objFolder.Path
On Error Resume Next
FindFiles = FindFiles + objFile.Size
If Err.Number <> 0 Then ShowError "FindFiles:02", objFile.Path
Next
If Err.Number = 0 Then
' Recursively drill down into subfolder
For Each objSubFolder In objFolder.SubFolders
On Error Resume Next
If Err.Number <> 0 Then ShowError "FindFiles:04", objFolder.Path
FindFiles = FindFiles + FindFiles(objSubFolder)
If Err.Number <> 0 Then ShowError "FindFiles:05", objSubFolder.Path
Next
Else
ShowError "FindFiles:03", objFolder.Path
End If
End Function
' Function to format a number into typical size scales
Function FormatSize(iSize)
aLabel = Array("bytes", "KB", "MB", "GB", "TB")
For i = 0 to 4
If iSize > 1024 Then iSize = iSize / 1024 Else Exit For End If
Next
FormatSize = Round(iSize, 2) & " " & aLabel(i)
End Function
Sub ShowError(strLocation, strMessage)
If blnShowErrors Then
WScript.StdErr.WriteLine "==> ERROR at [" & strLocation & "]"
WScript.StdErr.WriteLine " Number:[" & Err.Number & "], Source:[" & Err.Source & "], Desc:[" & Err.Description & "]"
WScript.StdErr.WriteLine " " & strMessage
Err.Clear
End If
End Sub
The only part pending, is to achieve this for the 'My Documents' folder within each of the other User Profile folders.
Is this possible?
Please help.

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

To run two or more .VBS script parallely

I have two .vbs file say a.vbs and b.vbs.Now both are written for the same Excel,but would work on 2 different sheets.So can we run those in parallel?
EDIT
a.vbs will update sheet2 and b.vbs will update sheet3.But for both source sheet is sheet1.
Please advice how to set such environment
CODE A
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1,objSheet2
Dim IntRow1,IntRow2
Dim ColStart
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
strPathExcel1 = "D:\AravoVB\Copy of Original Scripts\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
Set objSheet2 = objExcel1.ActiveWorkbook.Worksheets("Bad Data")
objExcel1.ScreenUpdating = False
objExcel1.Calculation = -4135 'xlCalculationManual
IntRow2=2
IntRow1=4
Do Until IntRow1 > objSheet1.UsedRange.Rows.Count
ColStart = objExcel1.Application.WorksheetFunction.Match("Parent Business Process ID", objSheet1.Rows(3), 0) + 1
Do Until ColStart > objSheet1.UsedRange.Columns.Count And objSheet1.Cells(IntRow1,ColStart) = ""
If objSheet1.Cells(IntRow1,ColStart + 1) > objSheet1.Cells(IntRow1,ColStart + 5) And objSheet1.Cells(IntRow1,ColStart + 5) <> "" Then
objSheet1.Range(objSheet1.Cells(IntRow1,1),objSheet1.Cells(IntRow1,objSheet1.UsedRange.Columns.Count)).Copy
objSheet2.Range(objSheet2.Cells(IntRow2,1),objSheet2.Cells(IntRow2,objSheet1.UsedRange.Columns.Count)).PasteSpecial
IntRow2=IntRow2+1
Exit Do
End If
ColStart=ColStart+4
Loop
IntRow1=IntRow1+1
Loop
objExcel1.ScreenUpdating = True
objExcel1.Calculation = -4105 'xlCalculationAutomatic
CODE B
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1,objSheet2
Dim IntRow1,IntRow2
Dim Flag
Dim IntColTemp,IntRowTemp
Dim Strcmp1,Strcmp2
Flag=0
IntColTemp=1
IntRowTemp=3
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
strPathExcel1 = "D:\VA\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
Set objSheet2 = objExcel1.ActiveWorkbook.Worksheets(2)
IntRow1=4
IntRow2=1
Do While objSheet1.Cells(IntRow1, 1).Value <> ""
objSheet2.Cells(IntRow2, 1).Value = objSheet1.Cells(IntRow1, 1).Value
IntColTemp=1
Flag=0
'This will travarse to the Parent Business Process ID column horizantally in the excel.
Do While Flag=0
If objSheet1.Cells(IntRowTemp,IntColTemp).Value="Parent Business Process ID" Then
Flag=1
End If
IntColTemp=IntColTemp+1
Loop
IntColTemp=IntColTemp-1
'MsgBox(IntColTemp)
Strcmp1=trim(objSheet1.Cells(IntRow1, 1).Value)
Strcmp2=trim(objSheet1.Cells(IntRow1,IntColTemp).Value)
If Strcmp1=Strcmp2 Then
objSheet2.Cells(IntRow2, 2).Value="Parent"
Else
objSheet2.Cells(IntRow2, 2).Value="child"
End If
IntRow1=IntRow1+1
IntRow2=IntRow2+1
Loop
Working on two different sheets should be possible by putting something like this in both of your scripts:
strPathExcel1 = "D:\CopyofGEWingtoWing_latest_dump_21112012.xls"
On Error Resume Next
Set objExcel1 = GetObject(, "Excel.Application") ' attach to running instance
If Err.Number = 429 Then ' if that fails
Err.Clear
Set objExcel1 = CreateObject("Excel.Application") ' create new instance
If Err Then ' if that still fails
WScript.Echo Err.Description & " (0x" & Hex(Err.Number) & ")"
WScript.Quit 1 ' report error and terminate
End If
objExcel1.Workbooks.Open strPathExcel1
End If
On Error Goto 0
However, I doubt that this approach would gain you enough performance to justify the additional complexity.
In CODE A replace the lines
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
strPathExcel1 = "D:\AravoVB\Copy of Original Scripts\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
with the above code block.
In CODE B replace the lines
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
strPathExcel1 = "D:\VA\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
with the above code block.

How can I determine if a file is locked using VBS?

I am writing a VB Script to update some files on the network. Before beginning, I want to know if any of the files are locked. I'd like to do this before I actually do any updates.
I am aware that I can handle the error if the file is locked when I try to replace it, but I really want to know if any files are locked before I start updating any files.
Is there any way to see that a file is locked using VBS (apart from trying to replace it)?
This function determines whether a file of interest can be accessed in 'write' mode. This is not exactly the same as determining whether a file is locked by a process. Still, you may find that it works for your situation. (At least until something better comes along.)
This function will indicate that 'write' access is not possible when a file is locked by another process. However, it cannot distinguish that condition from other conditions that prevent 'write' access. For instance, 'write' access is also not possible if a file has its read-only bit set or possesses restrictive NTFS permissions. All of these conditions will result in 'permission denied' when a 'write' access attempt is made.
Also note that if a file is locked by another process, the answer returned by this function is reliable only at the moment the function is executed. So, concurrency problems are possible.
An exception is thrown if any of these conditions are found: 'file not found', 'path not found', or 'illegal file name' ('bad file name or number').
Function IsWriteAccessible(sFilePath)
' Strategy: Attempt to open the specified file in 'append' mode.
' Does not appear to change the 'modified' date on the file.
' Works with binary files as well as text files.
' Only 'ForAppending' is needed here. Define these constants
' outside of this function if you need them elsewhere in
' your source file.
Const ForReading = 1, ForWriting = 2, ForAppending = 8
IsWriteAccessible = False
Dim oFso : Set oFso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Dim nErr : nErr = 0
Dim sDesc : sDesc = ""
Dim oFile : Set oFile = oFso.OpenTextFile(sFilePath, ForAppending)
If Err.Number = 0 Then
oFile.Close
If Err Then
nErr = Err.Number
sDesc = Err.Description
Else
IsWriteAccessible = True
End if
Else
Select Case Err.Number
Case 70
' Permission denied because:
' - file is open by another process
' - read-only bit is set on file, *or*
' - NTFS Access Control List settings (ACLs) on file
' prevents access
Case Else
' 52 - Bad file name or number
' 53 - File not found
' 76 - Path not found
nErr = Err.Number
sDesc = Err.Description
End Select
End If
' The following two statements are superfluous. The VB6 garbage
' collector will free 'oFile' and 'oFso' when this function completes
' and they go out of scope. See Eric Lippert's article for more:
' http://blogs.msdn.com/b/ericlippert/archive/2004/04/28/when-are-you-required-to-set-objects-to-nothing.aspx
'Set oFile = Nothing
'Set oFso = Nothing
On Error GoTo 0
If nErr Then
Err.Raise nErr, , sDesc
End If
End Function
The script below tries to write to a file for 30 seconds and gives up after that. I needed this when all our users had to click on a script. Chances are that multiple users try to write at the same time. OpenCSV() tries to open the file 30 times with a delay of 1 second in between.
Const ForAppending = 8
currentDate = Year(Now) & "-" & Month(Now) & "-" & Day(Now) & " " & Hour(Now) & ":" & Minute(Now) & ":" & Second(Now)
filepath = "\\network\path\file.csv"
Set oCSV = OpenCSV( filepath )
oCSV.WriteLine( currentDate )
oCSV.Close
Function OpenCSV( path )
Set oFS = CreateObject( "Scripting.FileSystemObject" )
For i = 0 To 30
On Error Resume Next
Set oFile = oFS.OpenTextFile( path, ForAppending, True )
If Not Err.Number = 70 Then
Set OpenCSV = oFile
Exit For
End If
On Error Goto 0
Wscript.Sleep 1000
Next
Set oFS = Nothing
Set oFile = Nothing
If Err.Number = 70 Then
MsgBox "File " & filepath & " is locked and timeout was exceeded.", vbCritical
WScript.Quit
End If
End Function
Or, more simply:
Assuming you already have a variable in your VBS named FileName, which contains the full filepath you want to test:
Dim oFso, oFile
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oFile = oFso.OpenTextFile(FileName, 8, True)
If Err.Number = 0 Then oFile.Close
Line 3 tries to open the file you want to test with append permissions enabled. e.g. it attempts to open the file with a write lock.
If opening the file with a write lock generates an error, then your VBS will error on the third line and not continue. At that point your error handling from wherever you called the VBS should kick in. The error message will be "Permission Denied" if you couldn't get a write lock.
If opening the file with a lock doesn't result in an error, then line 4 closes it again. You can now open the file or do whatever you want with it, confident that it doesn't have a write lock on it.

Resources