I cannot call the "test1.bat" file from this visual basic script.
The only thing that i get is "Runtime error 70, access denied". Has someone had a similar outcome or experiences.
Sub test()
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
wsh.Run "C:\Users\taischa\Desktop\test1.bat", windowStyle, waitOnReturn
End Sub
I already tried to change the .bat to .cmd file. I also tried to access the bat file through a link as admin.I can execute the Batchfile without any problem if i doubleclick the icon or call ir via cmd. I suspect the firewall to block the makro.
Maybe someone can help me.
Set oShell = CreateObject ("Wscript.Shell")
Dim strArgs
strArgs = "test.bat"
oShell.Run strArgs, 0, false
This makes the file invisible, but execute they. You can also type:
Set oShell = CreateObject ("Wscript.Shell")
Dim strArgs
strArgs = "cmd /c test.bat"
oShell.Run strArgs, 0, false
To end the process when its get off.
If you need to start it with a window:
Set oShell = CreateObject ("Wscript.Shell")
Dim strArgs
strArgs = "cmd /c start test.bat"
oShell.Run strArgs, 0, false
first, they create a object, then, they start a function of cmd, called cmd with the paramter /c, that means: the code will stop and the cmd will close while they stop running. But, first, he will start a window with your bat file. That makes the file visible.
I hope i helped you.
Try in this simpler way, please:
Shell "C:\Users\taischa\Desktop\test1.bat", 1
If it does not work, you should take the ownership of the folder in discussion. I mean, the user account who executes the code.
Is your user account an administrator type?
Edited:
Please, test the next code and send some feedback:
Sub testCreateRunBat()
Dim FSO As Object, lngOK As Long, BT As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set BT = FSO.OpenTextFile(ThisWorkbook.Path & "\Test.bat", 2, True)
BT.Write "C:"
BT.WriteLine
BT.Write "Dir"
BT.Close
lngOK = Shell(ThisWorkbook.Path & "\Test.bat", 1)
If lngOK <> 0 Then MsgBox "Everything OK!"
End Sub
Related
I am using the ScriptControl in Access VBA to load the scripts (.vbs files) and execute them for extracting data from a SAP system. For the small data the code works fine.
However, when there is a big data which takes time or stops responding then Access opens a popup window asking me to switch to the app or retry. If I click on retry button or by hand switch to that window, then the script resumes!
Is there any way to tackle this access popup window or a code to press this retry button? Thanks
Mycode:
Open scriptPath For Input As #1
vbsCode = Input$(LOF(1), 1)
Close #1
On Error GoTo ERR_VBS
With CreateObject("ScriptControl")
.Language = "VBScript"
.AddCode vbsCode '>>>>>>>>>>>>>>>> I get this popup window at this line
End With
Tried :
Sub Test()
Dim oSC As Object
Set oSC = CreateObjectx86("ScriptControl") ' create ActiveX via x86 mshta host
Debug.Print TypeName(oSC) ' ScriptControl
' do some stuff
CreateObjectx86 Empty ' close mshta host window at the end
End Sub
Function CreateObjectx86(sProgID)
Static oWnd As Object
Dim bRunning As Boolean
Dim vbsCode As String, result As Variant, Script As Object
Open "\My Documents\\Desktop\x.vbs" For Input As #1
vbsCode = Input$(LOF(1), 1)
Close #1
Set oWnd = CreateWindow()
oWnd.execScript vbsCode, "VBScript" '>>>>>>>>>Gets an Error says "Error on Script page"
Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
End Function
Function CreateWindow()
' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
Dim sSignature, oShellWnd, oProc
On Error Resume Next
Do Until Len(sSignature) = 32
sSignature = sSignature & Hex(Int(Rnd * 16))
Loop
CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
Do
For Each oShellWnd In CreateObject("Shell.Application").Windows
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
Err.Clear
Next
Loop
End Function
So after lot of headache, I found the solution! The solution is to use waitToReturn. This will make Access VBA wait for the Script to be completed no matter how long it take! Hence, this tackled the problem of Access popup window asking to switch to window or Retry!
Solution code:
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim errorCode As Integer
errorCode = wsh.Run("C:\path\x.vbs", windowStyle, waitOnReturn)
If errorCode = 0 Then
MsgBox "Script successful. "
Else
MsgBox "Script exited with error code " & errorCode & "."
End If
with cases like this you would always try to get the focus via the object you are manipulating, usually it is done by .setFocus or .active.
the below is code that will help you out. I would try the session.setFocus.
Session.ActiveWindow.SetFocus
the below code will also help:
Dim SapGuiAuto As Object
Dim Application As SAPFEWSELib.GuiApplication
Dim Connection As SAPFEWSELib.GuiConnection
Dim Session As SAPFEWSELib.GuiSession
Dim UserArea As SAPFEWSELib.GuiUserArea
' Dim oWindow As SAPFEWSELib.GuiConnection
Dim oUserAreaOfMobileWindow As SAPFEWSELib.GuiUserArea
Dim oGuiSimpleContainer As SAPFEWSELib.GuiSimpleContainer
Set SapGuiAuto = GetObject("SAPGUI")
If Not IsObject(SapGuiAuto) Then
Exit Sub
End If
Set Application = SapGuiAuto.GetScriptingEngine()
If Not IsObject(Application) Then
Exit Sub
End If
Set Connection = Application.Connections(0)
If Not IsObject(Connection) Then
Exit Sub
End If
Set Session = Connection.Sessions(0)
If Not IsObject(Session) Then
Exit Sub
End If
I use the following function in a lot of my VBA projects. I initially added the reference to Windows Script Host Object model to take advantage of Intellisense, but then switched to late binding so I didn't have to reference a bunch of stuff.
Private Function RunCMD(ByVal strCMD As String) As String
'Runs the provided command
Dim oShell As Object 'New WshShell
Dim cmd As Object 'WshExec
Dim x As Integer
Const WshRunning = 0
On Error GoTo wshError
x = 0
RunCMD = "Error"
Set oShell = CreateObject("Wscript.Shell")
Set cmd = oShell.Exec(strCMD)
'Debug.Print strCMD
'Stop
Do While cmd.Status = WshRunning
Sleep 100 'for 1/10th of a second
x = x + 1
If x > 1200 Then 'We've waited 2 minutes so kill it
cmd.Terminate
MsgBox "Error: Timed Out", vbCritical, "Timed Out"
End If
Loop
RunCMD = cmd.StdOut.ReadAll & cmd.StdErr.ReadAll
Set oShell = Nothing
Set cmd = Nothing
Exit Function
wshError:
On Error Resume Next
RunCMD = cmd.StdErr.ReadAll
Resume Next
End Function
It works great when you do something like
RunCMD("ping www.bing.com") or
RunCMD("winrs -r:" & strHost & " reg query hklm\system\currentcontrolset\services\cdrom /v start")
However RunCMD("Dir c:\config* /a:-d /b /d /s") fails, and cmd.StdErr.ReadAll gives an Object Variable or With Block not set error. Even a simple RunCMD("Dir") fails.
Why does DIR make the WScript shell crap out? More importantly, how can I use CMD's DIR function (not VBA's DIR function!) to get a list of files that match a search pattern?
Does it work if you preface your dir command with "cmd /c " and wrap your DOS command in double quotes, like
RunCmd("cmd /c ""DIR""")
or
RunCmd("cmd /c ""Dir c:\config* /a:-d /b /d /s""")
I have a macro in excel vba that runs a shell to execute a simple pdf editor by command line, exports a list of the page names and numbers, searches for a keyword to find the page we want, gets the page num, and then extracts that page from the pdf file.
I've realised this macro would serve better as a standalone entity, and was wondering what is required to take the code out of excel, and run it from a .vbs file.
I tried direct copy and paste and it didnt like the letter "A" in the word "As" in the first line.
Sub PDF_GetUFPlan()
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim errorCode As Integer
wsh.Run "C:\Users\johnmcs\Desktop\pdftk.exe C:\Users\johnmcs\Desktop\FULL.PDF burst output C:\Users\johnmcs\Desktop\output.txt", windowStyle, waitOnReturn
Dim hf As Integer: hf = FreeFile
Dim lines() As String, i As Long
Open "C:\Users\johnmcs\Desktop\doc_data.txt" For Input As #hf
lines = Split(Input$(LOF(hf), #hf), vbNewLine)
Close #hf
For i = 0 To UBound(lines)
If InStrRev(lines(i), "UPPER FLOOR PLAN") > 0 Then
For x = i To UBound(lines)
If InStrRev(lines(x), "BookmarkPageNumber: ") > 0 Then
Dim UFpagenum As Integer, PagenumPosi As Integer
PagenumPosi = InStrRev(lines(x), " ")
PagenumPosi = Len(lines(x)) - PagenumPosi
UFpagenum = Right(lines(x), PagenumPosi)
GoTo extractpage
End If
Next
End If
Debug.Print "Line"; i; "="; lines(i)
Next
extractpage:
wsh.Run "C:\Users\johnmcs\Desktop\pdftk.exe C:\Users\johnmcs\Desktop\FULL.PDF cat " & UFpagenum & " output C:\Users\johnmcs\Desktop\page" & UFpagenum & ".pdf", windowStyle, waitOnReturn
End Sub
Sub PDF_GetUFPlan()
Dim wsh
Set wsh = CreateObject("WScript.Shell") ' NB we also have wscript.createobject
Dim waitOnReturn
waitOnReturn = True
Dim windowStyle
windowStyle = 1
Dim errorCode
So here, the beginning is fixed. You cannot Dim as anything. Everything is a variant. Everything MUST be late bound so all sets must be done with CreateObject - no set x = new thing but set x = CreateObject("thing.application").
Remember VB6/VBA supports vbs feature set. vbs is compatable (a design goal) with vb6/vba.
VBscript does not support
Dim variable_name As variable_type
variable declaration....all variables are of type variant.
Just type:
Dim variable_name
Not technically a necessity, but (sigh... I can't believe I'm saying this) you should consider hungarian notation for VBScript. As the other answerers pointed out, VBScript is not a strongly typed language. You should rename your variables so it is clear what type they are to any future maintainer.
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim boolWaitOnReturn : waitOnReturn = True
Dim intWindowStyle : windowStyle = 1
Dim intErrorCode
I am trying to ping a server before uploading a file with ftp. Recently, a client complained that the process was freezing. I tested the ping process with a vbscript file just to make sure something wasn't broken on the computer. The vbscript worked just fine. So I ran the script from the Access database and it hung just the same as it did before. Is there something about the ping exe that I am missing here?
Vbscript that runs just fine when you double click it.
Const fsoForWriting = 2
Dim oShell, ping, strPath, strPing
Set oShell = WScript.CreateObject ("WScript.Shell")
Set ping = oShell.exec("ping -n 2 -w 750 google.com")
Do While ping.Status = 0
WScript.Sleep 100
Loop
strPing = ping.StdOut.ReadAll
strPath = Wscript.ScriptFullName
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTextFile = objFSO.GetParentFolderName(strPath) & "\PingResults.txt"
Set objTextStream = objFSO.OpenTextFile(strTextFile, fsoForWriting, True)
objTextStream.WriteLine strPing
objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
Set oShell = Nothing
VBA function that runs on the test database on startup. This is the code that hangs.
Function fFtpOnline(ByVal ComputerName As String)
On Error GoTo ErrHandler
Dim oShell, ping
Set oShell = CreateObject("WScript.Shell")
Set ping = oShell.exec("cscript " & Access.CurrentProject.Path & "\" & "Test.vbs")
Do While ping.Status = 0
DoEvents
Loop
Set oShell = Nothing
Exit Function
ErrHandler:
MsgBox Err.Description & " " & "fFtpOnline "
Resume Next
End Function
This code works fine on my computer but on the client's computer, the code hangs.
This may sound like a rude answer, but by no means is it intended to be. Just as the comment above stated, this is more than likely it issue on your customer's end. If the program works currently on your end and not theirs they have the issue, not the code. I've run into plenty of customers who are clueless so unless they are willing to let you take control of their machine remotely I would recommend them capturing some information for you. ipconfig is a good place to start. And while they are at the command prompt have them try to ping some places. I know this is not a true answer, but it is what I have encountered in the past.
I have a vbs script which captures file information and then exports it to a csv file. I need to run the script on main drives such as C:\, E:\, I:\ and more, but each time I run for the main directory I get "Permission Denied" when I try to run it for a subfolder example C:\Program Files it works fine. I have tested this on different desktop machines and servers with full admin accounts and still get it.
What could be the issue with this code. test.vbs
Option Explicit
Dim objFS, objFld
Dim objArgs
Dim strFolder, strDestFile, blnRecursiveSearch
Dim strLines()
Dim i
Dim strCsv
i = 0
' 'Get the commandline parameters
' Set objArgs = WScript.Arguments
' strFolder = objArgs(0)
' strDestFile = objArgs(1)
' blnRecursiveSearch = objArgs(2)
'###################################
'MAKE SURE THESE VALUES ARE CORRECT
'###################################
strFolder = "C:\"
strDestFile = "C:\Output.csv"
blnRecursiveSearch = True
'Create the FileSystemObject
Set objFS=CreateObject("Scripting.FileSystemObject")
'Get the directory you are working in
Set objFld = objFS.GetFolder(strFolder)
'Now get the file details
GetFileDetails objFld, blnRecursiveSearch
'Write the csv file
Set strCsv = objFS.CreateTextFile(strDestFile, True)
strCsv.Write Join(strLines, vbCrLf)
'Close and cleanup objects
strCsv.Close
Set strCsv = Nothing
Set objFld = Nothing
Set strFolder = Nothing
Set objArgs = Nothing
Private Sub GetFileDetails(fold, blnRecursive)
Dim fld, fil
dim strLine(5)
If blnRecursive Then
'Work through all the folders and subfolders
For Each fld In fold.SubFolders
GetFileDetails fld, True
Next
End If
'Now work on the files
For Each fil in fold.Files
strLine(0) = fil.Path
strLine(1) = fil.Type
strLine(2) = fil.Size
strLine(3) = fil.DateCreated
strLine(4) = fil.DateLastModified
strLine(5) = fil.DateLastAccessed
Redim Preserve strLines(i)
strLines(i) = Join(strLine, ",")
i = i + 1
Next
end sub
Please advise and modify code if you know where the issue is.
If it's a permissions problem I would strongly recommend Process Monitor from Sysinternals to diagnose it. You should be able to watch the cscript process (or whatever is executing your script) and find out what kind of permission problem you're having.