6
\$\begingroup\$

Frustrated with the solutions that I found online I decided to write my of Icon Browser. From the onset I decided that my Icon Browser should work from the VBEditor and not show any of the thousands of blank button faces that I've been sifting through.

Icon Browser Demo

CommandBarButtonCallBack:Class

Description: Hooks the CommandBarButton Events.

Option Explicit
Private Type Variables
    IconBrowser As IconBrowser
End Type
Private m As Variables

Private WithEvents CEvent As CommandBarEvents

Private Sub CEvent_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)
    m.IconBrowser.CallBackButtonClicked CommandBarControl
End Sub

Public Sub Init(IconBrowser As IconBrowser, CommandBarButton As Office.CommandBarButton)
    Set CEvent = Application.VBE.Events.CommandBarEvents(CommandBarButton)
    Set m.IconBrowser = IconBrowser
End Sub

IconBrowser: Class

Description: This class is responsible for creating the menus and responding to there button events.

Option Explicit
Private Const CAPTION_CLOSE As String = "Close", CAPTION_MOVE_FIRST As String = "Move First", CAPTION_PREVIOUS As String = "Previous", CAPTION_NEXT As String = "Next", CAPTION_MOVE_LAST As String = "Move Last", CAPTION_GOTO_FACE_ID As String = "Goto Face ID", CAPTION_SAVE_MENU As String = "Saved Faced IDs"
Private Const LAST_FACEID = 22690
Private Const MAINMENU_TOP As Long = 100, MAINMENU_LEFT As Long = 100
Private Const MENU_ROOT_NAME As String = "IconExplorer"
Private Const OPTIONS_COPY_FACE_ID As String = "Copy Face ID", OPTIONS_DEBUG_PRINT As String = "Debug Print", OPTIONS_INSERT_AT_CURSOR As String = "Insert at Cursor", OPTIONS_SAVE_FACE_ID As String = "Save Face ID"

Private Type Variables
    BarPosition As Long
    ButtonsPerMenu As Long
    ComboOptions As Office.CommandBarComboBox
    CallbackCollection As VBA.Collection
    ButtonCollection As VBA.Collection
    FaceIDIndex As Long
    MainMenu As Office.CommandBar
    SaveMenu As Office.CommandBarPopup
    SubMenus() As Office.CommandBar
End Type

Private m As Variables

Private Sub Class_Terminate()
    DeleteMenus
End Sub

Private Function AddCommandBarButton(menu As Object) As Office.CommandBarButton
    Dim Button As Office.CommandBarButton, btnCallBack As New VBAProject.CommandBarButtonCallBack
    Set Button = menu.Controls.Add(MsoControlType.msoControlButton)
    btnCallBack.Init Me, Button
    m.CallbackCollection.Add btnCallBack
    Set AddCommandBarButton = Button
End Function

Public Sub CallBackButtonClicked(ByVal Button As Office.CommandBarButton)
    Select Case Button.Caption
        Case CAPTION_CLOSE
            DeleteMenus
        Case CAPTION_MOVE_FIRST
            gotoFaceID 1
        Case CAPTION_PREVIOUS
            IncrementFaceIDs False
        Case CAPTION_NEXT
            IncrementFaceIDs True
        Case CAPTION_MOVE_LAST
            gotoFaceID LAST_FACEID
            IncrementFaceIDs False
        Case CAPTION_GOTO_FACE_ID
            gotoFaceID
        Case Else
            performOption Button
    End Select

End Sub

Public Sub DeleteMenus()
    Dim cBar As Office.CommandBar
    For Each cBar In Application.VBE.CommandBars
        If Left(cBar.Name, Len(MENU_ROOT_NAME)) = MENU_ROOT_NAME Then cBar.Delete
    Next
End Sub

Private Sub gotoFaceID(Optional result As Variant)
    If IsMissing(result) Then result = Application.InputBox(Prompt:="Enter the FaceID", Title:="Goto Face ID", Type:=1)

    If Not VarType(result) = vbBoolean Then
        m.ButtonCollection(m.ButtonCollection.Count).FaceID = result - 1
        IncrementFaceIDs True
    End If
End Sub

