英文:
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 "Open document", "OpenDocument", , 1, , ""
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)来处理:
- 要插入自定义图片,请尝试第一种方法。它使用来自特定路径的图片:
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...
- 第二个版本使用/复制了已添加到
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
- 第三个版本使用已定义的标准
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):
- 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 = "Open document"
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) 'create it to be the first menu option
Set picPicture = stdole.StdFunctions.LoadPicture(ThisWorkbook.Path & "\test.gif") '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 "It works..."
End Sub
Of course, you may adapt the code to call your own/necessary Sub...
- A second version uses/copies a picture already added on a specific sheet of
ThisWorkbook:
Sub AddItemContextMenuWithImage_2()
Const butName As String = "Open document"
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) 'create it to be the first menu option
ActiveSheet.Pictures("Picture 2").Copy 'need to have a "Picture 2" picture on the active sheet
'you can copy it as image of the newly added control button
With ctrlButt
.PasteFace 'paste the above copied picture
.OnAction = calledProc
.Caption = butName
End With
End Sub
- 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()
'Here the list of FaceID controls with their images:
'https://bettersolutions.com/vba/ribbon/face-ids-2003.htm
Const butName As String = "Open document"
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) '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 '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("Cell").Reset
End Sub
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。


评论