在(自定义右键菜单)中添加一个图标,Application.ShortcutMenus。

huangapple go评论57阅读模式
英文:

Add an icon to (custom right_click menu) , Application.ShortcutMenus

问题

我正在使用这段代码来将条目添加到Excel右键单击菜单中:

Private Sub Workbook_Open()
   Application.ShortcutMenus(xlWorksheetCell).MenuItems.Add "Open document", "OpenDocument", , 1, , ""
End Sub

Sub OpenDocument()
' 这里放置VBA代码
End Sub

我需要为这个条目添加一个图标(使用shell32.dll或任何独立的图像),因为现在它是空白的。

英文:

I am using this code to add an entry to excel right_click menu: <br>

Private Sub Workbook_Open()
   Application.ShortcutMenus(xlWorksheetCell).MenuItems.Add &quot;Open document&quot;, &quot;OpenDocument&quot;, , 1, , &quot;&quot;
End Sub

Sub OpenDocument()
‘vba code here
End Sub

I need to add an icon to this entry (using shell32.dl or any standalone image), as it is now blank. <br>

答案1

得分: 2

你的要求可以用不同的方法解决,但至少根据我所了解的方法之一,可以使用不同的方式(CommandBar)来处理:

  1. 要插入自定义图片,请尝试第一种方法。它使用来自特定路径的图片:
Sub AddItemContextMenuWithImage_1()
      Const butName As String = "打开文档"
      Const calledProc As String = "testSubX"
      
      deleteCellCustomControl butName
      
      Dim cmBar As CommandBar, ctrlButt As CommandBarButton, picPicture As IPictureDisp
      
      Set cmBar = Application.CommandBars("Cell")
      Set ctrlButt = cmBar.Controls.Add(Type:=msoControlButton, Before:=1) '创建为第一个菜单选项
      Set picPicture = stdole.StdFunctions.LoadPicture(ThisWorkbook.Path & "\test.gif") '接受的扩展名:bmp、jpg、gif
      
      With ctrlButt
        .Picture = picPicture
        .OnAction = calledProc
        .Caption = butName
    End With
End Sub

要检查它,示例Sub应该如下:

Sub testSubX()
  MsgBox "它有效..."
End Sub

当然,您可以根据需要调整代码来调用您自己/所需的Sub...

  1. 第二个版本使用/复制了已添加到ThisWorkbook特定工作表上的图片:
Sub AddItemContextMenuWithImage_2()
      Const butName As String = "打开文档"
      Const calledProc As String = "testSubX"
      
      deleteCellCustomControl butName
      
      Dim cmBar As CommandBar, ctrlButt As CommandBarButton
      
      Set cmBar = Application.CommandBars("Cell")
      Set ctrlButt = cmBar.Controls.Add(Type:=msoControlButton, Before:=1) '创建为第一个菜单选项
      ActiveSheet.Pictures("Picture 2").Copy '需要在活动工作表上有一个名为"Picture 2"的图片
        '可以将其复制为新添加的控制按钮的图像
      With ctrlButt
       .PasteFace '粘贴上面复制的图片
        .OnAction = calledProc
        .Caption = butName
    End With
End Sub
  1. 第三个版本使用已定义的标准FaceIDs。有很多可以使用的选项,很有可能可以找到适合您需求的选项,所以这是我更喜欢的版本:
Sub AddItemContextMenuWithImage_3()
      '这里是FaceID控件及其图像的列表:
      'https://bettersolutions.com/vba/ribbon/face-ids-2003.htm
      Const butName As String = "打开文档"
      Const calledProc As String = "testSubX"
      
      deleteCellCustomControl butName
      
      Dim cmBar As CommandBar, ctrlButt As CommandBarButton
      
      Set cmBar = Application.CommandBars("Cell")
      Set ctrlButt = cmBar.Controls.Add(Type:=msoControlButton, Before:=1) '创建为第一个菜单选项
      
      With ctrlButt
        .FaceId = 1661
        .OnAction = calledProc
        .Caption = butName
    End With
End Sub

可以在这里找到许多这样的FaceIDs。我还将链接作为注释放在Sub中,以供对这种方法感兴趣的人参考。

所有上述子程序首先调用下一个子程序,以预先删除菜单选项(如果它已经存在):