Private Sub IncrementFaceIDs(bIncrementNext As Boolean)
    On Error GoTo IncrementFaceIDs_Error
    Dim Button As Office.CommandBarButton, IconIterator As New VBAProject.IconIterator
    Dim FaceID As Long, j As Long

    If bIncrementNext Then
        FaceID = m.ButtonCollection(m.ButtonCollection.Count).FaceID
        For j = 1 To m.ButtonCollection.Count
            Set Button = m.ButtonCollection(j)
            IconIterator.setNext Button, FaceID
        Next
    Else
        FaceID = m.ButtonCollection(1).FaceID
        For j = m.ButtonCollection.Count To 1 Step -1
            Set Button = m.ButtonCollection(j)
            IconIterator.setPrevious Button, FaceID
        Next
    End If

    On Error GoTo 0
    Exit Sub
 IncrementFaceIDs_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure IncrementFaceIDs, line " & Erl & "."
End Sub

Private Sub initMainMenu()
    Set m.MainMenu = Application.VBE.CommandBars.Add(Name:=MENU_ROOT_NAME & " - Controls", Position:=m.BarPosition, Temporary:=True)
    If m.BarPosition = MsoBarPosition.msoBarFloating Then
        m.MainMenu.Left = MAINMENU_LEFT
        m.MainMenu.Top = MAINMENU_TOP
    End If
    With AddCommandBarButton(m.MainMenu)
        .Caption = CAPTION_CLOSE
        .FaceID = 924
    End With
    With AddCommandBarButton(m.MainMenu)
        .Caption = CAPTION_MOVE_FIRST
        .FaceID = 154
    End With
    With AddCommandBarButton(m.MainMenu)
        .Caption = CAPTION_PREVIOUS
        .FaceID = 155
    End With
    With AddCommandBarButton(m.MainMenu)
        .Caption = CAPTION_NEXT
        .FaceID = 156
    End With
    With AddCommandBarButton(m.MainMenu)
        .Caption = CAPTION_MOVE_LAST
        .FaceID = 157
    End With
    With AddCommandBarButton(m.MainMenu)
        .BeginGroup = True
        .Caption = CAPTION_GOTO_FACE_ID
        .FaceID = 25
        .Style = msoButtonIconAndCaption
    End With

    Set m.ComboOptions = m.MainMenu.Controls.Add(MsoControlType.msoControlDropdown)
    With m.ComboOptions
        .AddItem OPTIONS_COPY_FACE_ID
        .AddItem OPTIONS_DEBUG_PRINT
        .AddItem OPTIONS_INSERT_AT_CURSOR
        .AddItem OPTIONS_SAVE_FACE_ID
        .ListIndex = 4
    End With

    Set m.SaveMenu = m.MainMenu.Controls.Add(MsoControlType.msoControlPopup)
    With m.SaveMenu
        .BeginGroup = True
        .Caption = CAPTION_SAVE_MENU
    End With

    m.MainMenu.Visible = True
End Sub

Private Sub initSubMenus()
    Dim btnCallBack As CommandBarButtonCallBack
    Dim j As Long, k As Long
    For j = 1 To UBound(m.SubMenus)
        Set m.SubMenus(j) = Application.VBE.CommandBars.Add(Name:=MENU_ROOT_NAME & j, Position:=m.BarPosition, Temporary:=True)
        If m.BarPosition = MsoBarPosition.msoBarFloating Then
            m.SubMenus(j).Left = MAINMENU_LEFT
            m.SubMenus(j).Top = MAINMENU_TOP + m.MainMenu.Height * j
        End If
        For k = 1 To m.ButtonsPerMenu
            m.ButtonCollection.Add AddCommandBarButton(m.SubMenus(j))
        Next
        m.SubMenus(j).Visible = True
    Next
End Sub

Public Sub Show(Optional BarPosition As MsoBarPosition = MsoBarPosition.msoBarTop, Optional NumOfSubMenus As Long = 1, Optional ButtonsPerMenu As Long = 50)
    Set m.CallbackCollection = New VBA.Collection
    Set m.ButtonCollection = New VBA.Collection
    ReDim m.SubMenus(1 To NumOfSubMenus)
    m.BarPosition = BarPosition
    m.ButtonsPerMenu = ButtonsPerMenu
    DeleteMenus
    initMainMenu
    initSubMenus
    IncrementFaceIDs True
End Sub

Private Sub performOption(ByVal Button As Office.CommandBarButton)
    On Error GoTo performOption_Error
    Select Case m.ComboOptions.Text
        Case OPTIONS_COPY_FACE_ID
            With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                .SetText Button.FaceID
                .PutInClipboard
            End With
        Case OPTIONS_DEBUG_PRINT
            Debug.Print "Face ID: "; Button.FaceID
        Case OPTIONS_INSERT_AT_CURSOR
            If Not Application.VBE.ActiveCodePane Is Nothing Then
                Application.VBE.ActiveCodePane.Show
                Application.SendKeys CStr(Button.FaceID)
            End If
        Case OPTIONS_SAVE_FACE_ID
            With AddCommandBarButton(m.SaveMenu)
                .Caption = "Face ID: " & Button.FaceID
                .FaceID = Button.FaceID
                .Style = MsoButtonStyle.msoButtonIconAndCaption
            End With
    End Select

    On Error GoTo 0
    Exit Sub
 performOption_Error:
    'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure performOption, line " & Erl & "."
