To run two or more .VBS script parallely - vbscript

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.

Related

How Can I pause speak command in vbscript? I have to play it from the same paused position

How Can I pause speak command in vbscript? I have to play it from the same paused position.
Code block:
Dim Speak, Path
Path = "string"
Path = "C:\Users\sony\Desktop\TheReunion.txt"
const ForReading = 1
Set objFileToRead = CreateObject("Scripting.FileSystemObject").OpenTextFile(Path,ForReading)
strFileText = objFileToRead.ReadAll()
Set Speak=CreateObject("sapi.spvoice")
Speak.Speak strFileText
objFileToRead.Close
Set objFileToRead = Nothing
You need to call the speak method asynchronously before using the pause and resume methods as mentioned by LotPings in the comments.
Code:
Dim Speak, Path
Path = "string"
Path = "C:\Users\sony\Desktop\TheReunion.txt"
const ForReading = 1
Set objFileToRead = CreateObject("Scripting.FileSystemObject").OpenTextFile(Path,ForReading)
strFileText = objFileToRead.ReadAll()
Set Speak=CreateObject("sapi.spvoice")
Speak.Speak strFileText,1 '1=Asynchronous. Click the link below for other possible values "SpeechVoiceSpeakFlags"
'Due to async call to speak method, we can proceed with the code execution while the voice is being played in the background. Now we can call pause and resume methods
wscript.sleep 5000 'voice played for 5000ms
Speak.pause 'paused
wscript.sleep 4000 'remains paused for 4000ms
Speak.resume 'resumes
objFileToRead.Close
Set objFileToRead = Nothing
SpeechVoiceSpeakFlags
Intrigue in this led me to take inspiration from Kira's answer and develop it somewhat (in a bad, novice kind of way), to achieve the pause/resume objective interactively, the code below works for me, and hopefully it's of some help to you...
option explicit
dim strpath, fso, strfile, strtxt, user, voice, flag
flag = 2
call init
sub init
do while len(strpath) = 0
strpath = inputbox ("Please enter the full path of txt file", "Txt to Speech")
if isempty(strpath) then
wscript.quit()
end if
loop
'strpath = "C:\Users\???\Desktop\???.txt"
set fso = createobject("scripting.filesystemobject")
on error resume next
set strfile = fso.opentextfile(strpath,1)
if err.number = 0 then
strtxt = strfile.readall()
strfile.close
call ctrl
else
wscript.echo "Error: " & err.number & vbcrlf & "Source: " & err.source & vbcrlf &_
"Description: " & err.description
err.clear
call init
end if
end sub
sub ctrl
user = msgbox("Press ""OK"" to Play / Pause", vbokcancel + vbexclamation, "Txt to Speech")
select case user
case vbok
if flag = 0 then
voice.pause
flag = 1
call ctrl
elseif flag = 1 then
voice.resume
flag = 0
call ctrl
else
call spk
end if
case vbcancel
wscript.quit
end select
end sub
sub spk
'wscript.echo strtxt
set voice = createobject("sapi.spvoice")
voice.speak strtxt,1
flag = 0
call ctrl
end sub

Distinguish between "file doesn't exist" and "access denied"

In a VBScript, I want to know if a file exists:
Set fso = CreateObject("Scripting.FileSystemObject")
If Not (fso.FileExists(file)) Then
msg = " doesn't exist."
End If
My files are on internal network.
Is there a way to distinguish:
file really doesn't exist
access denied
I try with fso.OpenTextFile but the result for these two cases is always: Err.Number = 5.
To distinguish between non-existing and non-accessible files you need .FileExists and .OpenTextFile:
Option Explicit
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
Function ReadFile(p, ByRef m)
If goFS.FileExists(p) Then
Dim aErr
On Error Resume Next
Set ReadFile = goFS.OpenTextFile(p)
aErr = Array(Err.Number, Err.Description)
On Error GoTo 0
If aErr(0) Then
m = p & " - " & aErr(1)
Set ReadFile = Nothing
Else
m = ""
End If
Else
Set ReadFile = Nothing
m = p & " - no such file"
End If
End Function
Dim p, m
For Each p In Split("e:\roots.own e:\nosuchfile e:\dirsbf.tmp")
Dim tsIn : Set tsIn = ReadFile(p, m)
If tsIn Is Nothing Then
WScript.Echo "fail", m
Else
' read from tsIn
tsIn.Close
WScript.Echo "ok"
End If
Next
Output:
cscript 35338634.vbs
fail e:\roots.own - Permission denied
fail e:\nosuchfile - no such file
ok
Thanks to Ansgar's observation, the function can be improved:
Function ReadFile(p, ByRef m)
Dim aErr
On Error Resume Next
Set ReadFile = goFS.OpenTextFile(p)
aErr = Array(Err.Number, Err.Description)
On Error GoTo 0
If aErr(0) Then
m = p & " - " & aErr(1)
Set ReadFile = Nothing
Else
m = ""
End If
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.

Not able to run vbscript on windows 7 and above version

