VBA - 填充自定义功能区下拉/列表框

Question

我无法填充下拉/列表框。

原始代码来自：

https://exceloffthegrid.com/inserting-a-dynamic-drop-down-in-ribbon/

如何使用 VBA 添加自定义功能区选项卡？

下面的 VBA 代码在一个模块中，而 XML 代码在第二个模块中。功能区在工作簿打开时创建。

我的代码：

VBA：

Option Explicit

'testRibbon is a variable which contains the Ribbon
Public testRibbon As IRibbonUI

Sub testRibbon_onLoad(ByVal ribbon As Office.IRibbonUI)

    Set testRibbon = ribbon

End Sub

Public Sub DropDown_getItemCount(control As IRibbonControl, ByRef returnedVal)

    Dim Workbook As Workbook
    Dim Worksheet As Worksheet
    Dim myCell As Range
    Dim LastColumn As Long

    Set logBook = Workbooks("Journal.xlsm")
    Set dataSheet = logBook.Worksheets("Data Sheet")
    Set myCell = dataSheet.Range("B3")

    ColumnNumber = myCell.End(xlToRight).Column

    'Convert To Column Letter
    ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)

    Set myCell = dataSheet.Range("B3:" & ColumnLetter & "3")

    returnedVal = 0

    For x = 1 To myCell.Columns.Count

        card1 = myCell.Cells(1, x).Value

        If card1 <> "" And Len(card1 & vbNullString) > 0 Then

            returnedVal = returnedVal + 1

        End If

    Next x

End Sub

Public Sub DropDown_getItemID(control As IRibbonControl, index As Integer, ByRef id)

    id = "Base Currency: " & index

End Sub

Public Sub DropDown_getItemLabel(control As IRibbonControl, index As Integer, ByRef returnedVal)

    Dim Workbook As Workbook
    Dim Worksheet As Worksheet
    Dim myCell As Range

    Set logBook = Workbooks("Journal.xlsm")
    Set dataSheet = logBook.Worksheets("Data Sheet")
    Set myCell = dataSheet.Range("B3")

    returnedVal = myCell.Value

End Sub

Public Sub DropDown_getSelectedItemID(control As IRibbonControl, ByRef id)

    id = "--SELECT--"

End Sub

Sub updateRibbon()

    testRibbon.Invalidate

End Sub

XML：

