Adding icons to custom commandbar menus

I am building a custom commandbar menu and wish to include definable margin icons as in the example below:

http://img146.imageshack.us/img146/9...ediconsws8.jpg

Note that these are not included in the FaceID set of images.

My question, therefore is what property of the CommandBarControl or CommandBarButton object must I alter to do this, and what is the syntax?

Advance thanks in anticipation of your help.

Paul

Bump for help - anybody?

Use the drawing toolbar to create the color squares you need and lace them on a worksheet. Give them decent names, then use the PasteFace method instead of FaceId

In your commandbar code:

Code:

---

Sheet1.Shapes("YourPictureName").Copy
MenuItem.PasteFace

---

See the attached gif.

Justin,

Thanks for your reply. however, I have just tried implementing it, and received the following error for my troubles:

http://img222.imageshack.us/img222/4...ceerrorjn1.jpg

Any suggestions?

Note that useing the commented out line instead works successfully, but only because I have placed the image on a VBA userform in the workbook - I'd like to avoid doing this if at all possible, because it takes much longer to set up than putting the pictures on a worksheet.

Cheers,
Paul

You might just need to set the Style property of the control first to one that includes an icon (e.g. msoButtonIconAndCaption)

Also, if you want solid colors as the icons, you can draw the bitmap in memory on-the-fly and then PasteFace that.
Could that be an option?

Just tried that - now getting a Type Mismatch error!

Well what's available to the object depends on what it's declared as (CommandBarButton, CommandBarControl, CommandBarPopup, etc).
Can you post the code?

Code:

---

Public Sub AddMenuItem(cmbTargetMenuBar As CommandBar, _
                            strMenuTitle As String, strItemCaption As String, strItemOnAction As String, _
                            Optional booFlyOut As Boolean, Optional strFlyOutTitle As String, _
                            Optional imgItemIcon As Image)
'created by Loose Cannon (VBAX handle),  July 2006
Dim booMenuExists As Boolean, booFlyOutExists As Boolean, booItemExists As Boolean
Dim cbpDestinationMenu As CommandBarPopup, cbpDestinationFlyOut As CommandBarPopup
Dim cbbNewMenuItem As CommandBarButton
''    Does a menu item with .Caption = strMenuTitle exist in cmbTargetMenuBar? (probably done using a for each obj in cmb)
    booMenuExists = FN_booMenuExists(cmbTargetMenuBar, strMenuTitle)
If booMenuExists Then
    ''        If True, set as DestinationMenu
    Set cbpDestinationMenu = cmbTargetMenuBar.Controls(strMenuTitle)
    ''        If False, create one and set as DestinationMenu
    Else
    Set cbpDestinationMenu = cmbTargetMenuBar.Controls.Add(msoControlPopup, , , , False)
    cbpDestinationMenu.Caption = strMenuTitle
    End If
If booFlyOut Then
    ''        Does a flyout branch with .Caption = strFlyOutTitle exist in DestinationMenu?
    booFlyOutExists = FN_booFlyOutExists(cbpDestinationMenu, strFlyOutTitle)
    If booFlyOutExists Then
    ''            If True, set as DestinationFlyOut
    Set cbpDestinationFlyOut = FN_cbpSetFlyOut(cbpDestinationMenu, strFlyOutTitle) ''causing problems with recoginition of "&" in strFlyOutTitle
    '                If cbpDestinationFlyOut = Nothing Then Exit Sub 'not sure this is necessary - PB
        Else
    ''            If False, create one and set as DestinationFlyOut
    Set cbpDestinationFlyOut = cbpDestinationMenu.Controls.Add(msoControlPopup, , , , False)
    cbpDestinationFlyOut.Caption = strFlyOutTitle
        End If
