SetCommandBarButtonColor()

The following routine sets the color of a CommandBarButton. It does this by creating a bitmap (bmp) file with that color picture in it and then loading it to the CommandBarButton's Picture property.

Private Declare Function GetTempPath Lib "kernel32.dll" Alias "GetTempPathA" ( _
    ByVal nBufferLength As Long, _
    ByVal lpBuffer As String) As Long

Private Declare Function GetTempFileName Lib "kernel32.dll" Alias "GetTempFileNameA" ( _
    ByVal lpszPath As String, _
    ByVal lpPrefixString As String, _
    ByVal wUnique As Long, _
    ByVal lpTempFileName As String) As Long

Function GetTempName() As String
    Dim S As String
    Dim TempName As String

    S = String(4096, 0)
    S = Left(S, GetTempPath(4096, S))
    TempName = String(4096, 0)
    GetTempFileName S, "xyz", 0, TempName
    TempName = LCase(TempName)
    TempName = Left(TempName, InStrRev(TempName, ".tmp", , vbTextCompare) + 3)
    Kill TempName
    GetTempName = TempName
End Function

Sub SetCommandBarButtonColor(ByVal CBB As CommandBarButton, ByVal Color As Long)
    Dim Pres As Presentation
    Dim Sld As Slide
    Dim Shp As Shape
    Dim FileName As String

    FileName = GetTempName() + ".bmp"
    Set Pres = Presentations.Add(False)
    Set Sld = Pres.Slides.Add(1, ppLayoutBlank)
    Set Shp = Sld.Shapes.AddShape(msoShapeRectangle, 1, 1, 16, 16)
    Shp.Line.Visible = False
    Shp.Fill.ForeColor.RGB = Color
    Shp.Export FileName, ppShapeFormatBMP
    CBB.Picture = LoadPicture(FileName)
    Kill FileName
    Pres.Close
End Sub

The following routines uses the SetCommandBarButtonColor() routine listed above

Sub CreateButton()
    Dim CBB As CommandBarButton

    Set CBB = CommandBars("Standard").Controls.Add(Type:=msoControlButton, Temporary:=True)
    CBB.Style = msoButtonIconAndCaption
    CBB.Tag = "Test"
End Sub

Sub SetButtonColor()
    Dim CBB As CommandBarButton

    Set CBB = CommandBars.FindControl(Tag:="Test")
    SetCommandBarButtonColor CBB, RGB(255, 0, 0)
End Sub

Sub DeleteButton()
    CommandBars.FindControl(Tag:="Test").Delete
End Sub

Contact OfficeOne on email at officeone@officeoneonline.com. Copyright © 2001-2023 OfficeOne. All rights reserved.