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""")
Related
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
I have a big issue with my code, which i'vre created by using already known/someone solution.
What's going on:
I need a code which will give me an extract of all files, which lastDateModified is older than some specific date. However the best solution will be if i will received those file names in array (don't know how to do that"
Problem:
When I enter a command in the console, it gives me the list of files correctly.
Whereas when I place it in Access it gets me text:
Microsoft Windows [Version 6.1.7601]
Copyright (c) 2009 Microsoft Corporation. All rights reserved.
I:\Documents\Access>
Code:
Public Sub TestCommandLine()
Const lngCancelled_c As Long = 0
Dim strCmd As String
strCmd = "cmd.exe forfiles /P directory /S /D +01/04/2015) > directory2"
CommandLine strCmd, False
End Sub
Public Function CommandLine(command As String, Optional ByVal keepAlive As _
Boolean = False, Optional windowState As VbAppWinStyle =
VbAppWinStyle.vbHide) _
As Boolean
'--------------------------------------------------------------------------------
' Procedure : CommandLine
' Author : Aaron Bush (Oorang)
' Date : 10/02/2007
' Purpose : Provides a simple interface to execute a command lines from VBA.
' Input(s) :
' command : The DOS command you wish to execute.
' keepAlive : Keeps the DOS window open *after* command has been
' executed. Default behavior is to auto-close. (See
' remarks section for additional information.)
' windowState : Determines the window state of the DOS prompt
' *during* command execution.
' Output : True if completed with no errors, False if error encountered.
' Remarks : If the windowState property is set to vbHide while the keepAlive
' parameter is set to True, then windowState will be changed to
' vbNormalFocus.
'--------------------------------------------------------------------------------
On Error GoTo Err_Hnd
Const lngMatch_c As Long = 0
Const strCMD_c As String = "cmd.exe"
Const strComSpec_c As String = "COMSPEC"
Const strTerminate_c As String = " /c "
Const strKeepAlive_c As String = " /k "
Dim strCmdPath As String
Dim strCmdSwtch As String
If keepAlive Then
If windowState = vbHide Then
windowState = vbNormalFocus
End If
strCmdSwtch = strKeepAlive_c
Else
strCmdSwtch = strTerminate_c
End If
strCmdPath = VBA.Environ$(strComSpec_c)
If VBA.StrComp(VBA.Right$(strCmdPath, 7), strCMD_c, vbTextCompare) <> _
lngMatch_c Then
strCmdSwtch = vbNullString
End If
VBA.Shell strCmdPath & strCmdSwtch & command, windowState
CommandLine = True
VBA.Shell Nothing
Exit Function
Err_Hnd:
CommandLine = False
End Function
Do anyone have this issue?
Using this construct
Option Explicit
Public Sub Find_Files()
Dim fileDetails() As String
fileDetails = Split(CreateObject("wscript.shell").exec("cmd /c forfiles /P C:\Users\User\Desktop\TestFolder /S /D -19/04/2018").StdOut.ReadAll, vbCrLf)
Dim i As Long
For i = LBound(fileDetails) To UBound(fileDetails)
If Not IsEmpty(fileDetails(i)) Then Debug.Print fileDetails(i)
Next i
End Sub
Another question abt same problem - how can i check all files in network drive?
i've tried with
cmd /c pushd "network drive path" forfiles /S /D +14/04/2018
and it doesnt work, however when i write it in console in seperate lines
pushd "network_drive"
forfiles /s /d +10/04/2018
popd
then all works.
Any ideas?
SOLVED:
fileDetails = Split(CreateObject("wscript.shell").exec("cmd /c pushd " & Chr(34) & IMPORT_PATH & FOLDER_PATH & Chr(34) & " & forfiles /S /D +" & s_date & " & popd").StdOut.ReadAll, Chr(10))
And it works for net drive
I figure that I could post this as a unique way of returning output as text instead of integers to see if this can help others that are having the same issue as I am having.
What I'm trying to accomplish is holding the output of the command, but then channeling a specific output out as a text instead of being interger based.
Here's what I have so far, and I'm currently stuck on filtering the output. I know that I can use the mid command, but since the output in general from this command is fluid, I can't use mid to count specific characters.
The command in question is PowerShell.exe manage-bde -status C:
The output is this:
Volume C: [OSDisk]
[OS Volume]
Size: 118.24 GB
BitLocker Version: Windows 7
Conversion Status: Fully Encrypted
Percentage Encrypted: 100%
Encryption Method: AES 256
Protection Status: Protection On
Lock Status: Unlocked
Identification Field: None
Key Protectors:
Numerical Password
TPM
I need to pull some information from say for instance Conversion Status. I want it to tell me if it's 100%, or 0%...or whatever it is. I can't seem to pull just that line.
Here's what I have so far.
dim outputArray
dim inputText
dim message
Dim strText
Set objShell = WScript.CreateObject("WScript.Shell")
Set objExecObject = ObjShell.Exec("PowerShell.exe manage-bde"" -status C:")
Do While Not objExecObject.StdOut.AtEndOfStream
strText = objExecObject.StdOut.ReadLine()
inputText = strText
outputArray = split(inputText,"Converstion Status:")
for each x in outputArray
message = message & x & vbCRLF
next
msgbox message
Loop
This does a line by line pull, and I know that Conversion Status is the 3rd line, so maybe something to that effect of channeling that line and echoing the 100% to a variable that I can store as a separate output.
Update: I decided not to go through the approach of parsing the output to a text file. There has to be a better way and shorter code to accomplish this methodology, plus if Bitlocker variables get changed around on the output, my line methodology might not work.
I'm now trying to see if I can use the for /F search approach to find the string and set the variable. The goal for me to do all of this is to add it to a registry key that will contain these values for reporting
Here's my revised code.
dim outputArray
dim inputText
dim message
Dim strText
dim line
dim testCase
dim strConversion
dim Currentline
Set objShell = WScript.CreateObject("WScript.Shell")
Set objExecObject = ObjShell.Exec("PowerShell.exe manage-bde"" -status C:")
Do While Not objExecObject.StdOut.AtEndOfStream
strText = objExecObject.StdOut.ReadLine()
strConversion = "for /F ""delims="" %%a in (strText) do do findstr /M /i /C:'Conversion' C:\%i var=%%a"
Wscript.echo strConversion
Loop
This does a line by line pull, and I know that Conversion Status is the 3rd line, so maybe something to that effect of channeling that line and echoing the 100% to a variable that I can store as a separate output.
Update: I decided not to go through the approach of parsing the output to a text file. There has to be a better way and shorter code to accomplish this methodology, plus if Bitlocker variables get changed around on the output, my line methodology might not work.
I'm now trying to see if I can use the for /F search approach to find the string and set the variable. The goal for me to do all of this is to add it to a registry key that will contain these values for reporting.
Here's my revised code.
dim outputArray
dim inputText
dim message
Dim strText
dim line
dim testCase
dim strConversion
dim Currentline
Set objShell = WScript.CreateObject("WScript.Shell")
Set objExecObject = ObjShell.Exec("PowerShell.exe manage-bde"" -status C:")
Do While Not objExecObject.StdOut.AtEndOfStream
strText = objExecObject.StdOut.ReadLine()
strConversion = "for /F ""delims="" %%a in (strText) do findstr /M /i /C:'Conversion' C:\%i var=%%a"
Wscript.echo strConversion
Loop
So far when running it, it parrots back the line back 14 times which is the number of lines when you run the command straight. So, it is seeing it, just not fully parsing the data. "Conversion" is one the strings that I'm having it check for.
Another reason I don't want to do longer code is this is part of a script that already has quite a few lines, and this will be a final sub process.
Try to store the output into array like this code :
Option Explicit
Dim arrData,Data
If Not WScript.Arguments.Named.Exists("elevate") Then
CreateObject("Shell.Application").ShellExecute WScript.FullName _
,WScript.ScriptFullName & " /elevate", "", "runas", 1
WScript.Quit
End If
arrData = Run_PS_Script
MsgBox arrData(6)
'To get all data from this loop For...Next
For Each Data in arrData
MsgBox Data
Next
'*****************************************************************
Function Run_PS_Script()
Dim WshShell,Command,PSFile,ret,fso,file,text,Temp
Set WshShell = CreateObject("WScript.Shell")
Temp = WshShell.ExpandEnvironmentStrings("%Temp%")
Command = "cmd /c echo manage-bde -status C: ^|" &_
"Out-File %temp%\output.txt -Encoding ascii > %temp%\PSFile.ps1"
PSFile = WshShell.Run(Command,0,True)
ret = WshShell.Run("powershell.exe -ExecutionPolicy Unrestricted -File %temp%\PSFile.ps1",0,True)
Set fso = CreateObject("Scripting.FileSystemObject")
text = ReadFile(Temp &"\output.txt","byline")
Run_PS_Script=text
End Function
'*****************************************************************
Function ReadFile(path,mode)
Const ForReading = 1
Const TriStateUseDefault = -2
Dim objFSO,objFile,i,contents,strLine
Set objFSO = CreateObject("Scripting.FileSystemObject")
If mode = "unicode" Then
Set objFile = objFSO.opentextfile(path,,,true)
contents = objFile.ReadAll
ReadFile = contents
objFile.Close
End If
If mode = "byline" then
Set objFile = objFSO.OpenTextFile(path,ForReading)
Dim arrFileLines()
i = 0
Do Until objFile.AtEndOfStream
Redim Preserve arrFileLines(i)
strLine = objFile.ReadLine
strLine = Trim(strLine)
If Len(strLine) > 0 Then
arrFileLines(i) = strLine
i = i + 1
ReadFile = arrFileLines
End If
Loop
objFile.Close
End If
If mode = "all" Then
Set objFile = objFSO.OpenTextFile(path,ForReading)
contents = objFile.ReadAll
ReadFile = contents
objFile.Close
End If
End Function
'*****************************************************************
Okay, I want to post another variation again. How about this?
dim outputArray
dim inputText
dim message
Dim strText
Dim MyArray
conversion = "Conversion Status:"
Set objShell = WScript.CreateObject("WScript.Shell")
Set objExecObject = ObjShell.Exec("PowerShell.exe manage-bde"" -status C:")
Do While Not objExecObject.StdOut.AtEndOfStream
strText = objExecObject.StdOut.ReadLine()
inputText = strText
outputArray = split(inputText,"Conversion Status:")
for each i in outputArray
output = i
next
position = InStr(1, strText,conversion, 1)
msgbox position
Loop
I've got it now where it will return the 0 or 5 value for the line. How can I convert the 5 response back to actual text that came from that line?
Here is an example of pulling values from an array of strings in VBS:
' let us mock out our expected data returned from the disk
Dim sampleData(100)
sampleData(0) = "Volume C: [OSDisk]"
sampleData(1) = "[OS Volume]"
sampleData(2) = ""
sampleData(3) = " Size: 118.24 GB"
sampleData(4) = " BitLocker Version: Windows 7"
sampleData(5) = " Conversion Status: Fully Encrypted"
sampleData(6) = " Percentage Encrypted: 100%"
sampleData(7) = " Encryption Method: AES 256"
sampleData(8) = " Protection Status: Protection On"
sampleData(9) = " Lock Status: Unlocked"
sampleData(10) = " Identification Field: None"
sampleData(11) = " Key Protectors:"
sampleData(12) = " Numerical Password"
sampleData(13) = " TPM"
'create a function to parse out the values you want
Function returnValueFromData(sampleData,fieldName)
For each infoLine in sampleData
If InStr(infoline,fieldName) Then
infoline = Trim(Replace(infoline,fieldName,""))
returnValueFromData = infoline
End If
Next
End Function
'now, we can use our function above to grab whatever field we want
'get the size of the disk
dim size
size = returnValueFromData(sampleData,"Size:")
wscript.echo size
'get the lock status of the disk
dim lockStatus
lockStatus = returnValueFromData(sampleData,"Lock Status:")
wscript.echo lockStatus
'shorthand to get the encryption algorithm
wscript.echo returnValueFromData(sampleData,"Encryption Method:")
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 problem in a VBScript that I am using with a VBA/Excel macro and a HTA. The problem is just the VBScript, I have the other two components, i.e. the VBA macro and HTA front-end working perfectly. But before I explain the problem, I think for you to help me I must help you understand the context of the VBScript.
So, basically all components (VBScript, VBA macro and HTA) are parts of a tool that I am building to automate some manual chores. It pretty much goes like this:
A - HTA
~~~~~~~~~~~~
User selects some files from the HTA/GUI.
Within the HTML of the HTA there is some VBScript within the "SCRIPT" tags which passes the users 4 input files as arguments to a VBScript (executed by WScript.exe - you may refer to note #1 for clarity here)
The script, lets call it myScript.vbs from now on then handles the 4 arguments, 3 of which are specific files and the 4th is a path/folder location that has multiple files in it - (also see note #2 for clarity)
B - myScript.vbs
~~~~~~~~~~~~
myScript.vbs opens up the first 3 arguments which are Excel files. One of them is a *.xlsm file that has my VBA macro.
myScript.vbs then uses the 4th argument which is a PATH to a folder that contains multiple files and assigns that to a variable for passing to a FileSystemObject object when calling GetFolder, i.e.
... 'Other code here, irrelevant for this post
Dim FSO, FLD, strFolder
... 'Other code here, irrelevant for this post
arg4 = args.Item(3)
strFolder = arg4
Set FSO = CreateObject("Scripting.FileSystemObject"
'Get a reference to the folder you want to search
Set FLD = FSO.GetFolder(strFolder)
...
From here I create a loop so that I can sequentially open the files within the folder
and then run my macro, i.e.
...
Dim strWB4, strMyMacro
strMyMacro = "Sheet1.my_macro_name"
'loop through the folder and get the file names
For Each Fil In FLD.Files
Set x4WB = x1.Workbooks.Open(Fil)
x4WB.Application.Visible = True
x1.Run strMyMacro
x4WB.close
Next
...
Please note that when the first 3 Excel files have opened (controlled by code prior to the loop, and not shown here as I am having no problem with that part) I must keep them open.
It is the files in the folder (that was passed as the 4th argument) which must sequentially open and close. But inbetween opening and closing, I require the VBA/macro (wrote in one of the 3 Excel files previously opened) to run each time the loop iterates and opens a new file from the folder (I hope you follow - if not please let me know :) ).
The problem I am having is that the files in the folder open and close, open and close, n number of times (n = # of files in folder, naturally) without waiting for the macro to run. This is not what I want. I have tried the WScript.sleep statement with a 10 second delay after the 'x1.Run strMyMacro' statement, but to no avail.
Any ideas?
Thanks,
QF.
NOTES:
1 - For simplicity/clarity this is how:
strCMD = cmd /c C:\windows\system32\wscript.exe myScript.vbs <arg1> <arg2> <arg3> <arg4>
'FYI - This is run by creating a WShell object, wsObj, and using the .run method, i.e. WShell.run(strCMD)
2 The HTA employs a piece of JavaScript that strips the users 4th input file (HTML: INPUT TYPE="file") and passes that to the the VBScript within the HTA. This gets me round the problem of not being able to exclusively select a FOLDER in HTML.
You need to tell the run to wait until the process is finished. Something like:
const DontWaitUntilFinished = false, ShowWindow = 1, DontShowWindow = 0, WaitUntilFinished = true
set oShell = WScript.CreateObject("WScript.Shell")
command = "cmd /c C:\windows\system32\wscript.exe <path>\myScript.vbs " & args
oShell.Run command, DontShowWindow, WaitUntilFinished
In the script itself, start Excel like so. While debugging start visible:
File = "c:\test\myfile.xls"
oShell.run """C:\Program Files\Microsoft Office\Office14\EXCEL.EXE"" " & File, 1, true
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2:Win32_Process")
objWMIService.Create "notepad.exe", null, null, intProcessID
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredProcesses = objWMIService.ExecNotificationQuery _
("Select * From __InstanceDeletionEvent Within 1 Where TargetInstance ISA 'Win32_Process'")
Do Until i = 1
Set objLatestProcess = colMonitoredProcesses.NextEvent
If objLatestProcess.TargetInstance.ProcessID = intProcessID Then
i = 1
End If
Loop
Wscript.Echo "Notepad has been terminated."
This may not specifically answer your long 3 part question but this thread is old and I found this while searching today. Here is one shorter way to: "Wait until a process has finished." If you know the name of the process such as "EXCEL.EXE"
strProcess = "EXCEL.EXE"
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colProcesses = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = '"& strProcess &"'")
Do While colProcesses.Count > 0
Set colProcesses = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = '"& strProcess &"'")
Wscript.Sleep(1000) 'Sleep 1 second
'msgbox colProcesses.count 'optional to show the loop works
Loop
Credit to: http://crimsonshift.com/scripting-check-if-process-or-program-is-running-and-start-it/
Probably something like this? (UNTESTED)
Sub Sample()
Dim strWB4, strMyMacro
strMyMacro = "Sheet1.my_macro_name"
'
'~~> Rest of Code
'
'loop through the folder and get the file names
For Each Fil In FLD.Files
Set x4WB = x1.Workbooks.Open(Fil)
x4WB.Application.Visible = True
x1.Run strMyMacro
x4WB.Close
Do Until IsWorkBookOpen(Fil) = False
DoEvents
Loop
Next
'
'~~> Rest of Code
'
End Sub
'~~> Function to check if the file is open
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function