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.
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).