首先，我们需要一种在工作簿中存储数据的方法。您可以使用命名范围或其他内容，但我将使用我的库 LibExcelBookItems，因为它非常易于使用。
LibExcelBookItems'''=============================================================================
''' 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
调用示例：
BookItem(ThisWorkbook, "myVar") = myTextValue
Debug.Print BookItem(ThisWorkbook, "myVar")
现在我们有了一种持久存储数据的方法，让我们确保在状态丢失的情况下可以恢复功能区。替换这个：
Option Explicit
Public myRibbon As IRibbonUI
Public pressed As Boolean
----------------------------------------------------------------------------------
Sub OnRibbonLoad(ribbon As IRibbonUI)
Set myRibbon = ribbon
End Sub
这样：
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
请注意，
myRibbonSafeRibbonpressed当一个宏已经在循环中运行时，我们不能简单地调用另一个宏。我们必须等待第一个退出。我们可以使用异步调用来实现这一点。
我们还可以使用图书项目库来检索发生失效时最后按下的按钮的状态：
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
'
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
BookItem(ThisWorkbook, ctrlID) = CStr(False)
SafeRibbon.InvalidateControl ctrlID
isMacroRunning = False
End Sub
其中
Private isMacroRunning As Boolean最终代码可能如下所示：
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
'
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
BookItem(ThisWorkbook, ctrlID) = CStr(False)
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
请注意，实际的宏（第一、第二、第三）都不需要对
InvalidateControlInvalidateControlAnyButtonGotPressed