Icon

[Robin Clay]

Greetings !

I have written some code (with a GREAT deal of much-
appreciated help from you guys !) to place a menu onto the
Command Bar.

I have attached some of the standard Icons to some menu
items, using e.g.
.Style = msoButtonIconAndCaption
.FaceId = 17

but I would like to create my own icons to go on other
menu items.

This requires
- code to actually create an icon
- code to identify each icon so created, and
- code to attach one such icon to a particular menu item

Please can SKS provide some samples of such coding ?


RClay AT haswell DOT com

 

[Colo]

Hello Robin,

Please place Auto shpas or bitmaps in the sheet1 before run this code.

'---------------------------------------------------------------------------
-----

Sub CreateToolbarMenu()
Dim lngCnt As Long, shp As Shape, sh As Worksheet
On Error Resume Next
Application.CommandBars("newToolbar").Delete
On Error GoTo 0
Set sh = Sheets(1) 'Change here to the worksheet for shapes
Application.CommandBars.Add(Name:="newToolbar", Temporary:=True).Visible
= True
With Application.CommandBars("newToolbar")
For lngCnt = 1 To sh.Shapes.Count
Set shp = sh.Shapes(lngCnt)
.Controls.Add Type:=msoControlButton
If shp.Type = 13 Or shp.Type = 7 Then
shp.CopyPicture Format:=xlBitmap
Else
shp.Copy
End If
With .Controls(lngCnt)
.PasteFace
.OnAction = "TestProc" & lngCnt
.Style = msoButtonlngCntnAndCaption
.Caption = "New Button" & lngCnt
.Tag = "my_toolbars"
.TooltipText = "PopHint" & lngCnt
End With
Next
End With
Set sh = Nothing
Set shp = Nothing
End Sub

Sub Auto_Close()
On Error Resume Next
Application.CommandBars("newToolbar").Delete
End Sub

Sub TestProc1()
MsgBox "Hello world"
End Sub

Sub TestProc2()
MsgBox "Hello world"
End Sub


--
Kind Regards
Colo
/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
Colo of 'The Road of The Cell Masters'

URL:http://www.interq.or.jp/sun/puremis/colo/CellMastersLink.htm
mailto:[email protected]

/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

 

[Colo]

Hello Robin,

Please place Auto shpas or bitmaps in the sheet1 before run this code.

'---------------------------------------------------------------------------
-----

Sub CreateToolbarMenu()
Dim lngCnt As Long, shp As Shape, sh As Worksheet
On Error Resume Next
Application.CommandBars("newToolbar").Delete
On Error GoTo 0
Set sh = Sheets(1) 'Change here to the worksheet for shapes
Application.CommandBars.Add(Name:="newToolbar", Temporary:=True).Visible
= True
With Application.CommandBars("newToolbar")
For lngCnt = 1 To sh.Shapes.Count
Set shp = sh.Shapes(lngCnt)
.Controls.Add Type:=msoControlButton
If shp.Type = 13 Or shp.Type = 7 Then
shp.CopyPicture Format:=xlBitmap
Else
shp.Copy
End If
With .Controls(lngCnt)
.PasteFace
.OnAction = "TestProc" & lngCnt
.Style = msoButtonlngCntnAndCaption
.Caption = "New Button" & lngCnt
.Tag = "my_toolbars"
.TooltipText = "PopHint" & lngCnt
End With
Next
End With
Set sh = Nothing
Set shp = Nothing
End Sub

Sub Auto_Close()
On Error Resume Next
Application.CommandBars("newToolbar").Delete
End Sub

Sub TestProc1()
MsgBox "Hello world"
End Sub

Sub TestProc2()
MsgBox "Hello world"
End Sub


--
Kind Regards
Colo
/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
Colo of 'The Road of The Cell Masters'

URL:http://www.interq.or.jp/sun/puremis/colo/CellMastersLink.htm
mailto:[email protected]

/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/