Firstly, we need a way to store data in the workbook. You can use named ranges or other stuff but I will use my library LibExcelBookItems because it's very easy to use.
Code also here for LibExcelBookItems module:
'''=============================================================================
''' Excel VBA Tools
''' -----------------------------------------------
''' https://github.com/cristianbuse/Excel-VBA-Tools
''' -----------------------------------------------
''' MIT License
'''
''' Copyright (c) 2018 Ion Cristian Buse
'''
''' Permission is hereby granted, free of charge, to any person obtaining a copy
''' of this software and associated documentation files (the "Software"), to
''' deal in the Software without restriction, including without limitation the
''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
''' sell copies of the Software, and to permit persons to whom the Software is
''' furnished to do so, subject to the following conditions:
'''
''' The above copyright notice and this permission notice shall be included in
''' all copies or substantial portions of the Software.
'''
''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
''' IN THE SOFTWARE.
'''=============================================================================
'*******************************************************************************
'' Description:
'' - Simple strings can be stored/retrieved using CustomXMLParts per book
'' - This module encapsulates the XML logic and exposes easy-to-use methods
'' without the need to write actual XML
'' Public/Exposed methods:
'' - BookItem - parametric property Get/Let
'' - GetBookItemNames
'' Notes:
'' - To delete a property simply set the value to a null string
'' e.g. BookItem(ThisWorkbook, "itemName") = vbNullString
'*******************************************************************************
Option Explicit
Option Private Module
Private Const XML_NAMESPACE As String = "ManagedExcelCustomXML"
Private Const rootName As String = "root"
'*******************************************************************************
'Returns the Root CustomXMLPart under the custom namespace
'part is created if missing!
'*******************************************************************************
Private Function GetRootXMLPart(ByVal book As Workbook) As CustomXMLPart
Const xmlDeclaration As String = "<?xml version=""1.0"" encoding=""UTF-8""?>"
Const rootTag As String = "<" & rootName & " xmlns=""" & XML_NAMESPACE _
& """></" & rootName & ">"
Const rootXmlPart As String = xmlDeclaration & rootTag
'
With book.CustomXMLParts.SelectByNamespace(XML_NAMESPACE)
If .Count = 0 Then
Set GetRootXMLPart = book.CustomXMLParts.Add(rootXmlPart)
Else
Set GetRootXMLPart = .Item(1)
End If
End With
End Function
'*******************************************************************************
'Clears all CustomXMLParts under the custom namespace
'*******************************************************************************
Private Sub ClearRootXMLParts(ByVal book As Workbook)
With book.CustomXMLParts.SelectByNamespace(XML_NAMESPACE)
Dim i As Long
For i = .Count To 1 Step -1
.Item(i).Delete
Next i
End With
End Sub
'*******************************************************************************
'Get the Root Node under the custom namespace
'Node is created if missing!
'*******************************************************************************
Private Function GetRootNode(ByVal book As Workbook) As CustomXMLNode
Dim root As CustomXMLNode
If root Is Nothing Then
With GetRootXMLPart(book)
Dim nsPrefix As String
nsPrefix = .NamespaceManager.LookupPrefix(XML_NAMESPACE)
Set root = .SelectSingleNode("/" & nsPrefix & ":" & rootName & "[1]")
End With
End If
Set GetRootNode = root
End Function
'*******************************************************************************
'Get an XML Node. Create it if missing
'*******************************************************************************
Private Function GetNode(ByVal book As Workbook _
, ByVal nodeName As String _
, ByVal addIfMIssing As Boolean) As CustomXMLNode
Dim node As CustomXMLNode
Dim expr As String
'
With GetRootNode(book)
expr = .XPath & "/" & nodeName & "[1]"
Set node = .SelectSingleNode(expr)
If node Is Nothing And addIfMIssing Then
.AppendChildNode nodeName
Set node = .SelectSingleNode(expr)
End If
End With
Set GetNode = node
End Function
'*******************************************************************************
'Retrieves/sets a book property value from a CustomXMLNode
'*******************************************************************************
Public Property Get BookItem(ByVal book As Workbook _
, ByVal itemName As String) As String
ThrowIfInvalid book, itemName
Dim node As CustomXMLNode
Set node = GetNode(book, itemName, False)
If Not node Is Nothing Then BookItem = node.Text
End Property
Public Property Let BookItem(ByVal book As Workbook _
, ByVal itemName As String _
, ByVal itemValue As String)
ThrowIfInvalid book, itemName
If LenB(itemValue) = 0 Then
Dim node As CustomXMLNode
Set node = GetNode(book, itemName, False)
If Not node Is Nothing Then node.Delete
Else
GetNode(book, itemName, True).Text = itemValue
End If
End Property
Private Sub ThrowIfInvalid(ByRef book As Workbook, ByRef itemName As String)
Const methodName As String = "BookItem"
If book Is Nothing Then
Err.Raise 91, methodName, "Book not set"
ElseIf LenB(itemName) = 0 Then
Err.Raise 5, methodName, "Invalid item name"
End If
End Sub
'*******************************************************************************
'Returns a collection of custom node names within the custom namespace
'*******************************************************************************
Public Function GetBookItemNames(ByVal book As Workbook) As Collection
If book Is Nothing Then Err.Raise 91, "GetBookItemNames", "Book not set"
'
Dim coll As New Collection
With GetRootNode(book).ChildNodes
Dim i As Long
ReDim arr(0 To .Count - 1)
For i = 1 To .Count
coll.Add .Item(i).BaseName
Next i
End With
Set GetBookItemNames = coll
End Function
Example call:
BookItem(ThisWorkbook, "myVar") = myTextValue
Debug.Print BookItem(ThisWorkbook, "myVar")
Now that we have a way to store data in a persistant way, let's make sure we can recover the ribbon in case of a state loss. Replace this:
Option Explicit
Public myRibbon As IRibbonUI
Public pressed As Boolean
----------------------------------------------------------------------------------
Sub OnRibbonLoad(ribbon As IRibbonUI)
Set myRibbon = ribbon
End Sub
with this:
Option Explicit
Private myRibbon As IRibbonUI
#If Mac Then
#If VBA7 Then
Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
#Else
Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
#End If
#Else 'Windows
'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If
#End If
Sub OnRibbonLoad(ByVal ribbon As IRibbonUI)
Set SafeRibbon = ribbon
End Sub
'===============================================================================
'Set/Get Ribbon object
'===============================================================================
Private Property Set SafeRibbon(ByVal ribbonUI As IRibbonUI)
Set myRibbon = ribbonUI
Dim mustAvoidSaveDialog As Boolean
mustAvoidSaveDialog = ThisWorkbook.IsAddin And ThisWorkbook.Saved
BookItem(ThisWorkbook, "BookPtr") = CStr(ObjPtr(ThisWorkbook))
BookItem(ThisWorkbook, "RibbonPtr") = CStr(ObjPtr(myRibbon))
If mustAvoidSaveDialog Then ThisWorkbook.Saved = True
End Property
Public Property Get SafeRibbon() As IRibbonUI
If myRibbon Is Nothing Then
If BookItem(ThisWorkbook, "BookPtr") = CStr(ObjPtr(ThisWorkbook)) Then
'Restore ribbon
#If Win64 Then
Dim ptr As LongLong
Const ptrSize As Long = 8
#Else
Dim ptr As Long
Const ptrSize As Long = 4
#End If
Dim obj As Object
'
ptr = Int(BookItem(ThisWorkbook, "RibbonPtr"))
CopyMemory obj, ptr, ptrSize 'Unmanaged - reference not counted
Set myRibbon = obj
CopyMemory obj, 0, ptrSize 'Reference count not decremented
End If
End If
Set SafeRibbon = myRibbon
End Property
Notice that myRibbon is now private and calls should only be made to the SafeRibbon parametric property.
Also notice I removed the pressed module member - we won't need it anymore.
When a macro is already running in a loop, we cannot simply call another macro. We must wait for the first one to exit. We can use asyncronous calls to achieve that.
Let's also use book item library to retrive the state of the last pressed button when an invalidation occurs:
Sub GetPressed(control As IRibbonControl, ByRef returnedVal)
Dim lastIDPressed As String
'
lastIDPressed = BookItem(ThisWorkbook, "lastIDPressed")
returnedVal = (lastIDPressed = control.ID)
If Len(lastIDPressed) > 0 Then AsyncMacro lastIDPressed
End Sub
Sub AnyButtonGotPressed(control As IRibbonControl, IsPressed)
If Not IsPressed Then
BookItem(ThisWorkbook, "lastIDPressed") = vbNullString
Exit Sub
End If
'
Dim lastIDPressed As String
'
lastIDPressed = BookItem(ThisWorkbook, "lastIDPressed")
If Len(lastIDPressed) > 0 Then
SafeRibbon.InvalidateControl lastIDPressed
End If
BookItem(ThisWorkbook, "lastIDPressed") = control.ID
If Not isMacroRunning Then AsyncMacro control.ID
End Sub
Private Sub AsyncMacro(ByVal ctrlID As String)
Application.OnTime Now(), CallbackName("AsyncMacroCallback", ctrlID)
End Sub
Private Function CallbackName(ByVal funcName As String, ByVal ctrlID As String) As String
CallbackName = "'" & Replace(ThisWorkbook.Name, "'", "''") _
& "'!'" & funcName & " """ & ctrlID & """'"
End Function
Public Sub AsyncMacroCallback(Optional ByVal ctrlID As String)
isMacroRunning = True
Select Case ctrlID
Case "customButton1": FirstMacro ctrlID
Case "customButton2": SecondMacro ctrlID
Case "customButton3": ThirdMacro ctrlID
Case Else
'...
End Select
SafeRibbon.InvalidateControl ctrlID
isMacroRunning = False
End Sub
Where Private isMacroRunning As Boolean is declared at module level.
The final code can look like this:
Option Explicit
Private myRibbon As IRibbonUI
Private isMacroRunning As Boolean
#If Mac Then
#If VBA7 Then
Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
#Else
Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
#End If
#Else 'Windows
'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If
#End If
Sub OnRibbonLoad(ByVal ribbon As IRibbonUI)
Set SafeRibbon = ribbon
End Sub
'===============================================================================
'Set/Get Ribbon object
'===============================================================================
Private Property Set SafeRibbon(ByVal ribbonUI As IRibbonUI)
Set myRibbon = ribbonUI
Dim mustAvoidSaveDialog As Boolean
mustAvoidSaveDialog = ThisWorkbook.IsAddin And ThisWorkbook.Saved
BookItem(ThisWorkbook, "BookPtr") = CStr(ObjPtr(ThisWorkbook))
BookItem(ThisWorkbook, "RibbonPtr") = CStr(ObjPtr(myRibbon))
If mustAvoidSaveDialog Then ThisWorkbook.Saved = True
End Property
Public Property Get SafeRibbon() As IRibbonUI
If myRibbon Is Nothing Then
If BookItem(ThisWorkbook, "BookPtr") = CStr(ObjPtr(ThisWorkbook)) Then
'Restore ribbon
#If Win64 Then
Dim ptr As LongLong
Const ptrSize As Long = 8
#Else
Dim ptr As Long
Const ptrSize As Long = 4
#End If
Dim obj As Object
'
ptr = Int(BookItem(ThisWorkbook, "RibbonPtr"))
CopyMemory obj, ptr, ptrSize 'Unmanaged - reference not counted
Set myRibbon = obj
CopyMemory obj, 0, ptrSize 'Reference count not decremented
End If
End If
Set SafeRibbon = myRibbon
End Property
Sub GetPressed(control As IRibbonControl, ByRef returnedVal)
Dim lastIDPressed As String
'
lastIDPressed = BookItem(ThisWorkbook, "lastIDPressed")
returnedVal = (lastIDPressed = control.ID)
If Len(lastIDPressed) > 0 Then AsyncMacro lastIDPressed
End Sub
Sub AnyButtonGotPressed(control As IRibbonControl, IsPressed)
If Not IsPressed Then
BookItem(ThisWorkbook, "lastIDPressed") = vbNullString
Exit Sub
End If
'
Dim lastIDPressed As String
'
lastIDPressed = BookItem(ThisWorkbook, "lastIDPressed")
If Len(lastIDPressed) > 0 Then
SafeRibbon.InvalidateControl lastIDPressed
End If
BookItem(ThisWorkbook, "lastIDPressed") = control.ID
If Not isMacroRunning Then AsyncMacro control.ID
End Sub
Private Sub AsyncMacro(ByVal ctrlID As String)
Application.OnTime Now(), CallbackName("AsyncMacroCallback", ctrlID)
End Sub
Private Function CallbackName(ByVal funcName As String, ByVal ctrlID As String) As String
CallbackName = "'" & Replace(ThisWorkbook.Name, "'", "''") _
& "'!'" & funcName & " """ & ctrlID & """'"
End Function
Public Sub AsyncMacroCallback(Optional ByVal ctrlID As String)
isMacroRunning = True
Select Case ctrlID
Case "customButton1": FirstMacro ctrlID
Case "customButton2": SecondMacro ctrlID
Case "customButton3": ThirdMacro ctrlID
Case Else
'...
End Select
SafeRibbon.InvalidateControl ctrlID
isMacroRunning = False
End Sub
Sub FirstMacro(ButtonName As String)
Debug.Print "Enter macro 1 " & Now
On Error GoTo CleanExit
Do While BookItem(ThisWorkbook, "lastIDPressed") = ButtonName
With ThisWorkbook.Sheets(1)
.Range("A1").Select
If ActiveCell.Address <> .Range("A1") Then
'Here comes stuff to do with the cell, if the user clicks somewhere out of "A1"
End If
DoEvents
End With
Loop
CleanExit:
Debug.Print "Exit macro 1 " & Now
End Sub
Sub SecondMacro(ButtonName As String)
Debug.Print "Enter macro 2 " & Now
On Error GoTo CleanExit
Do While BookItem(ThisWorkbook, "lastIDPressed") = ButtonName
With ThisWorkbook.Sheets(1)
.Range("B2").Select
If ActiveCell.Address <> .Range("B2") Then
'Here comes stuff to do with the cell, if the user clicks somewhere out of "B2"
End If
DoEvents
End With
Loop
CleanExit:
Debug.Print "Exit macro 2 " & Now
End Sub
Sub ThirdMacro(ButtonName As String)
Debug.Print "Enter macro 3 " & Now
On Error GoTo CleanExit
Do While BookItem(ThisWorkbook, "lastIDPressed") = ButtonName
With ThisWorkbook.Sheets(1)
.Range("C3").Select
If ActiveCell.Address <> .Range("C3") Then
'Here comes stuff to do with the cell, if the user clicks somewhere out of "C3"
End If
DoEvents
End With
Loop
CleanExit:
Debug.Print "Enter macro 3 " & Now
End Sub
Notice that none of the actual macros (First, Second, Third) need to do any more calls to InvalidateControl and we also don't need to loop through all controls in a loop to InvalidateControl in the AnyButtonGotPressed method.