Sub LoadCustRibbon()

    Dim hFile As Long
    Dim path As String, fileName As String, ribbonXML As String, user As String

    hFile = FreeFile
    user = Environ("Username")
    path = "C:\Users\" & user & "\AppData\Local\Microsoft\Office\"
    fileName = "Excel.officeUI"

    ribbonXML = "               <mso:customUI      xmlns:mso='http://schemas.microsoft.com/office/2009/07/customui'>" & vbNewLine
    ribbonXML = ribbonXML + "       <mso:ribbon>" & vbNewLine
    ribbonXML = ribbonXML + "           <mso:qat/>" & vbNewLine
    ribbonXML = ribbonXML + "               <mso:tabs>" & vbNewLine

    'Group 1
    ribbonXML = ribbonXML + "                   <mso:tab id='myTab' label='Tab1' insertBeforeQ='mso:TabFormat'>" & vbNewLine

    ribbonXML = ribbonXML + "                       <mso:group id='sendSubmit' label='Submit' autoScale='true'>" & vbNewLine

                                                        'Drop Down
    ribbonXML = ribbonXML + "                           <mso:dropDown   id='DropDown' label='myList' " & vbNewLine
    ribbonXML = ribbonXML + "                               onAction='DropDown_onAction' " & vbNewLine
    ribbonXML = ribbonXML + "                               getSelectedItemID='DropDown_getSelectedItemID' " & vbNewLine
    ribbonXML = ribbonXML + "                               getItemLabel='DropDown_getItemLabel' " & vbNewLine
    ribbonXML = ribbonXML + "                               getItemID='DropDown_getItemID' " & vbNewLine
    ribbonXML = ribbonXML + "                               getItemCount='DropDown_getItemCount'" & vbNewLine
    ribbonXML = ribbonXML + "                           />" & vbNewLine

    ribbonXML = ribbonXML + "                       </mso:group>" & vbNewLine
    ribbonXML = ribbonXML + "                   </mso:tab>" & vbNewLine
    ribbonXML = ribbonXML + "               </mso:tabs>" & vbNewLine
    ribbonXML = ribbonXML + "           </mso:ribbon>" & vbNewLine
    ribbonXML = ribbonXML + "   </mso:customUI>"

    ribbonXML = Replace(ribbonXML, """", "")

    Open path & fileName For Output Access Write As hFile
    Print #hFile, ribbonXML
    Close hFile

End Sub

我已经完全按照教程中的方式复制了代码，但我无法填充下拉框 - 即使我按照他们对工作簿中的工作表的建议进行操作。

希望有人能帮忙，这让我发疯。：/

Answer 1

设法找到了一个教程，解释了我试图实现的正确用法。

关联：

https://www.contextures.com/excelribbonmacrostab.html

链接中的信息要点：

1. 下载适用于 Microsoft Office 的自定义 UI 编辑器
2. 打开要添加自定义的 Excel 文件 - 使用自定义 UI 编辑器
3. 在编辑器中加载文件后，右键单击该文件，然后选择您首选的 Office 兼容性以进行其他更改（2010 选项适用于 Office 2010 - 当前）
4. 将创建一个 XML“文件”并将其链接到编辑器内的原始 excel 文件
5. 将您的 XML 代码插入编辑器
6. 通过单击编辑器任务栏中的“验证”按钮进行代码检查
7. 单击“生成回调”按钮，这将创建VBA 中所需的子项以传递参数或识别 XML 上的元素（在自定义选项卡中） - 将回调复制到记事本
8. 如果一切看起来不错并且验证不会抛出任何错误，保存更改并打开您的 excel 文件 - 现在应该有自定义
9. 将回调粘贴到 VBA 中的模块中，用于自定义的 excel 文件

2010 年及以后的 XML 代码示例：

代码：

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
    <ribbon startFromScratch="false">
        <tabs>
            <tab id="myLogTab" label="Logbook">

                <group id="setup" label="Setup">

                    <button 
                        id="btnSubmit" 
                        label="Submit" 
                        imageMso="GoTo" 
                        size="large" 
                        onAction="Submit" 
                    />

                    <dropDown   
                        id="ddlBase"
                        label="Base"
                        getItemCount="DropDown_getItemCount"
                        getItemLabel="DropDown_getItemLabel"
                        getSelectedItemIndex="GetSelItemIndex"
                        onAction="DropDown_onAction"

                    />

                    <editBox 
                        id="txtEntry"
                        label="Entry"
                        getText="MyEditBoxCallbackgetText"
                        onChange="MyEditBoxCallbackOnChange"
                    />

                </group>

                <group id="logSummary" label="Summary">

                    <labelControl 
                        id="lblTotal" 
                        label="Total" 
                    />

                </group>

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

VBA 示例：

代码：

Option Explicit
'https://www.contextures.com/excelribbondynamictab.html
Public myRibbon As IRibbonUI

Sub Onload(ribbon As IRibbonUI)

    'Create a ribbon instance for use in this project
    Set myRibbon = ribbon

End Sub

'Callback for ddlBase getItemCount
Sub DropDown_getItemCount(control As IRibbonControl, ByRef count)

End Sub

'Callback for ddlBase getItemLabel
Sub DropDown_getItemLabel(control As IRibbonControl, Index As Integer, ByRef label)

End Sub

'Callback for ddlBase getSelectedItemIndex
Sub GetSelItemIndex(control As IRibbonControl, ByRef Index)

End Sub

'Callback for ddlBase onAction
Sub DropDown_onAction(control As IRibbonControl, id As String, Index As Integer)

End Sub

'Callback for txtEntry getText
Sub MyEditBoxCallbackgetText(control As IRibbonControl, ByRef returnedVal)

End Sub

'Callback for txtEntry onChange
Sub MyEditBoxCallbackOnChange(control As IRibbonControl, text As String)

End Sub