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

Question

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

原始代码来自:

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

How to add a custom Ribbon tab using 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. 使用自定义 UI 编辑器打开要添加自定义项的 excel 文件
3. 在编辑器中加载文件后，右键单击该文件，然后选择您喜欢的 office 兼容性，以便在其中进行其他更改(2010 选项适用于 office 2010 - 当前)
4. 将在编辑器中创建一个 XML"file"并将其链接到您的原始 excel 文件
5. 将您的 XML 代码插入编辑器
6. 点击编辑器任务栏中的验证按钮进行代码检查
7. 点击 Generate Callbacks 按钮，这将创建 VBA 中需要的 sub 以传递参数或识别 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