[求助]自定义菜单工具栏加载ImageList储藏的图标

zbs112

在UserForm1里，ImageList里储藏着待加载的4个自定义图标（不是系统的FaceId图标），如何加载到自定义的菜单工具栏上？

MyPopup.Controls.Add(Type:=msoControlButton).Button.FaceId = 1023
MyBars.Controls.Add(Type:=msoControlButton) .FaceId =1023

此2句的代码要如何修改？

Sub Menu_Currency()   '个性化菜单设置
  On Error Resume Next
  Dim Popup(5)  '建立新菜单（附加于默认菜单上）
  Dim Button As CommandBarControl
  Set Popup(0) = Application.CommandBars("Worksheet Menu Bar")
      Popup(0).Visible = True
     
  Popup(1).ImageList = ImageList1 '连接图标
  Popup(1).TextAlignment = tbrTextAlignBooton '图标显示方式

  Set Popup(1) = Popup(0).Controls.Add(Type:=msoControlPopup)
      Popup(1).Caption = "【记账凭证】 (&R)"
      Call MyButton(Popup(1), "凭证保存", 1023, "CreatePZ", True)
      Call MyButton(Popup(1), "凭证查询", 172, "FindPZ", True)
      Call MyButton(Popup(1), "凭证修改", 1020, "ReworkPZ", True)
      Call MyButton(Popup(1), "凭证删除", 644, "DeletePZ", True)
      Popup(1).BeginGroup = True

End Sub

Sub MyButton(MyPopup, Caption As String, FaceId As Integer, OnAction As String, BeginGroup As String)
  Set Button = MyPopup.Controls.Add(Type:=msoControlButton)
      Button.Caption = Space(5) & Caption
      Button.FaceId = FaceId
      Button.OnAction = OnAction
      Button.BeginGroup = BeginGroup
End Sub

Sub MyToolSet()      '自定义工具栏模块
  On Error Resume Next
  Dim MyBar As CommandBar
  Dim BarCoB As CommandBarComboBox
  Application.CommandBars("ZBSMenu").Delete
  Set MyBar = Application.CommandBars.Add("ZBSMenu", , False, True)
      MyBar.Position = msoBarTop
      MyBar.Protection = msoBarNoMove
      MyBar.Visible = True
      Call ZDYTool(MyBar, 1023, "保存", "CreatePZ", True, msoButtonIconAndCaption)
      Call ZDYTool(MyBar, 172, "查询", "FindPZ", True, msoButtonIconAndCaption)
      Call ZDYTool(MyBar, 1020, "修改", "ReworkPZ", True, msoButtonIconAndCaption)
      Call ZDYTool(MyBar, 644, "删除", "DeletePZ", True, msoButtonIconAndCaption)
      Call ZDYTool(MyBar, 601, "清空", "ClearPZ", True, msoButtonIconAndCaption)
  Set MyBar = Nothing
End Sub

Sub ZDYTool(MyBars, FaceId As Integer, Caption As String, OnAction As String, BeginGroup As Boolean, Style As Long)
   With MyBars.Controls.Add(Type:=msoControlButton)
      .FaceId = FaceId
      .Caption = Caption
      .OnAction = OnAction
      .BeginGroup = BeginGroup
      .Style = Style
   End With
End Sub

xIfwCJoe.rar (11.73 KB, 下载次数: 198)

2007-7-28 15:39 上传

点击文件名下载附件
[求助]自定义菜单工具栏加载ImageList图标

[此贴子已经被作者于2007-7-28 15:43:18编辑过]

zbs112

MyPopup.Controls.Add(Type:=msoControlButton).Button.FaceId = 1023
MyBars.Controls.Add(Type:=msoControlButton) .FaceId =1023

此2句的代码要如何修改？

zbs112

Application.CommandBars("....").Controls(i).PasteFace

这一句不知道是怎么加进，还请版主修改1楼的自定工具栏和菜单，谢谢

yxy博

还是现成的好!

zbs112

Sub MyButton(MyPopup, Caption As String, FaceId As Integer, OnAction As String, BeginGroup As String)
  Set Button = MyPopup.Controls.Add(Type:=msoControlButton)
      Button.Caption = Space(5) & Caption
      Button.FaceId = FaceId
      Button.OnAction = OnAction
      Button.BeginGroup = BeginGroup
End Sub

Sub ZDYTool(MyBars, FaceId As Integer, Caption As String, OnAction As String, BeginGroup As Boolean, Style As Long)
   With MyBars.Controls.Add(Type:=msoControlButton)
      .FaceId = FaceId
      .Caption = Caption
      .OnAction = OnAction
      .BeginGroup = BeginGroup
      .Style = Style
   End With
End Sub

是在这里加的吗？我晕了，帮我修改一下。

自定义的图标丰富些，所以喜欢尝试一下。

qee用

传个例子,参考一下:

基本方法是辅助一IMAGE对象

(1)读图到Image1

Image1.Picture = ImageList1.ListImages(i).ExtractIcon

或Image1.Picture = ImageList1.ListImages(i).Picture

(2)复制图像

Image1.Copy

(3)粘贴图像到工具(菜单)项

Application.CommandBars("....").Controls(i).PasteFace

qee用

QUOTE:

以下是引用yxy博在2007-7-31 13:41:02的发言：
还是现成的好!

深切同感.

也许是懒人自慰,自定义菜单的图标本身就有很多限制,只能是BMP格式,大小也要合适,在VBA下实现起来还要反复调试...

真的不划算.

qee用

QUOTE:

以下是引用zbs112在2007-7-31 11:35:49的发言：

Application.CommandBars("....").Controls(i).PasteFace

这一句不知道是怎么加进，还请版主修改1楼的自定工具栏和菜单，谢谢

省略号部分就是菜单或工具栏的名子

附件例子进入设计状态就可以看到Imagelist控件

xgy0214dxy

下载学习，谢谢

xgy0214dxy

2010里提示运行不了呀