Sub deleteCellCustomControl(strBut As String)
    On Error Resume Next '防止尝试删除不存在的按钮时出错...
     Application.ShortcutMenus(xlWorksheetCell).MenuItems(strBut).Delete
    On Error GoTo 0
End Sub

如果上下文菜单中只有这样一个自定义选项,或者如果您想删除所有自定义选项,您可以使用以下方法简单地重置命令栏:

Private Sub ResetContextMenuBar()
   Application.CommandBars("Cell").Reset
End Sub
英文:

Your requirement can be solved in more ways, but (at least, this is what I know how to handle) using a different approach (CommandBar):

  1. To place a custom picture, please try the first version. It uses a picture from a specific path:
Sub AddItemContextMenuWithImage_1()
      Const butName As String = &quot;Open document&quot;
      Const calledProc As String = &quot;testSubX&quot;
      
      deleteCellCustomControl butName
      
      Dim cmBar As CommandBar, ctrlButt As CommandBarButton, picPicture As IPictureDisp
      
      Set cmBar = Application.CommandBars(&quot;Cell&quot;)
      Set ctrlButt = cmBar.Controls.Add(Type:=msoControlButton, Before:=1) &#39;create it to be the first menu option
      Set picPicture = stdole.StdFunctions.LoadPicture(ThisWorkbook.Path &amp; &quot;\test.gif&quot;) &#39;accepted extensions: bmp, jpg, gif
      
      With ctrlButt
        .Picture = picPicture
        .OnAction = calledProc
        .Caption = butName
    End With
End Sub

To check it, the demonstative Sub should look as:

Sub testSubX()
  MsgBox &quot;It works...&quot;
End Sub

Of course, you may adapt the code to call your own/necessary Sub...

  1. A second version uses/copies a picture already added on a specific sheet of ThisWorkbook:
Sub AddItemContextMenuWithImage_2()
      Const butName As String = &quot;Open document&quot;
      Const calledProc As String = &quot;testSubX&quot;
      
      deleteCellCustomControl butName
      
      Dim cmBar As CommandBar, ctrlButt As CommandBarButton
      
      Set cmBar = Application.CommandBars(&quot;Cell&quot;)
      Set ctrlButt = cmBar.Controls.Add(Type:=msoControlButton, Before:=1) &#39;create it to be the first menu option
      ActiveSheet.Pictures(&quot;Picture 2&quot;).Copy &#39;need to have a &quot;Picture 2&quot; picture on the active sheet
                                                                            &#39;you can copy it as image of the newly added control button
      With ctrlButt
       .PasteFace &#39;paste the above copied picture
        .OnAction = calledProc
        .Caption = butName
    End With
End Sub
  1. The third version uses standard, already defined FaceIDs. There are so many, that it is very probable to find something suitable for your need, so this is the version I prefer:
Sub AddItemContextMenuWithImage_3()
      &#39;Here the list of FaceID controls with their images:
      &#39;https://bettersolutions.com/vba/ribbon/face-ids-2003.htm
      Const butName As String = &quot;Open document&quot;
      Const calledProc As String = &quot;testSubX&quot;
      
      deleteCellCustomControl butName
      
      Dim cmBar As CommandBar, ctrlButt As CommandBarButton
      
      Set cmBar = Application.CommandBars(&quot;Cell&quot;)
      Set ctrlButt = cmBar.Controls.Add(Type:=msoControlButton, Before:=1) &#39;create it to be the first menu option
      
      With ctrlButt
        .FaceId = 1661
        .OnAction = calledProc
        .Caption = butName
    End With
End Sub

A lot of such FaceIDs can be found here. I also place the link as a comment inside the Sub, to remain there for people being interested in this approach...

All the above Subs firstly call the next Sub, to preliminarily delete the menu option, if it already exists:

Sub deleteCellCustomControl(strBut As String)
    On Error Resume Next &#39;for the case of not existing button to be deleted...
     Application.ShortcutMenus(xlWorksheetCell).MenuItems(strBut).Delete
    On Error GoTo 0
End Sub

If there is only such a custom option in the context menu, or if you want deleting all of them (the custom once), you can simple reset the command Bar, using:

Private Sub ResetContextMenuBar()
   Application.CommandBars(&quot;Cell&quot;).Reset
End Sub

huangapple
  • 本文由 发表于 2023年2月8日 15:44:31
  • 转载请务必保留本文链接:https://go.coder-hub.com/75382665.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定