I would like to repeat Creating Object until it gets created (opened).
In my case the problem looks like this. Application is opened via COM and access is controlled via licensing service. While all licenses are in use, you eventually will get an error as shown in attached image. But when free license will appear, you will be able to launch the application.
Dim ApplicationName As Object
Set ApplicationName = CreateObject("AppNameToLaunchViaCOM")
Is there any way to do it? And maybe inform the user how many times it failed to open etc.
Server Execution Failed window
You could try the following approach
Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As LongPtr)
Function getObj() As Object
On Error GoTo EH
Dim ApplicationName As Object
Set ApplicationName = CreateObject("AppNameToLaunchViaCOM")
Set getObj = ApplicationName
Exit Function
EH:
End Function
Sub TryOut()
Const MAX = 10
Dim i As Long
Dim myObj As Object
Do
Set myObj = getObj
If Not myObj Is Nothing Then
Exit Do
End If
' Code to wait
Sleep 1000
' exit loop in case more than max tries
i = i + 1
Loop Until i > MAX
If myObj Is Nothing Then
Debug.Print "No license"
' furher code
Else
Debug.Print "Tries", i
' furher code
End If
End Sub
Related
So I have some macros run inside an Excel document and wanted to know if there is a way to frequently output text to a Console window (Basicly using it like the immediate window).
I know there are multiple ways of writing text to files, I just want to display some info on the running process without using the immediate window or other windows inside Excel itself.
Using this helps me to display a single line, but I dont want to open a new window for every line:
Call Shell("cmd.exe /K echo testInfo", vbNormalFocus)
I do NOT want to run a command (except echo maybe?) to execute a task, its just supposed to display text.
Thank you in advance for any advice.
EDIT:
As an addition to #JohnRC 's post I found a solution without external applications:
Call Shell("PowerShell.exe -noexit -command get-content " + strPath + " -wait")
Logging information to a textfile at the location after running the command above does the trick.
OK, as I got a couple of downvotes on my earlier answer, I thought I should attempt to provide an actual answer to the request, namely to provide a way of sending log messages to a command prompt window. Here goes...
This solution is implemented as a VBA class that will send messages as comment lines to a separately-running command prompt window that has the text "ExcelLog" in the title. This command prompt must be started separately. The easiest way to do this is to create a shortcut named "ExcelLog" to just run CMD, then when this shortcut is opened the command prompt window will have "ExcelLog" in the title.
Inside the spreadsheet add the code for the class cConsole (below), and then in your VBA code create a global instance of the class and use the method .W "message" to send a text message to the console as a comment line (in this case using the prefix :: to the line to identify it as a comment).
The cConsole class looks for any command prompt window with the requisite title, then sends the comment message to that window. If the window cannot be found, it simply skips the action so the Excel VBA code continues to execute without reporting an error. Also if you open the command prompt window after Excel VBA has started running, cConsole will automatically connect to the window and start/resume sending messages. This means you can close and reopen the command prompt ExcelLog window any time without interrupting the execution of the VBA code.
This seems to work on my setup OK. I think it is a bit more trouble than simply tailing a text file, but - hey, you pays your money and takes your choice.
Here is the code of the cConsole class.
Option Explicit
'// cConsole class
'// This class wraps an interface to a separately-started command prompt
'// window to which messages are sent as comments, so that the command prompt
'// window can be used as a real-time scrolling log from Excel.
'// Each instance of this class creates its own connection to the
'// command prompt window which must have a title containing the text
'// "ExcelLog". If such a window is not open then messages are not
'// logged. The command prompt window can be opened after messages
'// have started, and it will be connected when the next message is
'// sent.
'// The simplest way to set up the necessary command prompt window is to
'// create a shortcut on the desktop the name "ExcelLog" which runs CMD
'// Usage - - - - - - - - - - - -
'//
'// Dim oConsole As New cConsole
'// :
'// oConsole.W "Message to be written to the console"
'//
'// Windows functions to get window handles etc
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
'// Handle of the excel log window
Private hLogWindow As Long
Private Sub Class_Initialize()
'// On instantiation, attempts to find the ExcelLog window
findExcelLogWindow
End Sub
Public Sub W(sMsg As String)
'// Public function used to send the given message
'// as a comment line to the linked window
SendToConsole ":: " & sMsg
End Sub
Private Sub SendToConsole(Command As String)
'// Connects to and sends a command line to the command prompt
'// window that is being used as the log
Dim res As Boolean
'// Check that a connection has been made and
'// attempt to connect if not
If hLogWindow = 0 Then
findExcelLogWindow
If hLogWindow = 0 Then Exit Sub
End If
On Error Resume Next
Do
'// Attempt to bring the logging window to the foreground
res = SetForegroundWindow(hLogWindow)
'// Check if successful, and send the command if so
If res Then
SendKeys Command & vbCrLf
Exit Do
Else
'// Not successful, so try reconnecting to the logging window
findExcelLogWindow
'// If we cannot connect, just exit without sending anything
If hLogWindow = 0 Then Exit Sub
End If
Loop
'// Check if there has been any error
If Err.Number <> 0 Then
hLogWindow = 0
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
End If
On Error GoTo 0
End Sub
Private Function findExcelLogWindow() As Long
'// This function looks for a command prompt window that has the text
'// ExcelLog in the title
Dim nLen As Long
Dim sData As String
Dim Class As String
Dim Title As String
'// Get handle to the first window
hLogWindow = 0
'// Check each window in turn
Do
hLogWindow = FindWindowEx(0&, hLogWindow, vbNullString, vbNullString)
'// Check that a window was found
If hLogWindow = 0 Then Exit Do
'// Get the class name of the window
sData = String$(100, Chr$(0))
nLen = GetClassName(hLogWindow, sData, 100)
Class = Left$(sData, nLen)
'// Get the title of the window
sData = String$(100, Chr$(0))
nLen = GetWindowText(hLogWindow, sData, 100)
Title = Left$(sData, nLen)
'// Check if the required window has been found
If Class = "ConsoleWindowClass" And InStr(Title, "ExcelLog") > 0 Then
'// Initialise the window to remove any prompt text
SendToConsole "PROMPT $S"
'// Write some initial messages
Me.W "*******************"
Me.W "[" & ThisWorkbook.Name & "] connected to console at " & Now
Me.W ""
'// Return the handle to the log window
findExcelLogWindow = hLogWindow
Exit Function
End If
Loop
'// The log window was not found, so return zero
findExcelLogWindow = 0
End Function
I tested this out by handling MouseMove events on an image control in a worksheet:
Option Explicit
Private oCons As New cConsole
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
oCons.W "MouseMove " & X & ", " & Y
End Sub
And here is the result
Instead of using a shell to act as a console to log messages, I have used a text file to hold the log, and monitored the output to the file with a tail utility (I have used WinTail from http://www.baremetalsoft.com/wintail/ but I am sure there are others). This is the code, which I put in a separate vba module named Log. Then call Log.W "Message" to log a message.
Option Explicit
'// You need a reference to "Microsoft Scripting Runtime" library in VBA
Private oLog As Scripting.TextStream
Private bErr As Boolean
Private Sub INIT()
'// Initialise the output log file
'// Check if log file is already open, or there has been an error
If bErr Then Exit Sub
If Not oLog Is Nothing Then Exit Sub
'// Open the log file for appending
Dim ofso As New Scripting.FileSystemObject
On Error Resume Next
Set oLog = ofso.OpenTextFile("excel.log", ForAppending, True)
'// Check that open was successful
If Err.Number <> 0 Then
MsgBox "Log file error: " & Err.Number & ": " & Err.Description
bErr = True
Exit Sub
End If
On Error GoTo 0
'// Write a starting block to the log
oLog.WriteLine "*"
W "********************************** START"
W "* Start of log " & Format(Date, "YYYY-MM-dd")
W ""
End Sub
Public Sub W(sMsg)
'// Writes a single line message to the log
'// Initialize if required
INIT
'// Check for log file error
If bErr Then Exit Sub
'// Create the log line and write to log file
Dim st As String
st = Format(Now, "hh:mm:ss ")
oLog.WriteLine st & sMsg
End Sub
Public Function ReportErr(Optional Loc As Variant = "") As Boolean
'// Reports information from the Err object, if an error has occured
'// Check if error has occurred, exit if not
If Err.Number = 0 Then ReportErr = False: Exit Function
'// Set return value
ReportErr = True
'// Initialize if required
INIT
'// Check for log file error
If bErr Then Exit Function
'// Write the error block to the log
W "*********** ERROR ******* " & IIf(Len(Loc) > 0, "[" & Loc & "]", "")
W "* Error #" & Err.Number
If Len(Err.Description) > 0 Then
W "* : " & Err.Description
W "*************************"
End If
End Function
Tailing the log file with WinTail means that output to the log appears immediately it is written, so you can monitor the log as the program is running.
I have a Word 2010 template with fields, and drop down lists etc and a save button to save the document in a certain place with a certain name. Part of the file name I retrieve as the network username in VBA and another part of the file name is the Date. This works fine for me but when I attempt to test the document with another user the VBA code complains at the line below stating "Compile error: can't find project or library".
strUserName = (Environ$("username"))
If I changed the above to be like the line below instead and another user opens the template and clicks the save button
strUserName = "validnetworkname"
It then complains with the same error at the next VBA referencing which is
strDate = Date
What is wrong here please?
I use this function:
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function UserName() As String
On Error GoTo ErrProc
Dim lnglen As Long
lnglen = 255
Dim strSpace As String
strSpace = String(254, 0)
Dim lngX As Long
lngX = apiGetUserName(strSpace, lnglen)
If lngX <> 0 Then GetUserName = Left(strSpace, lnglen - 1)
Leave:
On Error GoTo 0
Exit Function
ErrProc:
Resume Leave
End Function
To call it:
Dim user_ As String
user_ = UserName
Hope you are doing well. The site i tried to scrape category-names from is very simple to look at if you notice it's inspected element but when i create a parser i can't pull the data. I wanted to scrape only the 7 category names from that page. I tried with all possible angles but failed. If anybody helps me point out what I'm doing wrong, I would be very grateful to him. Thanks in advance. FYC, I'm pasting here the code I tried with.
Sub ItemName()
Dim http As New MSXML2.XMLHTTP60, html As New HTMLDocument
Dim topics As Object, topic As Object, posts As Object, post As Object, ele As Object
Dim x As Long
x = 2
http.Open "GET", "http://www.bjs.com/tv--electronics.category.3000000000000144985.2002193", False
http.send
html.body.innerHTML = http.responseText
Set topics = html.getElementsByClassName("categories")
For Each topic In topics
For Each posts In topic.getElementsByTagName("li")
For Each post In posts.getElementsByTagName("a")
Set ele = post.getElementsByTagName("h4")(0)
Cells(x, 1) = ele.innerText
x = x + 1
Next post
Next posts
Next topic
End Sub
Here's one possible solution, I'm using the internet explorer object instead of MSXML. I'm able to retrieve the data from the page, and it's pretty quick.
Here's the full code:
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub ItemName()
On Error GoTo errhand:
Dim ie As Object: Set ie = CreateObject("InternetExplorer.Application")
Dim topics As Object, topic As Object
Dim i As Byte
With ie
.Visible = False
.Navigate "http://www.bjs.com/tv--electronics.category.3000000000000144985.2002193"
Sleep 500 ' Wait for the page to start loading
Do Until .document.readyState = 4 Or .busy = False Or i >= 100
Sleep 100
DoEvents
i = i + 1
Loop
End With
Set topics = ie.document.getElementsByClassName("name ng-binding")
For Each topic In topics
'Print out the element's innertext
Debug.Print topic.innertext
Next
ie.Quit
Set ie = Nothing
Exit Sub
errhand:
Debug.Print Err.Number, Err.Description
ie.Quit
Set ie = Nothing
End Sub
As the content of that site are generated dynamically, so there is no way for xmlhttp request to catch the page source. However, to get around that selenium is good to go, as it works well when it comes to deal with javascriptheavy website. I only used selenium in my below script to get the page source. As soon as it get that, I reverted back to usual vba method to accomplish the process.
Sub Grabbing_item()
Dim driver As New ChromeDriver, html As New HTMLDocument
Dim post As Object
With driver
.get "http://www.bjs.com/tv--electronics.category.3000000000000144985.2002193"
html.body.innerHTML = .ExecuteScript("return document.body.innerHTML;")
.Quit
End With
For Each post In html.getElementsByClassName("name")
x = x + 1: Cells(x, 1) = post.innerText
Next post
End Sub
I have been struggling to identify the cause of an error in a PPT Add-in that is distributed across about 40 end users.
Problem: loss of the ribbon state/loss of the ribbonUI object.
For some users, eventually the Rib object becomes Nothing.
Users assure me they are not getting any run-time errors nor script errors (from COM object that we also invoke through this add-in). An unhandled error, if user hits End would expectedly cause the state loss.
None of the users have been able to reliably reproduce the scenario which causes the observed failure. This is what makes it very difficult to troubleshoot. I am hoping against hope that there is something obvious that I'm missing, or that I didn't anticipate.
How I currently handle loss or RibbonUI
In attempt to combat this, I store the object pointer to the ribbon in THREE places, this seems like overkill to me but it is still apparently not sufficient:
A class object called cbRibbon has a property .RibbonUI which is assigned; Set cbRibbon.RibbonUI = Rib during the ribbon's onLoad callback procedure. So we have a byRef copy of the object itself. If the ribbon is nothing, theoretically I can Set rib = cbRibbon.RibbonUI and this works unless cbRibbon object is also out of scope.
The cbRibbon object has property .Pointer which is assigned: cbRibbon.Pointer = ObjPtr(Rib).
A CustomDocumentProperty called "RibbonPointer" is also used to store a reference to the object pointer. (Note: This persists even beyond state loss)
So you can see I've given some thought to this in attempt to replicate the way of storing this pointer the way one might store it in a hidden worksheet/range in Excel.
Additional information
I can see from robust client-side logging that this the error appears to happen usually but not always during the procedure below, which is used to refresh/invalidate the ribbon and its controls.
This procedure is called any time I need to dynamically refresh the ribbon or part of its controls:
Call RefreshRibbon(id)
The error appears to (sometimes, I can't stress this enough: the error cannot be replicated on-demand) happen during a full refresh, which is called like:
Call RefreshRibbon("")
This is the procedure that does the invalidation:
Sub RefreshRibbon(id As String)
If Rib Is Nothing Then
If RibbonError(id) Then GoTo ErrorExit
End If
Select Case id
Case vbNullString, "", "RibbonUI"
Call Logger.LogEvent("RefreshRibbon: Rib.Invalidate", Array("RibbonUI", _
"Ribbon:" & CStr(Not Rib Is Nothing), _
"Pointer:" & ObjPtr(Rib)))
Rib.Invalidate
Case Else
Call Logger.LogEvent("RefreshRibbon: Rib.InvalidateControl", Array(id, _
"Ribbon:" & CStr(Not Rib Is Nothing), _
"Pointer:" & ObjPtr(Rib)))
Rib.InvalidateControl id
End Select
Exit Sub
ErrorExit:
End Sub
As you can see, the very first thing I do in this procedure is test the Rib object for Nothing-ness. If this evaluates to True, then the RibbonUI object has somehow been lost.
The error function then attempts to re-instantiate the ribbon: first from cbRibbon.RibbonUI, then from the cbRibbon.Pointer and if both of those fails, then from the CustomDocumentProperties("RibbonPointer") value. If neither of these succeeds, then we display a fatal error and the user is prompted to close the PowerPoint application. If any one of these succeeds, then the ribbon is reloaded programmatically and everything continues to work.
Here is the code for that procedure. Note that it calls several other procedures which I have not included code for. These are helper functions or logger functions. The .GetPointer method actually invokes the WinAPI CopyMemory function to reload the object from its pointer value.
Function RibbonError(id As String) As Boolean
'Checks for state loss of the ribbon
Dim ret As Boolean
If id = vbNullString Then id = "RibbonUI"
Call Logger.LogEvent("RibbonError", Array("Checking for Error with Ribbon" & vbCrLf & _
"id: " & id, _
"Pointer: " & ObjPtr(Rib), _
"cbPointer: " & cbRibbon.Pointer))
If Not Rib Is Nothing Then
GoTo EarlyExit
End If
On Error Resume Next
'Attempt to restore from class object:
Set Rib = cbRibbon.ribbonUI
'Attempt to restore from Pointer reference if that fails:
If Rib Is Nothing Then
'Call Logger.LogEvent("Attempt to Restore from cbRibbon", Array(cbRibbon.Pointer))
If Not CLng(cbRibbon.Pointer) = 0 Then
Set Rib = cbRibbon.GetRibbon(cbRibbon.Pointer)
End If
End If
'Attempt to restore from CDP
If Rib Is Nothing Then
'Call Logger.LogEvent("Attempt to Restore from CDP", Array(MyDoc.CustomDocumentProperties("RibbonPointer")))
If HasCustomProperty("RibbonPointer") Then
cbRibbon.Pointer = CLng(MyDoc.CustomDocumentProperties("RibbonPointer"))
Set Rib = cbRibbon.GetRibbon(cbRibbon.Pointer)
End If
End If
On Error GoTo 0
If Rib Is Nothing Then
Debug.Print "Pointer value was: " & cbRibbon.Pointer
'Since we can't restore from an invalid pointer, erase this in the CDP
' a value of "0" will set Rib = Nothing, anything else will crash the appliation
Call SetCustomProperty("RibbonPointer", "0")
Else
'Reload the restored ribbon:
Call RibbonOnLoad(Rib)
Call SetCustomProperty("RibbonPointer", ObjPtr(Rib))
cbRibbon.Pointer = ObjPtr(Rib)
End If
'Make sure the ribbon exists or was able to be restored
ret = (Rib Is Nothing)
If ret Then
'Inform the user
MsgBox "A fatal error has been encountered. Please save & restart the presentation", vbCritical, Application.Name
'Log the event to file
Call Logger.LogEvent("RibbonError", Array("FATAL ERROR"))
Call ReleaseTrap
End If
EarlyExit:
RibbonError = ret
End Function
All of this works perfectly well in theory and in fact I can straight-up kill run-time (by invoking the End statement or otherwise) and these procedures reset the ribbon as expected.
So, what am I missing?
OK I forgot about this... while I still have not pinpointed the error I have some ideas that users are simply not reporting unhandled runtime errors and instead they're hitting "End" when prompted by PowerPoint.
I'm reasonably certain that is the cause and I have confirmation that in many cases, that sort of error precedes the "crash", so I'm updating to resolve that soon.
Otherwise, here is the method I ultimately have been using for several months, with success.
Create a procedure that writes the Pointer value of the ribbon on the user's machine. I didn't want to do this, but ultimately had to:
Sub LogRibbon(pointer As Long)
'Writes the ribbon pointer to a text file
Dim filename As String
Dim FF As Integer
filename = "C:\users\" & Environ("username") & "\AppData\Roaming\Microsoft\AddIns\pointer.txt"
FF = FreeFile
Open filename For Output As FF
Print #FF, pointer
Close FF
End Sub
In the ribbon's _OnLoad event handler, I call the LogRibbon procedure:
Public Rib As IRibbonUI
Public cbRibbon As New cRibbonProperties
Sub RibbonOnLoad(ribbon As IRibbonUI)
'Callback for customUI.onLoad
Set Rib = ribbon
Call LogRibbon(ObjPtr(Rib))
'Store the properties so we can easily access them later
cbRibbon.ribbonUI = Rib
End Sub
I created a class object to store some information about the ribbon to avoid repeated and slow calls to an external API, but for this purpose you can create a class that stores just the pointer value. That is referenced above in the cbRibbon.ribbonUI = Rib. This GetRibbon method of this class uses the CopyMemory function from WinAPI to restore the object from it's pointer.
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (destination As Any, source As Any, _
ByVal length As Long)
'example ported from Excel:
'http://www.excelguru.ca/blog/2006/11/29/modifying-the-ribbon-part-6/
Private pControls As Object
Private pRibbonUI As IRibbonUI
Private pPointer As Long
Sub Class_Initialize()
'Elsewhere I add some controls to this dictionary so taht I can invoke their event procedures programmatically:
Set pControls = CreateObject("Scripting.Dictionary")
Set pRibbonUI = Rib
Call SaveRibbonPointer(Rib)
pConnected = False
End Sub
'#############################################################
'hold a reference to the ribbon itself
Public Property Let ribbonUI(iRib As IRibbonUI)
'Set RibbonUI to property for later use
Set pRibbonUI = iRib
End Property
Public Property Get ribbonUI() As IRibbonUI
'Retrieve RibbonUI from property for use
Set ribbonUI = pRibbonUI
End Property
'http://www.mrexcel.com/forum/excel-questions/518629-how-preserve-regain-id-my-custom-ribbon-ui.html
Public Sub SaveRibbonPointer(ribbon As IRibbonUI)
Dim lngRibPtr As Long
' Store the custom ribbon UI Id in a static variable.
' This is done once during load of UI.
lngRibPtr = ObjPtr(ribbon)
cbRibbon.pointer = lngRibPtr
End Sub
Function GetRibbon(lngRibPtr As Long) As Object
'Uses CopyMemory function to re-load a ribbon that
' has been inadvertently lost due to run-time error/etc.
Dim filename As String
Dim ret As Long
Dim objRibbon As Object
filename = "C:\users\" & Environ("username") & "\AppData\Roaming\Microsoft\AddIns\pointer.txt"
On Error Resume Next
With CreateObject("Scripting.FileSystemObject").GetFile(filename)
ret = .OpenAsTextStream.ReadLine
End With
On Error GoTo 0
If lngRibPtr = 0 Then
lngRibPtr = ret
End If
CopyMemory objRibbon, lngRibPtr, 4
Set GetRibbon = objRibbon
' clean up invalid object
CopyMemory objRibbon, 0&, 4
Set objRibbon = Nothing
End Function
'##############################################################
' Store the pointer reference to the RibbonUI
Public Property Let pointer(p As Long)
pPointer = p
End Property
Public Property Get pointer() As Long
pointer = pPointer
End Property
'#############################################################
'Dictionary of control properties for Dropdowns/ComboBox
Public Property Let properties(p As Object)
Set pProperties = p
End Property
Public Property Get properties() As Object
Set properties = pProperties
End Property
Then, I have a function which checks for loss of ribbon, and restores from the pointer value. This one actually invokes the OnLoad procedure, which we can do since we have an object variable (or class object property) representing the Ribbon object).
Function RibbonError(id As String) As Boolean
'Checks for state loss of the ribbon
Dim ret As Boolean
Dim ptr As Long
Dim src As String
On Error Resume Next
If Not Rib Is Nothing Then
GoTo EarlyExit
End If
If Rib is Nothing then
ptr = GetPointerFile
cbRibbon.pointer = ptr
Set Rib = cbRibbon.GetRibbon(ptr)
End If
On Error GoTo 0
'make sure the ribbon has been restored or exists:
ret = (Rib is Nothing)
If Not ret then
'Reload the restored ribbon by invoking the OnLoad procedure
' we can only do this because we have a handle on the Ribbon object now
Call RibbonOnLoad(Rib)
cbRibbon.pointer = ObjPtr(Rib) 'store the new pointer
Else
MsgBox "A fatal error has been encountered.", vbCritical
End If
EarlyExit:
RibbonError = ret
End Function
Call on the RibbonError function any time you are going to refresh the ribbon through either Invalidate or InvalidateControl methods.
The code above may not 100% compile -- I had to modify it and trim some stuff out, so let me know if you have any problems trying to implement it!
Found the real solution: Credit
Public Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (destination As Any, source As Any, _
ByVal length As Long)
Public Sub ribbon L o a ded(ribbon As IRibbonUI)
' Store pointer to IRibbonUI
Dim lngRibPtr As Long
' Store the custom ribbon UI Id in a static variable.
' This is done once during load of UI. I.e. during workbook open.
Set guiRibbon = ribbon
lngRibPtr = ObjPtr(ribbon)
' Write pointer to worksheet for safe keeping
Tabelle2.Range("A1").Value = lngRibPtr
End Sub
Function GetRibbon(lngRibPtr as Long) As Object
Dim objRibbon As Object
CopyMemory objRibbon, lngRibPtr, 4
Set GetRibbon = objRibbon
' clean up invalid object
CopyMemory objRibbon, 0&, 4
Set objRibbon = Nothing
End Function
Then
Public Sub DoButton(ByVal control As IRibbonControl)
' The onAction callback for btn1 and btn2
' Toggle state
Toggle12 = Not Toggle12
' Invalidate the ribbon UI so that the enabled-states get reloaded
If Not (guiRibbon Is Nothing) Then
' Invalidate will force the UI to reload and thereby ask for their enabled-states
guiRibbon.Invalidate 'Control ("tabCustom") InvalidateControl does not work reliably
Else
Set guiRibbon = GetRibbon(CLng(Tabelle2.Range("A1").Value))
guiRibbon.Invalidate
' The static guiRibbon-variable was meanwhile lost
' MsgBox "Due to a design flaw in the architecture of the MS ribbon UI you have to close " & _
' "and reopen this workbook." & vbNewLine & vbNewLine & _
' "Very sorry about that.", vbExclamation + vbOKOnly
MsgBox "Hopefully this is sorted now?"
' Note: In the help we can find
' guiRibbon.Refresh
' but unfortunately this is not implemented.
' It is exactly what we should have instead of that brute force reload mechanism.
End If
End Sub
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