VBA-填充自定义功能区下拉列表框 [英] VBA - Populate Custom Ribbon Drop Down/List Box

问题描述

我无法填充下拉列表框.

I cannot get the drop down/list box to populate.

原始代码来自:

https://exceloffthegrid.com/inserting-a-动态下拉功能区/

如何使用VBA添加自定义功能区标签?

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

Below code for VBA is in one module and the XML code in a second module. The ribbon is created as the workbook opens.

我的代码:

VBA:

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:

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

我已完全按照本教程中的说明复制了代码，但我只是无法填写下拉框-即使我按照工作簿中的工作表的建议进行操作也是如此.

I have copied the code exactly as in the tutorial but I just cannot get the drop box to populate - even when I do it as they suggest with the sheets in the workbook.

希望有人可以提供帮助，这使我发疯. :/

Hope someone can help, this is driving me crazy. :/

推荐答案

设法找到一个教程，该教程解释了我正在尝试实现的目标的正确用法.

Managed to find a tutorial that explains the correct usage of what I was trying to achieve.

链接:

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

链接中信息的突出显示:

Highlights of the information in the link:

1. 下载用于Microsoft Office的自定义UI编辑器
2. 使用自定义UI编辑器"打开您要添加自定义设置的excel文件
3. 加载到编辑器中后，右键单击该文件，然后选择所需的Office兼容性以使其他更改生效(2010选项适用于Office 2010-当前)
4. 将在编辑器内创建XML文件"并将其链接到原始excel文件
5. 将XML代码插入编辑器
6. 通过单击编辑器任务栏中的验证按钮进行代码检查
7. 点击生成回调按钮，该按钮将创建VBA中所需的子，以传递参数或标识XML上的元素(在自定义"标签中)-复制回调记事本
8. 提供的一切看起来不错，并且验证不会引发任何错误，保存更改并打开excel文件-现在应该在其中包含自定义内容
9. 使用自定义功能将回叫粘贴到VBA中的excel文件模块中

1. Download Custom UI Editor for Microsoft Office
2. Open the excel file you want to add the customizations to - using the Custom UI Editor
3. Right click on the file once loaded in the editor and choose your preferred office compatibility for the additional changes to work in (The 2010 option works for office 2010 - current)
4. An XML "file" will be created and linked to your original excel file WITHIN the editor
5. Insert your XML code into the editor
6. Do a code check by clicking on the Validate button in the task bar of the editor
7. Click the Generate Callbacks button which will create the sub's needed in VBA to pass parameters or identify elements on the XML (in the custom tab) - Copy the call backs to notepad
8. Provided everything looks good and the validation does not throw any errors, save the changes and open your excel file - which should now have the customizations in it
9. Paste the call backs in a module in VBA for the excel file with customizations

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

Example of XML Code for 2010 and Up:

代码:

Code:

<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示例:

代码:

Code:

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

这篇关于VBA-填充自定义功能区下拉列表框的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！