I am not able to run a vbscript on windows 7 and above version. This script basically is used to copy data from one excel workbook to another. Please help me.
Thanks.
option explicit
on error resume next
dim objexcel,objfso,objfolder,objsubfolder,objfile,objrange
dim objworkbook,objworkbook2,objworksheet
dim strpath,pathname,endroww,introw,k,i
dim intnewrow,startrow,endrow
dim objrange1,objrange2
'constants asigned to sort
Const xlAscending = 1
Const xlYes = 1
Set objExcel = CreateObject("Excel.Application")
intnewrow=1
strPath = "C:\Documents and Settings\SupriyaS\Desktop\feb 141"
pathName="xls"
If strPath = "" then Wscript.quit
If pathName = "" then Wscript.quit
'Creating an Excel Workbook in My Documents(destination)
Set objWorkbook2= objExcel.Workbooks.Add()
'to supress the flashing oh the screens
objExcel.Visible = False
'to supress the dialog box
objExcel.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)
Set objsubFolder = objfolder.subFolders
set objfile = objsubfolder.files
'loop through all the subfolders
For Each objsubfolder in objfolder.subfolders
'loopt hrough all the excel files in subfolder
For Each objFile In objsubFolder.Files
'to check for excel files using extention
If objFso.GetExtensionName (objFile.Path) = "xls" Then
'open the workbook to be copied from(source)
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
'activate the worksheet
Set objWorksheet = objWorkbook.WorkSheets(1)
objworksheet.Activate
'copy from the 2nd row
If intNewRow = 1 Then
startrow = 1
Else
startrow = 2
End If
'count the number of used row
endrow = objWorkbook.Worksheets("SHEET1").UsedRange.Rows.Count
'copy the data
objWorkbook.Worksheets("SHEET1").Range(startrow & ":" & endrow).Copy
'close the workbook after copying
objWorkbook.close
'paste it on workbook2
objWorkbook2.Worksheets("Sheet1").Cells(intNewRow,1).PasteSpecial
'increment the row
intNewRow = intNewRow + (endrow - startrow + 1)
End If
Next
Next
'counting row of workbook2
endroww = objWorkbook2.Worksheets("SHEET1").UsedRange.Rows.Count
'Deleting empty rows w.r.t column A (Sl.no)
while endroww >= 2
if objworkbook2.worksheets("sheet1").cells(endroww,1).value = "" then
Set objRange = objworkbook2.worksheets("sheet1").Cells(endroww,1).EntireRow
objrange.delete
end if
endroww = endroww -1
Wend
'Sorting the data w.r.t date in ascending order
Set objWorksheet2 = objWorkbook2.Worksheets(1)
Set objRange1 = objWorksheet2.UsedRange
Header = xlYes
Set objRange2 = objExcel.Range("d2")
objRange2.Sort objRange2,xlAscending,,,,,,xlYes
'counting rows of workbook2 after deleting
k = objWorkbook2.Worksheets("SHEET1").UsedRange.Rows.Count
'Editing Serial number
introw = 2
for i = 1 to k
objworkbook2.worksheets("sheet1").cells(introw,1).value = i
introw = introw + 1
next
'save and close workbook2
objworkbook2.save
objworkbook2.close
This is the script and it will loop through all the subfolder and copy's the data from the excel workbooks in the sub folder to a single workbook. when i run the code it runs but i am not getting the excepted output i,e., its not copying the data at all and i am not getting any error while running the code.
You need to comment out that line.
on error resume next
by
'on error resume next
Then you'll get an error number, line number, and column nnumber of the error.
on error resume next
turns off error checking.
If you turn off error checking then you need to do it yourself. So after any line that may generate an error
If err.number <> 0 then
Fix_the_error
err.clear
End If

How we can rename a list of built-in administrator accounts to "administrator"? (using vbs)

I'm trying to change all the built-in windows local administrators names in my domain.
The new name will be "administrator", but it seems that my script is unable to read the excel data(server|old account name).
DIM strPassword, strAdminUserName, strNewAdminUserName
Dim strExcelPath, objExcel, objSheet, intRow
'''''
'Spreadsheet file.
strExcelPath = "c:\List.xls"
' Bind to Excel object.
On Error Resume Next
Set objExcel = CreateObject("Excel.Application")
If (Err.Number <> 0) Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
On Error GoTo 0
' Open spreadsheet.
On Error Resume Next
objExcel.Workbooks.Open strExcelPath
If (Err.Number <> 0) Then
On Error GoTo 0
Wscript.Echo "Spreadsheet cannot be opened: " & strExcelPath
Wscript.Quit
End If
On Error GoTo 0
' Bind to worksheet.
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
intRow = 2
Do While objSheet.Cells(intRow, 1).Value <> ""
comp = objSheet.Cells(intRow, 1).Value
strAdminUserName = objSheet.Cells(intRow, 2).Value
strNewAdminUserName = "Administrator"
On Error Resume Next
' Rename a local user account on a given computer
SET objComputer = GetObject("WinNT://" & Comp)
SET objUser = GetObject("WinNT://" & Comp & "/" & strAdminUserName & ",user")
IF err.number = 0 THEN
objComputer.MoveHere objUser.ADsPath,strNewAdminUserName
END IF
ON ERROR GOTO 0
loop
' Close the workbook.
objExcel.ActiveWorkbook.Close
' Quit Excel.
objExcel.Application.Quit
Wscript.Echo "Done"
Any opinion/comment will be appreciated.

Resources