End Sub

IconIterator:Class

Option Explicit

Private Type Bitmap
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private Declare Function GetObjectA Lib "Gdi32" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "Gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Const FIRST_FACEID = 2
Private Const LAST_FACEID = 22690

Private Function hasPictureData(ByVal Button As Office.CommandBarButton) As Boolean
    Dim x As Long
    Dim PicBits(767) As Byte

    GetBitmapBits Button.Picture, UBound(PicBits), PicBits(0)

    For x = 1 To 171
        If PicBits(x) > 0 And PicBits(x) <> 240 Then
            hasPictureData = True
            Exit Function
        End If
    Next
End Function

Public Sub setNext(ByVal Button As Office.CommandBarButton, ByRef FaceID As Long)
    On Error GoTo setNext_Error
    FaceID = FaceID + 1
    Button.FaceID = FaceID
    Do Until hasPictureData(Button)
        FaceID = FaceID + 1
        If FaceID > LAST_FACEID Then FaceID = FIRST_FACEID
        Button.FaceID = FaceID
        DoEvents
    Loop
    Button.TooltipText = "Face ID: " & Button.FaceID
    On Error GoTo 0
    Exit Sub
setNext_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure setNext, line " & Erl & "."
End Sub

Public Sub setPrevious(ByVal Button As Office.CommandBarButton, ByRef FaceID As Long)
    On Error GoTo setPrevious_Error
    FaceID = FaceID - 1
    Button.FaceID = FaceID
    Do Until hasPictureData(Button)
        FaceID = FaceID - 1
        If FaceID < FIRST_FACEID Then FaceID = LAST_FACEID
        Button.FaceID = FaceID
        DoEvents
    Loop
    Button.TooltipText = "Face ID: " & Button.FaceID
    On Error GoTo 0
    Exit Sub
setPrevious_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure setPrevious, line " & Erl & "."
End Sub

Description: Changes the FaceID of the CommandBarButton FaceID until it finds a non-empty button face. It does this by iterating through the Byte() of the CommandBarButton.Picture object.

Note: In order to run this code: "Trust Access To Visual Basic Project" needs to be checked in In Security settings and a reference needs to be added to the "Microsoft Visual Basic for Applications Extensibility x.x" library

ThisWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 0, 0

I am mystified by some errors that were thrown while working on and the project. I added error handler and DoEvents to allow me to easily break the code. The errors occur in IconIterator::setNext, IconIterator::setPrevious, and IconBrowser::performOption. All the errors are caused by a CommandBarButton object returned from a CommandBarButtonCallBack::CEvent_Click event. In every case, the CommandBarButton which throw the Event and is returned by the Event equals Nothing.

At times I will name ah Object after its type (Dim CommandBarButton as CommandBarButton). I assume that this is actual a bad coding practice but I would like to know why. IMO, the context of CommandBarButton makes it clear whether it is an Object or it is a Type.

Other than that, I am happy with the project and will probably roll it up into an Addon (just to do it).

Down Load IconExplorer.xlsm

\$\endgroup\$
4
  • \$\begingroup\$ I'm just a little confused - this is for adding custom command bars (into the VBE, not the ribbon) with icons, right? Not like inserting them into a Form. But what would the buttons do? Run macros? Maybe I'm just obtuse. \$\endgroup\$ May 16 '18 at 7:55
  • \$\begingroup\$ Both VBA and VBE use Office.CommandBarControls. It's a real pain to find the right icon to use. In my previous project, I created several context menu (popup menus),which I used, on my Userforms. You can also add controls to the Add-in Tab of the Ribbon and the Cell menus. \$\endgroup\$
    – user109261
    May 16 '18 at 12:06
  • \$\begingroup\$ So it's about picking an icon to insert into whatever? Clicking it will insert it? \$\endgroup\$ May 16 '18 at 22:25
  • \$\begingroup\$ It was missing. I added a download link , In case you want to try it out. It has a Show and Hide macros. As always thanks form you input. \$\endgroup\$
    – user109261
    May 17 '18 at 4:09

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy