如何计算和显示Excel加载项面板此加载项中包含的所有宏的总使用次数

时间：2017-05-03 02:19:05

标签： excel vba excel-vba

对不起。与谷歌翻译翻译！
链接到程序开发人员的网站，我用它创建了Excel加载项文件！这个节目是免费的！ [http://novikov.gq/products/ribbonxmleditor/ribbonxmleditor.html][1]

初始数据：我们有Excel程序的加载项！该加载项包含两个与“加载项”面板上的按钮关联的宏。

任务：总结按钮上的所有按键。 “加载项”面板中显示的点击量。重启后不应重置该金额。

我无法解决的错误：
1）如果选择否（按按钮2），则重置点击量 2）每次启动Excel时，点击量加+1，这是不正确的。

XML代码：

<?xml version="1.0" standalone="yes"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="Init_RibVar_Custom">
    <ribbon startFromScratch="false">
        <tabs>
            <tab id="excel-vba" label="Test">
                <group id="groupe_1" label=" Редактирование">
                    <button id="button_1" imageMso="GoLtrDown" label="Button 1" onAction="macro1" />
                    <button id="button_2" imageMso="GoLtrDown" label="Button 2" onAction="macro2" />
                </group>

                <group id="groupe_2" label="Counter">
                    <labelControl id="Counter" getLabel="getLabel_Cnt" />
                </group>

            </tab>
        </tabs>
    </ribbon>
</customUI>

主要代码：

Option Explicit
#If VBA7 Then
Public Declare PtrSafe Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (ByRef destination As Any, ByRef Source As Any, ByVal length As LongPtr)
#Else
Public Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (ByRef destination As Any, ByRef Source As Any, ByVal length As Long)
#End If

Public MyCounter As Long
Public objRibCustom As IRibbonUI
Public cntr As IRibbonControl

Sub CheckRibbon()
    If objRibCustom Is Nothing Then
#If VBA7 Then
        Dim lPointer As LongPtr
        lPointer = CLngPtr(ThisWorkbook.Sheets(1).Range("A1"))
#Else
        Dim lPointer As Long
        lPointer = CLng(ThisWorkbook.Sheets(1).Range("A1"))
#End If
        CopyMemory objRibCustom, lPointer, LenB(lPointer)
    End If
End Sub
Sub Init_RibVar_Custom(ribbon As IRibbonUI)
    Set objRibCustom = ribbon
    ThisWorkbook.Sheets(1).Range("A1") = ObjPtr(ribbon)
    objRibCustom.Invalidate
    Open "D:\Counter.txt" For Input As #1
    Input #1, MyCounter
    Close #1
    MyCounter = MyCounter + 1
    Call getLabel_Cnt(cntr, "")
    Open "D:\Counter.txt" For Output As #1
    Print #1, MyCounter
    Close #1
End Sub  
Sub getLabel_Cnt(control As IRibbonControl, ByRef label)
    Call CheckRibbon
    If cntr Is Nothing Then
        Set cntr = control
    End If
    label = "Counter: " & MyCounter
    On Error Resume Next
    objRibCustom.InvalidateControl control.ID
    objRibCustom.Invalidate
End Sub  
Sub macro1(control As IRibbonControl)
    MyCounter = MyCounter + 1
    Call getLabel_Cnt(cntr, "")
     MsgBox "First button", vbOKOnly
End Sub   
Sub macro2(control As IRibbonControl)
    MyCounter = MyCounter + 1
    Call getLabel_Cnt(cntr, "")
    If MsgBox("Second button ", vbYesNo) = vbYes Then
Else
    End
End If
End Sub

3 个答案:

答案 0 :(得分：1)

Public MyCounter As Long

该变量的值与执行上下文一起生存和死亡;这意味着当End运行时，该值消失了。因此，您需要一个可以处理文件存储的程序。现在你在Init_RibVar_Custom中有一些;将该文件处理问题转移到自己的过程中。哎呀，把整个反处理的东西搬进自己的班级！

Option Explicit

Private currentValue As Long

Private Sub Class_Initialize()
    LoadValue
End Sub

Public Property Get Value() As Long
    Value = currentValue
End Property

Public Sub Increment()
    currentValue = currentValue + 1
    SaveValue
End Sub

Public Sub LoadValue()
    'assign currentValue from file
End Sub

Public Sub SaveValue()
    'save currentValue to file
End Sub

现在将该类命名为CallCounter，然后将其命名为：

Private MyCounter As Long

你可以拥有：

Private counter As New CallCounter

现在，要保持正确计数，您只需在宏中调用counter.Increment：

Sub macro1(control As IRibbonControl)
    counter.Increment
    '...
End Sub

请注意，Increment会调用SaveValue，因此无论发生什么情况，都会将正确的值存储在文件中。

请确保LoadValue和SaveValue不要更改该值，并且您将始终拥有正确的计数。

答案 1 :(得分：0)

感谢David Zemens和Mat's Mug

问题编号1的解决方案：在整个代码中删除End运算符
问题2的解决方案：从过程Init_RibVar_Custom中删除MyCounter = MyCounter + 1行

Option Explicit
#If VBA7 Then
Public Declare PtrSafe Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (ByRef destination As Any, ByRef Source As Any, ByVal length As LongPtr)
#Else
Public Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (ByRef destination As Any, ByRef Source As Any, ByVal length As Long)
#End If

Public MyCounter As Long
Public objRibCustom As IRibbonUI
Public cntr As IRibbonControl

Sub CheckRibbon()
    If objRibCustom Is Nothing Then
#If VBA7 Then
        Dim lPointer As LongPtr
        lPointer = CLngPtr(ThisWorkbook.Sheets(1).Range("A1"))
#Else
        Dim lPointer As Long
        lPointer = CLng(ThisWorkbook.Sheets(1).Range("A1"))
#End If
        CopyMemory objRibCustom, lPointer, LenB(lPointer)
    End If
End Sub
Sub Init_RibVar_Custom(ribbon As IRibbonUI)
    Set objRibCustom = ribbon
    ThisWorkbook.Sheets(1).Range("A1") = ObjPtr(ribbon)
    objRibCustom.Invalidate
    Open "D:\Counter.txt" For Input As #1
    Input #1, MyCounter
    Close #1
    Call getLabel_Cnt(cntr, "")
    Open "D:\Counter.txt" For Output As #1
    Print #1, MyCounter
    Close #1
End Sub  
Sub getLabel_Cnt(control As IRibbonControl, ByRef label)
    Call CheckRibbon
    If cntr Is Nothing Then
        Set cntr = control
    End If
    label = "Counter: " & MyCounter
    On Error Resume Next
    objRibCustom.InvalidateControl control.ID
    objRibCustom.Invalidate
End Sub  

Sub macro1(control As IRibbonControl)
Open "D:\Counter.txt" For Input As #1
Input #1, MyCounter
Close #1
MyCounter = MyCounter + 1
Call getLabel_Cnt(cntr, "")
     MsgBox "First button", vbOKOnly
Open "D:\Counter.txt" For Output As #1
Print #1, MyCounter
Close #1
End Sub  

Sub macro2(control As IRibbonControl)
Open "D:\Counter.txt" For Input As #1
Input #1, MyCounter
Close #1
MyCounter = MyCounter + 1
Call getLabel_Cnt(cntr, "")
    If MsgBox("Second button ", vbYesNo) = vbYes Then
Else  
End If
Open "D:\Counter.txt" For Output As #1
Print #1, MyCounter
Close #1
End Sub

答案 2 :(得分：0)

解决方案非常简单：使用隐藏名称。此隐藏名称保留在工作簿中。要创建隐藏名称（以及重新初始化计数器），请运行以下过程：

Sub CreateHiddenName()
    ThisWorkbook.Names.Add Name:="ClicksCounter", RefersTo:=0, Visible:=False
End Sub

隐藏名称安全地保存在/xl/workbook.xml中：

<definedNames>
    <definedName name="ClicksCounter" hidden="1">0</definedName>
</definedNames>

我使用的测试工作簿有以下XML用于功能区：

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="OnRibbonLoaded">
    <ribbon>
        <tabs>
            <tab id="rxTab1" label="MY_TAB">
            <group id="rxGroup1" label="Group1">
                <button id="rxButton1"
                        label="I am humble button"
                        imageMso="QueryAppend"
                        onAction="OnHumbleButtonClick" />
            <labelControl id="rxLabel1"
                          getLabel="OnGetCounter" />
            </group>
        </tab>
        </tabs>
    </ribbon>
</customUI>

VBA代码（标准模块中）：

Private ribbon As IRibbonUI

Sub OnRibbonLoaded(IRibbon As IRibbonUI)
    Set ribbon = IRibbon
End Sub

Sub OnGetCounter(ctrl As IRibbonControl, returnValue)
    returnValue = "Counter: " & GetCounterValue()
End Sub

Sub OnHumbleButtonClick(ctrl As IRibbonControl)
    ' Do something here...
    ' In the end call:
    Call IncrCounter
End Sub

Sub IncrCounter()
    ThisWorkbook.Names("ClicksCounter").Value = GetCounterValue() + 1
    ribbon.InvalidateControl "rxLabel1"
End Sub

Function GetCounterValue()
    GetCounterValue = Replace(ThisWorkbook.Names("ClicksCounter").Value, "=", "")
End Function

这里有什么步骤：

1）当工作簿启动时，会调用 OnRibbonLoaded ，其唯一目的是保留 IRibbonUI 变量。

2）当你按下“简单”按钮时， OnHumbleButtonClick 回调就会运行。

4） OnHumbleButtonClick 运行 IncrCounter 程序：

4.1）递增计数器;

4.2）使 labelControl 无效以反映新的计数器值（无效使 OnGetCounter 运行以获取 labelControl 的新标签）。

作为旁注，如果您使用它，最好添加可以恢复Ribbon变量地址的代码。以下是代码的必要补充：

1）创建隐藏名称以保留地址：

Sub AddNameForRibbonPointer()
    ThisWorkbook.Names.Add Name:="RibbonPointer", RefersTo:=0, Visible:=False
End Sub

2）声明恢复地址的Win32 RtlMoveMemory 函数：

#If VBA7 Then
Public Declare PtrSafe Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (ByRef destination As Any, ByRef Source As Any, ByVal length As LongPtr)
#Else
Public Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (ByRef destination As Any, ByRef Source As Any, ByVal length As Long)
#End If

3）添加一行，将功能区的地址保留为隐藏名称：

Sub OnRibbonLoaded(IRibbon As IRibbonUI)
    Set ribbon = IRibbon
    ThisWorkbook.Names("RibbonPointer").Value = ObjPtr(ribbon)
End Sub

4）帮助程序检查功能区变量是否为空。如果是，则它将从隐藏名称恢复地址：

Sub CheckRibbon()
     
    If ribbon Is Nothing Then
#If VBA7 Then
        Dim lPointer As LongPtr
        lPointer = CLngPtr([RibbonPointer])
#Else
        Dim lPointer As Long
        lPointer = CLng([RibbonPointer])
#End If
        CopyMemory ribbon, lPointer, LenB(lPointer)
    End If
 
End Sub

从现在开始，您只需在使用功能区变量之前调用 CheckRibbon 程序：

Sub MyProcedure
    ' Doing something...
    Call CheckRibbon
    ribbon.Invalidate
End Sub

UPD：

要与工作簿保持一致，您需要保存工作簿。对于通常的工作簿，您可以手动保存它，也可以在关闭工作簿时自动保存。对于加载项，您必须自动执行此操作，因为关闭Excel时不会保存任何更改。对于自动保存，您需要使用Workbook的BeforeClose事件。转到ThisWorkbook模块并粘贴此代码：

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ThisWorkbook.Save
End Sub
相关问题
最新问题