英文:
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
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论