Office Ribbon下拉列表项自定义图标实现问题

问题场景 #

我有一个带有自定义Office Ribbon的Excel文件，功能区包含一个dropDown列表，想要给列表中的每个项显示图标，但目前仅能通过LoadPicture从本地文件加载图标。现有的customUI14.xml配置如下：

<dropDown id="Test"  
    label = "Test dropDown:"
    onAction="Test_OnAction" 
    getItemCount="Test_OnGetItemCount"
    getItemID="Test_OnGetItemID"
    getItemLabel="Test_OnGetItemLabel"
    getItemImage="Test_OnGetItemImage"
    getSelectedItemIndex="Test_OnGetSelectedItemIndex"/> 

尝试直接返回图像ID或引用工作表Picture对象均无效，需要实现从customUI14.xml资源或工作表Pictures集合加载图标的方案。

解决方案一：从customUI14.xml的资源库加载图标 #

1. 修改customUI14.xml配置 #

先在customUI根节点下添加resources节点定义图像资源，确保图标文件已打包到Excel文件的自定义UI目录中（可通过Office Open XML工具将图标放入xl/customUI/Icons文件夹）：

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <resources>
    <images>
      <image id="img_Icon1" src="Icons/icon1.png" />
      <image id="img_Icon2" src="Icons/icon2.png" />
      <!-- 按需添加更多图像定义 -->
    </images>
  </resources>
  <ribbon>
    <!-- 保留原有功能区结构，包含目标dropDown -->
    <dropDown id="Test"  
        label = "Test dropDown:"
        onAction="Test_OnAction" 
        getItemCount="Test_OnGetItemCount"
        getItemID="Test_OnGetItemID"
        getItemLabel="Test_OnGetItemLabel"
        getItemImage="Test_OnGetItemImage"
        getSelectedItemIndex="Test_OnGetSelectedItemIndex"/> 
  </ribbon>
</customUI>

2. 编写VBA回调函数 #

在Test_OnGetItemImage中直接返回customUI里定义的图像ID字符串即可：

Sub Test_OnGetItemImage(control As IRibbonControl, index As Integer, ByRef returnedVal)
    ' 根据下拉项索引映射对应的图像ID
    Select Case index
        Case 0
            returnedVal = "img_Icon1"
        Case 1
            returnedVal = "img_Icon2"
        ' 扩展更多项的图像映射
    End Select
End Sub

解决方案二：从工作表Pictures集合加载图标 #

工作表中的Picture对象与LoadPicture返回的StdPicture对象类型不同，需要通过API转换后才能被Ribbon识别。

1. 声明API与结构 #

在VBA模块顶部添加以下声明（适配32/64位Office）：

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
    ByRef picdesc As PICTDESC, _
    ByRef riid As GUID, _
    ByVal fOwn As Long, _
    ByRef ppvObj As Any) As Long

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PICTDESC
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
End Type

Private Const PICTYPE_BITMAP As Long = 1
Private Const IID_IPicture As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

2. 编写转换函数 #

实现将工作表Picture转换为StdPicture的函数：

Private Function PictureToStdPicture(pic As Picture) As StdPicture
    Dim picdesc As PICTDESC
    Dim iid As GUID
    Dim ppvObj As StdPicture
    
    ' 初始化IPicture接口的GUID
    With iid
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    
    ' 填充图像描述结构
    With picdesc
        .Size = Len(picdesc)
        .Type = PICTYPE_BITMAP
        .hPic = pic.Handle
        .hPal = pic.hPal
    End With
    
    ' 创建StdPicture对象并返回
    OleCreatePictureIndirect picdesc, iid, True, ppvObj
    Set PictureToStdPicture = ppvObj
End Function

3. 修改回调函数 #

在Test_OnGetItemImage中获取工作表图片并转换后返回：

Sub Test_OnGetItemImage(control As IRibbonControl, index As Integer, ByRef returnedVal)
    Dim ws As Worksheet
    Dim targetPic As Picture
    
    Set ws = ThisWorkbook.Worksheets("Sheet1") ' 替换为你的目标工作表名称
    
    ' 根据索引匹配对应的工作表图片
    Select Case index
        Case 0
            Set targetPic = ws.Pictures("anyIcon") ' 替换为你的图片名称
        Case 1
            Set targetPic = ws.Pictures("anotherIcon")
        ' 扩展更多项的图片映射
    End Select
    
    ' 转换后返回给Ribbon
    If Not targetPic Is Nothing Then
        Set returnedVal = PictureToStdPicture(targetPic)
    End If
End Sub

内容的提问来源于stack exchange，提问作者blrun