''        Does a menu item with .Caption = strItemCaption exist in DestinationFlyOut
booItemExists = FN_booItemExists(cbpDestinationFlyOut, strItemCaption)
        If Not booItemExists Then
    ''            If False create and set .OnAction = strItemOnAction
    Set cbbNewMenuItem = cbpDestinationFlyOut.Controls.Add(msoControlButton, , , , False)
    With cbbNewMenuItem
        .Caption = strItemCaption
        .OnAction = strItemOnAction
        .Picture = imgItemIcon.Picture
    End With
        Else
    ''            If True, exit
        Exit Sub
    End If
Else  ''not a fly out item
    ''        Does a menu item with .Caption = strItemCaption exist in DestinationMenu
    booItemExists = FN_booItemExists(cbpDestinationMenu, strItemCaption)
    If Not booItemExists Then
        ''            If False create and set .OnAction = strItemOnAction
        Set cbbNewMenuItem = cbpDestinationMenu.Controls.Add(msoControlButton, , , , False)
        With cbbNewMenuItem
            .Caption = strItemCaption
            .OnAction = strItemOnAction
            .Picture = imgItemIcon.Picture
        End With
    Else
        ''            If True, exit
        Exit Sub
    End If
End If
End Sub

---

The item being added, cbbNewMenuItem is defined as a CommandBarButton. PasteFace appears in the properties/methods hot list for it and allows the project to compile, but is not then recognised when the code is run.

Passing in an image from a user form as imgItemIcon works with cbbNeMenuItem.Picture = imgItemIcon.Picture. However, I wondered if there was a way of reading images directly from the worksheet.

Your help is much appreciated!

Oops, sorry, it's going to need the corresponding Functions:

Code:

---

Public Function FN_booMenuExists(cmb As CommandBar, strMenuTitle As String) As Boolean
Dim cbc As CommandBarControl
FN_booMenuExists = False
For Each cbc In cmb.Controls
    If cbc.Caption = strMenuTitle Then FN_booMenuExists = True
Next cbc
End Function

Public Function FN_booFlyOutExists(cbp As CommandBarPopup, strFlyOutTitle As String) As Boolean
Dim cbc As CommandBarControl
FN_booFlyOutExists = False
For Each cbc In cbp.Controls
    If cbc.Caption = strFlyOutTitle And cbc.Type = msoControlPopup Then FN_booFlyOutExists = True
Next cbc
End Function

Public Function FN_booItemExists(cbp As CommandBarPopup, strItemCaption As String) As Boolean
Dim cbc As CommandBarControl
FN_booItemExists = False
For Each cbc In cbp.Controls
    If cbc.Caption = strItemCaption Then FN_booItemExists = True
Next cbc
End Function

Public Function FN_cbpSetFlyOut(cbpRoot As CommandBarPopup, strFlyOutTitle As String) As CommandBarPopup
Dim cbc As CommandBarControl
Set FN_cbpSetFlyOut = Nothing
For Each cbc In cbpRoot.Controls
    If cbc.Caption = strFlyOutTitle And cbc.Type = msoControlPopup Then Set FN_cbpSetFlyOut = cbc
Next cbc
End Function

---

So the key parts of the code are

Code:

---

Sub test()
Dim cmbTargetMenuBar As CommandBar
Dim cbbNewMenuItem As CommandBarButton
Set cmbTargetMenuBar = CommandBars.Add
With cmbTargetMenuBar
    .Visible = True
    Set cbbNewMenuItem = .Controls.Add(msoControlButton, , , , False)
    With cbbNewMenuItem
        .Caption = "Test caption"
        .OnAction = "testroutine"
        .Style = msoButtonIconAndCaption
        Sheets(1).Shapes("testicon").Copy
        .PasteFace
    End With
End With
End Sub

---

So with a picture named "testicon" on sheet 1, I get a bar/button/icon.

You'll get a "Method... failed" error if:
there's nothing on the clipboard
the clipboard contents isn't compatible

Although, using similar code, I had this error occasionally (actually rare and randomly) when running from Excel97 - I could never replicate it under test conditions and since the project spec specified 2000+, I didn't chase it down.

Works a treat - thanks Killian!