Arena Simulation Start and Close in VBA - vba

currently I am using Arena Simulation for an acadamic project. I want to start the a model of the acadamic Arena version via VBA, run the model and close it automatically.
Until now the Arena model opens but is not running. The click on the run button (to start the model simulation) in Arena is missing. How can I "click" the run button in VBA?
My current code section:
Private Function ExecuteArena(ByVal arenaFile As String, ByVal arenaPath As String)
On Error GoTo ErrorHandler
''' Clear the error mesaage variable.
gszErrMsg = vbNullString
''' Shell out
If Not bShellAndWait(arenaPath & " " & arenaFile & " ", 6) Then Err.Raise 9999
Exit Function
ErrorHandler:
''' If we ran into any errors this will explain what they are.
MsgBox gszErrMsg, vbCritical, "Shell and Wait Error"
End Function
Private Function bShellAndWait(ByVal szCommandLine As String, Optional ByVal iWindowState As Integer = vbHide) As Boolean
Dim lTaskID As Long
Dim lProcess As Long
Dim lExitCode As Long
Dim lResult As Long
On Error GoTo ErrorHandler
''' Run the Shell function.
lTaskID = Shell(szCommandLine, iWindowState)
''' Check for errors.
If lTaskID = 0 Then Err.Raise 9999, , "Shell function error."
''' Get the process handle from the task ID returned by Shell.
lProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0&, lTaskID)
''' Check for errors.
If lProcess = 0 Then Err.Raise 9999, , "Unable to open Shell process handle."
''' Loop while the shelled process is still running.
Do
''' lExitCode will be set to STILL_ACTIVE as long as the shelled process is running.
lResult = GetExitCodeProcess(lProcess, lExitCode)
DoEvents
Loop While lExitCode = STILL_ACTIVE
bShellAndWait = True
Exit Function
ErrorHandler:
gszErrMsg = Err.Description
bShellAndWait = False
End Function

I found the answer to my question. First you have to activate the Arena Libary in VBA.
Extra-->References--> select "Arena 14.0 Type Library". Then you can open, run and end an Arena model with this code.
'Declare variables
Dim oArenaApp As Arena.Application
Dim oModel As Arena.Model, oSIMAN As Arena.SIMAN
Dim oModule As Arena.Module
'Start Arena, open model, make Arena active & visible
Set oArenaApp = CreateObject("Arena.Application")
ModName = "YOUR FILEPATH"
Set oModel = oArenaApp.Models.Open(ModName)
Set oSIMAN = oModel.SIMAN
oArenaApp.Activate
oArenaApp.Visible = True
'Run model in batch mode and send results back to Excel
oModel.BatchMode = True ' Turn off animation
oModel.QuietMode = True ' Do not ask final question
oModel.Go (smGoWait) ' Suspend VB until run ends
'End model run and exit Arena
oModel.End
oArenaApp.Visible = False

Related

Trying to use VBA to Open a PowerBI File, Refresh it, and Save it?

I am trying to open a .pbix file that sits on a network drive, refresh the PowerBI connection to the file, then close the file and save the changes. I am trying to run the process from Excel, because Excel does some things, propr to this refresh task. I am testing the code below, which I think is pretty close, but I an getting this error message:
RUN TIME ERROR: 424 Object Required
Public vPID As Variant
Sub Launch_Calculator()
Dim fileString as String
If IsProcessRunning("C:\Program Files\PBIDesktop.exe") = True Then
On Error GoTo Reload ' Open new instance of PBIX
AppActivate (vPID) ' Reactivate, using Public declared variant
SendKeys "%{Enter}" ' Bring it back into focus if user minimises it
Else
Reload:
fileString = """\\network_path_here\testing.pbix"""
strFileName = CreateObject("WScript.Shell").Specialfolders("\\network_path_here\") & "testing.pbix"
' fileString.Open...got RUN TIME ERROR: 424 Object Required
' strFileName.Open...got RUN TIME ERROR: 424 Object Required
End If
On error GoTo 0
End Sub
' Function to check for running application by its process name
Function IsProcessRunning(sApp As String)
On Error GoTo Skip
Dim objList As Object
Set objList = GetObject("winmgmts:") _
.ExecQuery("select * from win32_process where name='" & sApp & "'")
If objList.Count > 0 Then
IsProcessRunning = True
Exit Function
Else
IsProcessRunning = False
Exit Function
End If
Skip:
IsProcessRunning = False
End Function
So, I can open the PowerBI.exe file, and run the application just fine, but I can't open and refresh the '.pbix' file. How can I open the .pbix file, refresh it, and save it?

Tackle the 'Not responding application outside of Microsoft Access' error in the calling Access VBA

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

How to trap any VBS error and return it to the calling VBA in Access

I have a program in Microsoft Access. I have VBS script files to automate SAP GUI screens ("transactions"). Using VBA in Access opens these different VBS script files using the Scriptcontrol object and performs a transaction in a SAP system.
Now, sometimes there is an error while running the transaction and then the script stops. I have written the error handler in every VBS script files.
My goal is that if there is an error in the SAP while running .VBS then it should close the active SAP session and store the status information in a string called "ScriptStatus". Then I pull this string to the calling vba back and again run the same .vbs script.
Code in the .VBS
dim ScriptStatus
Function (DoWork)
If Not IsObject(application) Then
Set SapGuiAuto = GetObject("SAPGUI")
Set application = SapGuiAuto.GetScriptingEngine
End If
If Not IsObject(connection) Then
Set connection = application.Children(0)
End If
If Not IsObject(session) Then
Set session = connection.Children(0)
End If
If IsObject(WScript) Then
WScript.ConnectObject session, "on"
WScript.ConnectObject application, "on"
End If
on error resume Next
'SAP Code
session.findById("wnd[0]").maximize
'Furhter SAP Code
'Change the ScriptStatus to completed
ScriptStatus = "Script Completed"
If Err.Number <> 0 Then
'Change ScriptStatus
ScriptStatus = "Script Error"
'Close SAP Session
session.findById("wnd[0]").Close
End If
End Function
The code in the calling VBA
Sub Foo()
Dim vbsCode As String, result As Variant, script As Object, ScriptInfo As String
ReRunScript:
'// load vbs source
Open "x.vbs" For Input As #1
vbsCode = Input$(LOF(1), 1)
Close #1
On Error GoTo ERR_VBS
Set script = CreateObject("ScriptControl")
script.Language = "VBScript"
script.AddCode vbsCode
result = script.Run("DoWork")
ScriptInfo = script.Eval("ScriptStatus")
If ScriptInfo = "Script Completed" Then
Exit Sub
Elseif ScriptInfo = "Script Error" Then
Goto ReRunScript
End if
ERR_VBS:
MsgBox Err.Description
MsgBox script.Eval("ScriptStatus")
End Sub
Rather than running them via cscript you can execute them directly using the ScriptControl (32 bit only) - this would let you catch the errors directly in Access with a standard On Error (As well as allowing you to capture a return value).
Example .VBS file:
function DoWork
'// do some work
msgbox 1
'// error
x = 100 / 0
DoWork = "OK"
end function
VBA:
Sub Foo()
Dim vbsCode As String, result As Variant
'// load vbs source
Open "x.vbs" For Input As #1
vbsCode = Input$(LOF(1), 1)
Close #1
On Error GoTo ERR_VBS
With CreateObject("ScriptControl")
.Language = "VBScript"
.AddCode vbsCode
result = .Run("DoWork")
End With
Exit Sub
ERR_VBS:
MsgBox Err.Description
End Sub
Edit - To capture your Status variable make it global in the script (declared outside of a sub/function) and use the .Eval() method to read in in VBA.
Example .VBS file:
dim Status
function DoWork
'// do some work
msgbox 1
Status = "Hello World"
'// error
x = 100 / 0
DoWork = "OK"
end function
VBA:
Sub Foo()
Dim vbsCode As String, result As Variant, script As Object
'// load vbs source
Open "x.vbs" For Input As #1
vbsCode = Input$(LOF(1), 1)
Close #1
On Error GoTo ERR_VBS
Set script = CreateObject("ScriptControl")
script.Language = "VBScript"
script.AddCode vbsCode
result = script.Run("DoWork")
Exit Sub
ERR_VBS:
MsgBox Err.Description
'// read VBS global
MsgBox script.Eval("Status")
End Sub

Pass output from powershell script to variable in VBA [duplicate]

Found this function on http://www.cpearson.com/excel/ShellAndWait.aspx
But I would also need to capture the output from the shell. Any code suggestion?
Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modShellAndWait
' By Chip Pearson, chip#cpearson.com, www.cpearson.com
' This page on the web site: www.cpearson.com/Excel/ShellAndWait.aspx
' 9-September-2008
'
' This module contains code for the ShellAndWait function that will Shell to a process
' and wait for that process to end before returning to the caller.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Const SYNCHRONIZE = &H100000
Public Enum ShellAndWaitResult
Success = 0
Failure = 1
TimeOut = 2
InvalidParameter = 3
SysWaitAbandoned = 4
UserWaitAbandoned = 5
UserBreak = 6
End Enum
Public Enum ActionOnBreak
IgnoreBreak = 0
AbandonWait = 1
PromptUser = 2
End Enum
Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80
Private Const STATUS_WAIT_0 As Long = &H0
Private Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0)
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0)
Private Const WAIT_TIMEOUT As Long = 258&
Private Const WAIT_FAILED As Long = &HFFFFFFFF
Private Const WAIT_INFINITE = -1&
Public Function ShellAndWait(ShellCommand As String, _
TimeOutMs As Long, _
ShellWindowState As VbAppWinStyle, _
BreakKey As ActionOnBreak) As ShellAndWaitResult
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShellAndWait
'
' This function calls Shell and passes to it the command text in ShellCommand. The function
' then waits for TimeOutMs (in milliseconds) to expire.
'
' Parameters:
' ShellCommand
' is the command text to pass to the Shell function.
'
' TimeOutMs
' is the number of milliseconds to wait for the shell'd program to wait. If the
' shell'd program terminates before TimeOutMs has expired, the function returns
' ShellAndWaitResult.Success = 0. If TimeOutMs expires before the shell'd program
' terminates, the return value is ShellAndWaitResult.TimeOut = 2.
'
' ShellWindowState
' is an item in VbAppWinStyle specifying the window state for the shell'd program.
'
' BreakKey
' is an item in ActionOnBreak indicating how to handle the application's cancel key
' (Ctrl Break). If BreakKey is ActionOnBreak.AbandonWait and the user cancels, the
' wait is abandoned and the result is ShellAndWaitResult.UserWaitAbandoned = 5.
' If BreakKey is ActionOnBreak.IgnoreBreak, the cancel key is ignored. If
' BreakKey is ActionOnBreak.PromptUser, the user is given a ?Continue? message. If the
' user selects "do not continue", the function returns ShellAndWaitResult.UserBreak = 6.
' If the user selects "continue", the wait is continued.
'
' Return values:
' ShellAndWaitResult.Success = 0
' indicates the the process completed successfully.
' ShellAndWaitResult.Failure = 1
' indicates that the Wait operation failed due to a Windows error.
' ShellAndWaitResult.TimeOut = 2
' indicates that the TimeOutMs interval timed out the Wait.
' ShellAndWaitResult.InvalidParameter = 3
' indicates that an invalid value was passed to the procedure.
' ShellAndWaitResult.SysWaitAbandoned = 4
' indicates that the system abandoned the wait.
' ShellAndWaitResult.UserWaitAbandoned = 5
' indicates that the user abandoned the wait via the cancel key (Ctrl+Break).
' This happens only if BreakKey is set to ActionOnBreak.AbandonWait.
' ShellAndWaitResult.UserBreak = 6
' indicates that the user broke out of the wait after being prompted with
' a ?Continue message. This happens only if BreakKey is set to
' ActionOnBreak.PromptUser.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim TaskID As Long
Dim ProcHandle As Long
Dim WaitRes As Long
Dim Ms As Long
Dim MsgRes As VbMsgBoxResult
Dim SaveCancelKey As XlEnableCancelKey
Dim ElapsedTime As Long
Dim Quit As Boolean
Const ERR_BREAK_KEY = 18
Const DEFAULT_POLL_INTERVAL = 500
If Trim(ShellCommand) = vbNullString Then
ShellAndWait = ShellAndWaitResult.InvalidParameter
Exit Function
End If
If TimeOutMs < 0 Then
ShellAndWait = ShellAndWaitResult.InvalidParameter
Exit Function
ElseIf TimeOutMs = 0 Then
Ms = WAIT_INFINITE
Else
Ms = TimeOutMs
End If
Select Case BreakKey
Case AbandonWait, IgnoreBreak, PromptUser
' valid
Case Else
ShellAndWait = ShellAndWaitResult.InvalidParameter
Exit Function
End Select
Select Case ShellWindowState
Case vbHide, vbMaximizedFocus, vbMinimizedFocus, vbMinimizedNoFocus, vbNormalFocus, vbNormalNoFocus
' valid
Case Else
ShellAndWait = ShellAndWaitResult.InvalidParameter
Exit Function
End Select
On Error Resume Next
Err.Clear
TaskID = Shell(ShellCommand, ShellWindowState)
If (Err.Number <> 0) Or (TaskID = 0) Then
ShellAndWait = ShellAndWaitResult.Failure
Exit Function
End If
ProcHandle = OpenProcess(SYNCHRONIZE, False, TaskID)
If ProcHandle = 0 Then
ShellAndWait = ShellAndWaitResult.Failure
Exit Function
End If
On Error GoTo ErrH:
SaveCancelKey = Application.EnableCancelKey
Application.EnableCancelKey = xlErrorHandler
WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)
Do Until WaitRes = WAIT_OBJECT_0
DoEvents
Select Case WaitRes
Case WAIT_ABANDONED
' Windows abandoned the wait
ShellAndWait = ShellAndWaitResult.SysWaitAbandoned
Exit Do
Case WAIT_OBJECT_0
' Successful completion
ShellAndWait = ShellAndWaitResult.Success
Exit Do
Case WAIT_FAILED
' attach failed
ShellAndWait = ShellAndWaitResult.Failure
Exit Do
Case WAIT_TIMEOUT
' Wait timed out. Here, this time out is on DEFAULT_POLL_INTERVAL.
' See if ElapsedTime is greater than the user specified wait
' time out. If we have exceed that, get out with a TimeOut status.
' Otherwise, reissue as wait and continue.
ElapsedTime = ElapsedTime + DEFAULT_POLL_INTERVAL
If Ms > 0 Then
' user specified timeout
If ElapsedTime > Ms Then
ShellAndWait = ShellAndWaitResult.TimeOut
Exit Do
Else
' user defined timeout has not expired.
End If
Else
' infinite wait -- do nothing
End If
' reissue the Wait on ProcHandle
WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)
Case Else
' unknown result, assume failure
ShellAndWait = ShellAndWaitResult.Failure
Exit Do
Quit = True
End Select
Loop
CloseHandle ProcHandle
Application.EnableCancelKey = SaveCancelKey
Exit Function
ErrH:
Debug.Print "ErrH: Cancel: " & Application.EnableCancelKey
If Err.Number = ERR_BREAK_KEY Then
If BreakKey = ActionOnBreak.AbandonWait Then
CloseHandle ProcHandle
ShellAndWait = ShellAndWaitResult.UserWaitAbandoned
Application.EnableCancelKey = SaveCancelKey
Exit Function
ElseIf BreakKey = ActionOnBreak.IgnoreBreak Then
Err.Clear
Resume
ElseIf BreakKey = ActionOnBreak.PromptUser Then
MsgRes = MsgBox("User Process Break." & vbCrLf & _
"Continue to wait?", vbYesNo)
If MsgRes = vbNo Then
CloseHandle ProcHandle
ShellAndWait = ShellAndWaitResult.UserBreak
Application.EnableCancelKey = SaveCancelKey
Else
Err.Clear
Resume Next
End If
Else
CloseHandle ProcHandle
Application.EnableCancelKey = SaveCancelKey
ShellAndWait = ShellAndWaitResult.Failure
End If
Else
' some other error. assume failure
CloseHandle ProcHandle
ShellAndWait = ShellAndWaitResult.Failure
End If
Application.EnableCancelKey = SaveCancelKey
End Function
Based on Andrew Lessard's answer, here's a function to run a command and return the output as a string -
Public Function ShellRun(sCmd As String) As String
'Run a shell command, returning the output as a string
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
'run command
Dim oExec As Object
Dim oOutput As Object
Set oExec = oShell.Exec(sCmd)
Set oOutput = oExec.StdOut
'handle the results as they are written to and read from the StdOut object
Dim s As String
Dim sLine As String
While Not oOutput.AtEndOfStream
sLine = oOutput.ReadLine
If sLine <> "" Then s = s & sLine & vbCrLf
Wend
ShellRun = s
End Function
Usage:
MsgBox ShellRun("dir c:\")
You can CreateProcess the application redirecting its StdOut to a pipe, then read that pipe directly; http://pastebin.com/CszKUpNS
dim resp as string
resp = redirect("cmd","/c dir")
resp = redirect("ipconfig","")
Based on Brian Burns' answer, I added passing input (using StdInput) to the executable during the call. Just in case somebody stumbles upon this and has the same need.
''' <summary>
''' Executes the given executable in a shell instance and returns the output produced
''' by it. If iStdInput is given, it is passed to the executable during execution.
''' Note: You must make sure to correctly enclose the executable path or any given
''' arguments in quotes (") if they contain spaces.
''' </summary>
''' <param name="iExecutablePath">
''' The full path to the executable (and its parameters). This string is passed to the
''' shell unaltered, so be sure to enclose it in quotes if it contains spaces.
''' </param>
''' <param name="iStdInput">
''' The (optional) input to pass to the executable. Default: Null
''' </param>
Public Function ExecuteAndReturnStdOutput(ByVal iExecutablePath As String, _
Optional ByVal iStdInput As String = vbNullString) _
As String
Dim strResult As String
Dim oShell As WshShell
Set oShell = New WshShell
Dim oExec As WshExec
Set oExec = oShell.Exec(iExecutablePath)
If iStdInput <> vbNullString Then
oExec.StdIn.Write iStdInput
oExec.StdIn.Close ' Close input stream to prevent deadlock
End If
strResult = oExec.StdOut.ReadAll
oExec.Terminate
ExecuteAndReturnStdOutput = strResult
End Function
Note: You will need to add a reference to Windows Script Host Object Model so the types WshShell and WshExec are known.
(To do this go to Tools -> References in the VBA IDE's menu bar.)
You can use the following small C# program to test your call from VBA. (If you don't have Visual Studio (Express) handy, you can follow these instructions to quickly compile it from a simple source file.):
using System;
class Program
{
static void Main(string[] args)
{
// Read StdIn
string inputText = Console.In.ReadToEnd();
// Convert input to upper case and write to StdOut
Console.Out.Write(inputText.ToUpper());
}
}
In VBA you could then run the following method that should show you a message box containing "ABCDEF":
Public Sub TestStdIn()
MsgBox ExecuteAndReturnStdOutput("C:\ConvertStdInToUpper.exe", "abcdef")
End Sub
Based on the various answers mostly the one from Brian Burns, here is a shorten version, tested and functional :
Function F_shellExec(sCmd As String) As String
Dim oShell As New WshShell 'requires ref to Windows Script Host Object Model
F_shellExec = oShell.Exec(sCmd).StdOut.ReadAll
End Function
it works pretty fine and it's quite fast. BUT, if the output is too large (for example scanning the whole C: drive sCmd = "DIR /S C:\"), ReadAll will crash
So I came up with the 2nd solution bellow, which so far works fine, in both cases. Note that the 1st reading is faster, and that if it crash, the reading restart at the beginning, so you don't miss information
Function F_shellExec2(sCmd As String) As String
'Execute Windows Shell Commands
Dim oShell As New WshShell 'requires ref to Windows Script Host Object Model
'Dim oExec As WshExec 'not needed, but in case you need the type
Dim oOutput As TextStream
Dim sReturn As String
Dim iErr As Long
'Set oExec = oShell.Exec(sCmd) 'unused step, for the type
Set oOutput = oShell.Exec(sCmd).StdOut
On Error Resume Next
sReturn = oOutput.ReadAll
iErr = Err.Number
On Error GoTo 0
If iErr <> 0 Then
sReturn = ""
While Not oOutput.AtEndOfStream
sReturn = sReturn & oOutput.ReadLine & Chr(10)
Wend
End If
F_shellExec2 = sReturn
End Function
Regarding the reference to Windows Script Host Object Model:
You will need to add a reference to Windows Script Host Object Model so the types WshShell (and WshExec) are known.
(To do this go to Tools -> References in the VBA IDE's menu bar.)
You could always redirect the shell output to a file, then read the output from the file.
Sub StdOutTest()
Dim objShell As Object
Dim objWshScriptExec As Object
Dim objStdOut As Object
Dim rline As String
Dim strline As String
Set objShell = CreateObject("WScript.Shell")
Set objWshScriptExec = objShell.Exec("c:\temp\batfile.bat")
Set objStdOut = objWshScriptExec.StdOut
While Not objStdOut.AtEndOfStream
rline = objStdOut.ReadLine
If rline <> "" Then strline = strline & vbCrLf & CStr(Now) & ":" & Chr(9) & rline
' you can handle the results as they are written to and subsequently read from the StdOut object
Wend
MsgBox strline
'batfile.bat
'ping 1.1.1.1 -n 1 -w 2000 > nul
'echo 2
'ping 1.1.1.1 -n 1 -w 2000 > nul
'echo 4
'ping 1.1.1.1 -n 1 -w 2000 > nul
'echo 6
'ping 1.1.1.1 -n 1 -w 2000 > nul
'echo 8
End Sub
This function provides a quick way to run a Command Line command, using the clipboard object:
Capture command-line output:
Function getCmdlineOutput(cmd As String)
CreateObject("WScript.Shell").Run "cmd /c """ & cmd & "|clip""", 0, True 'output>clipbrd
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") 'latebound clipbrd obj
.GetFromClipboard 'get cmdline output from clipboard
getCmdlineOutput = .GetText(1) 'return clipboard contents
End With
End Function
Example usage:
Sub Demo1()
MsgBox getCmdlineOutput("w32tm /tz") 'returns the system Time Zone information
End Sub
It uses the WShell Run command because it optionally allows for asynchronous execution, meaning it will wait for the command to finish running before VBA continues, which is important when involving the clipboard.
It also utilizes a built-in but often-forgotten command line utility called clip.exe, in this case as a destination for the piped cmdline output.
Clipboard manipulation requires a reference to the Microsoft Forms 2.0 library, which in this case I created with a Late-bound reference (which looks different since MS Forms - aka fm20.dll - is a Windows library, not VBA).
Preserving Existing Clipboard Data:
In my case it was an issue that the function above wipes the existing clipboard data, so the function below is modified to retain & replace existing text on the clipboard.
If there is something other than text on the clipboard you'll be warned that it will be lost. Some heavy coding could allow for other/any type of clipboard data to be returned... but advanced clipboard manipulation is far more complex than most users realize, and I frankly don't have the need or desire to get into it. More info here.
Note that this in this method MS Forms is Early-Bound but could be changed if desired. (But remember as a general rule of thumb, late-binding generally doubles processing time.)
Function getCmdlineOutput2(cmd As String)
'requires Reference: C:\Windows\System32\FM20.DLL (MS Forms 2.0) [Early Bound]
Dim objClipboard As DataObject, strOrigClipbrd As Variant
Set objClipboard = New MSForms.DataObject 'create clipboard object
objClipboard.GetFromClipboard 'save existing clipboard text
If Not objClipboard.GetFormat(1) Then
MsgBox "Something other than text is on the clipboard.", 64, "Clipboard to be lost!"
Else
strOrigClipbrd = objClipboard.GetText(1)
End If
'shell to hidden commandline window, pipe output to clipboard, wait for finish
CreateObject("WScript.Shell").Run "cmd /c """ & cmd & "|clip""", 0, True
objClipboard.GetFromClipboard 'get cmdline output from clipboard
getCmdlineOutput2 = objClipboard.GetText(1) 'return clipboard contents
objClipboard.SetText strOrigClipbrd, 1 'Restore original clipboard text
objClipboard.PutInClipboard
End Function
Example Usage:
Sub Demo2()
MsgBox getCmdlineOutput2("dir c:\") 'returns directory listing of C:\
End Sub
For those situations where a small return is expected, this is the shortest command I've ever seen:
MsgBox CreateObject("WScript.Shell").Exec("C:\Windows\SysWOW64\WHOAMI.EXE /USER /FO CSV").StdOut.ReadAll

VBA: Sub to Write to a Log File

I have a set of macros defined in my workbook, and I'd like to offer the user the option to log events related to those macros in a log file.
I initiate the log by creating the following in ThisWorkbook:
Public writeLog as Boolean
Public logWrite as Object
Public log as Object
Private Sub Worksheet_Open()
Dim prompt as Integer
prompt = MsgBox("Would you like to log events for this session?", vbYesNo, "Log Events?")
If prompt Then
writeLog = True
Set logWrite = CreateObject("Scripting.FileSystemObject")
Set log = logWrite.CreateTextFile("C:/TEST.txt", False)
Else
writeLog = False
End If
End Sub
I then created a procedure that I can use to write an argument to this object, which I've stored in its own module:
Public Sub PrintLog(obj as Object, argument as String)
If writeLog = True Then
obj.WriteLine argument
End If
End Sub
Unfortunately, this doesn't work, and I'm not sure why: even if I don't include obj as an argument to the function (since log and logWrite were created as global variables), I'm not able to Call WriteLog("String here.") or Call WriteLog(log, "String here.") without an error (Compile Error: Argument Not Optional.)
Is it possible to get such a Sub() to work, so that I can call it from anywhere in the workbook (after a button is pressed in a userform, for example) without having to define a new Scripting.FileSystemObject in every module?
I think that you can solve your problem by making some minor changes to your code. I tried the following setup:
logger module:
Option Explicit
Private log As Object
Public Sub initLog()
Dim prompt As VbMsgBoxResult
Dim fso As Object
prompt = MsgBox("Would you like to log events for this session?", vbYesNo, "Log Events?")
If prompt = vbYes Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set log = fso.CreateTextFile("C:/TEST.txt", False)
End If
End Sub
Public Sub PrintLog(argument As String)
If Not log Is Nothing Then
log.WriteLine argument
End If
End Sub
Public Sub yadda()
'test
PrintLog "yadda"
End Sub
ThisWorkbook:
Private Sub Workbook_Open()
initLog
End Sub
This is my no-frills drop in replacement for Debug.Print(), that logs to "Log.txt" at your Workbook path.
To install : Just search and replace "Debug.Print" with "Log", and optionally call LogClear() at the start of your program.
Public Function Log(ByRef a_stringLogThis As String)
' send to TTY
Debug.Print (a_stringLogThis)
' append (not write) to disk
Open ThisWorkbook.path & "\Log.txt" For Append As #1
Print #1, a_stringLogThis
Close #1
End Function
OPTIONAL : And here's a helper you COULD call at the beginning of your to clear out the previous logs.
Public Function LogClear()
Debug.Print ("Erasing the previous logs.")
Open ThisWorkbook.path & "\Log.txt" For Output As #1
Print #1, ""
Close #1
End Function
OPTIONAL : Finally, if can't live without date and time in your logging, use this Log statement instead:
Public Function Log(ByRef a_stringLogThis As String)
' prepare date
l_stringDateTimeNow = Now
l_stringToday = Format(l_stringDateTimeNow, "YYYY-MM-DD hh:mm:ss")
' concatenate date and what the user wants logged
l_stringLogStatement = l_stringToday & " " & a_stringLogThis
' send to TTY
Debug.Print (l_stringLogStatement)
' append (not write) to disk
Open ThisWorkbook.path & "\Log.txt" For Append As #1
Print #1, l_stringLogStatement
Close #1
End Function
I believe you're having issues as writeLog already exists as a boolean. Error should be popping up "Ambiguous name detected"
Try the following,
Public bLog as Boolean
Public logWrite as Object
Public log as Object
Private Sub Worksheet_Open()
Dim prompt as Integer
prompt = MsgBox("Would you like to log events for this session?", vbYesNo, "Log Events?")
If prompt Then
bLog = True
Set logWrite = CreateObject("Scripting.FileSystemObject")
Set log = logWrite.CreateTextFile("C:/TEST.txt", False)
Else
bLog = False
End If
End Sub
Public Sub WriteLog(Optional obj as Object, Optional argument as String)
If bLog = True Then
obj.WriteLine argument
End If
End Sub
Edit: made parameters optional in WriteLog (or PrintLog) for further testing
' Write to a log file using Separator and Array of variant Parameters
' Auto generate the file
' USE EndLog to close
'use:
' PrintLog vbtab, "one", 2, 3
' PrintLog vbtab, "Apple","Windows","Linux","Android","Commodore","Amiga","Spectrum"
' EndLog
' Generate a csv file:
' PrintLog ";", rst!ID, rst!Name
Private FileLog As Object
Private fso As Object
Const DEBUG_LOG_FILE = "C:\log.txt"
Public Sub PrintLog(ByVal Separator As String, ParamArray Arguments() As Variant)
Dim ele As Variant
Dim line As String
If FileLog Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set FileLog = fso.CreateTextFile(DEBUG_LOG_FILE, True, True)
End If
line = CStr(Now()) ' Print Timestamp
For Each ele In Arguments
If line > "" Then line = line & Separator
line = line & CStr(ele)
Next
If line > "" Then FileLog.WriteLine line
End Sub
Public Sub EndLog()
On Error Resume Next
FileLog.Close
Set FileLog = Nothing
Set fso = Nothing
On Error GoTo 0
End Sub