ToggleButton on excel user form code to toggle backcolor between red and green: code does not work (completely)

[kerrywayne]

I have created a userform in excel and added a list of toggle buttons for the users to select various options. I added in the toggle button code, to change the color between red and green to let the user know what options he has chosen. The starting backcolor property toggle works, but not the next. For example, if the toggle starts out red, or "false", the toggle to green does not complete change the property to green. It actually changes it to a thatch patter, which with green lines. Clicking on it again, changes it back to the full red "false" condition. The opposite happens if the begining state is Green.

 

[Anfinsen]

Hi Kerry.
Perhaps it might make it easier to use Constants, I oftentimes rely on these, as they are easier to read in a code enviroment.

Interior.Color = vbBlack
Interior.Color = vbRed
Interior.Color = vbGreen
Interior.Color = vbYellow
Interior.Color = vbBlue
Interior.Color = vbMagenta
Interior.Color = vbCyan
Interior.Color = vbWhite

 

[kerrywayne]

Thanks for the suggestion, but that didn't work. ToggleButton does not have the internal.color property, so I had to stick with .backcolor. I did try the vbGreen and vbRed and they worked the same as using the color codes.

 

[kerrywayne]

Thanks for the suggestion, but that didn't work. ToggleButton does not have the internal.color property, so I had to stick with .backcolor. I did try the vbGreen and vbRed and they worked the same as using the color codes.

Interestingly, the color does change completely when I click on the button again,, but it is only fully red for an instance, before turning to the other color.

 

[Jaafar Tribak]

What you are describing is the normal behaviour of ToggleButtons.

When the togglebutton is depressed, its back color automatically changes to a lighter color and a Hatch pattern is added to it like you just described. This is in order to visually indicate that the button is currently pressed... In other words, you can't, for example, get a full solid red color when you press a togglebutton even after setting its BackColor Property to vbRed.

I think, the only workaround is to use the ToggleButtton Picture Property for setting its background color but that will need some more involved code.

 

[Jaafar Tribak]

I have given this a shot over the weekend and it turned out more difficult than I initially anticipated.

Basically, you call the SetBackColorAPI routine in replacement for the default BackColor Property of the ToggleButton(s)... Works with multiple togglebuttons.

Behind the scenes, the requested color(s) is\are stored as a StdPicture object pointer in the togglebutton Tag Property.

Limitations: 1- Multiline captions render as single line. 2- Some fonts do not render accurately (you may need to play a bit with the font facename and size until you get a satisfactory result)


Workbook Example:
ToggleBackColor.xls







1- API Worker code in a Standard Module:

Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As LongPtr, pbmi As BITMAPINFO, ByVal iUsage As Long, ByVal ppvBits As LongPtr, ByVal hSection As LongPtr, ByVal dwOffset As Long) As LongPtr
    Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hdc As LongPtr, ByVal lpStr As LongPtr, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As LongPtr, pbmi As BITMAPINFO, ByVal iUsage As Long, ByVal ppvBits As LongPtr, ByVal hSection As LongPtr, ByVal dwOffset As Long) As LongPtr
    Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hdc As LongPtr, ByVal lpStr As LongPtr, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

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

Private Type BITMAPFILEHEADER
    bfType As String * 2&
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO
    bmiheader As BITMAPINFOHEADER
End Type

Private stdPicsCollection As New Collection
Private hMemBmp As LongPtr


Public Sub SetBackColorAPI( _
    ByVal TglButton As MSForms.ToggleButton, _
    ByVal col As Long _
)
    Const COLOR_BTNFACE = 15&
    Dim sTag As String
    
    With TglButton
        sTag = .Tag
        If .BackColor <> GetSysColor(COLOR_BTNFACE) Then
            .BackColor = GetSysColor(COLOR_BTNFACE)
        End If
        If .PicturePosition Then
            .PicturePosition = fmPicturePositionLeftTop
        End If
        If Len(sTag) - Len(Replace(sTag, "|", "")) <= 1& Then
            Call CreateBackColor(TglButton, col)
        End If
        Set .Picture = ColorFromTag(TglButton)
    End With
End Sub


' __________________________________ PRIVATE HELPER ROUTINES __________________________________

Private Sub CreateBackColor( _
    ByVal TglButton As MSForms.ToggleButton, _
    ByVal col As Long _
)
    Dim Bytes() As Byte, oStdPic As StdPicture
    
    hMemBmp = CreateMemoryBitmap(TglButton, col)
    Bytes = GetDIBBits(hMemBmp)
    Call DeleteObject(hMemBmp)
    With CreateObject("WIA.Vector")
        .BinaryData = Bytes
        Set oStdPic = .Picture
    End With
    stdPicsCollection.Add oStdPic, CStr(ObjPtr(oStdPic))
    TglButton.Tag = TglButton.Tag & ObjPtr(oStdPic) & "|"
End Sub

Private Function ColorFromTag(ByVal TglButton As MSForms.ToggleButton) As StdPicture
    Dim sTag As String, vTagArray As Variant
    
    sTag = TglButton.Tag
    If Len(sTag) Then
        vTagArray = Split(sTag, "|")
        If TglButton.Value Then
            sTag = vTagArray(0&)
        Else
            sTag = vTagArray(1&)
        End If
        Set ColorFromTag = stdPicsCollection.Item(sTag)
    End If
End Function

Private Function CreateMemoryBitmap( _
    ByVal TglButton As MSForms.ToggleButton, _
    ByVal Color As Long _
) As LongPtr

    Const DT_CALCRECT = &H400, DT_NOCLIP = &H100
    Const CF_BITMAP = 2&
    Const TRANSPARENT = 1

    Dim hdc As LongPtr, hMemDc As LongPtr
    Dim hPrevBmp As LongPtr, hBrush As LongPtr, hPrevFont As LongPtr
    Dim tBmpRect As RECT, tTextRect As RECT
    Dim IFont As stdole.IFont
    Dim lTextCol As Long, lBackCol As Long
    Dim W As Long, H As Long
    Dim sItemText As String
  
    On Error GoTo Xit
    
    W = PTtoPX(TglButton.Width, False)
    H = PTtoPX(TglButton.Height, True)
    Call SetRect(tBmpRect, 0&, 0&, W, H)
    hdc = GetDC(NULL_PTR)
    hMemDc = CreateCompatibleDC(hdc)
    With tBmpRect
        hMemBmp = CreateCompatibleBitmap(hdc, .Right - .Left, .Bottom - .Top)
    End With
    hPrevBmp = SelectObject(hMemDc, hMemBmp)
    Set IFont = TglButton.Font
    sItemText = TglButton.Caption
    hPrevFont = SelectObject(hMemDc, IFont.hFont)
    Call DrawText(hMemDc, StrPtr(sItemText), -1&, tTextRect, DT_CALCRECT)
    With tTextRect
        .Left = (W - tTextRect.Right - tTextRect.Left) / 2&
        .Top = (H - tTextRect.Bottom - tTextRect.Top) / 2&
    End With
    Call TranslateColor(Color, NULL_PTR, lBackCol)
    hBrush = CreateSolidBrush(lBackCol)
    Call FillRect(hMemDc, tBmpRect, hBrush)
    Call SetBkMode(hMemDc, TRANSPARENT)
    Call TranslateColor(TglButton.ForeColor, NULL_PTR, lTextCol)
    Call SetTextColor(hMemDc, lTextCol)
    Call DrawText(hMemDc, StrPtr(sItemText), -1&, tTextRect, DT_NOCLIP)
    CreateMemoryBitmap = hMemBmp
Xit:
    Call SelectObject(hMemDc, hPrevBmp)
    Call SelectObject(hMemDc, hPrevFont)
    Call DeleteDC(hMemDc)
    Call DeleteObject(hBrush)
    Call ReleaseDC(NULL_PTR, hdc)
End Function

Private Function GetDIBBits(ByVal BMP As LongPtr) As Byte()
    Const DIB_RGB_COLORS = 0&
    
    Dim tBmpInf As BITMAPINFO, tBmpFileHearder As BITMAPFILEHEADER, tBitmap As BITMAP
    Dim bDIBBits() As Byte
    Dim hdc As LongPtr, hDib As LongPtr
    
    If GetObjectAPI(BMP, LenB(tBitmap), tBitmap) = NULL_PTR Then
        MsgBox "Failed to retrieve info for the bitmap.": GoTo ReleaseHandles
    End If
    With tBmpInf.bmiheader
        .biSize = LenB(tBmpInf.bmiheader)
        .biWidth = tBitmap.bmWidth
        .biHeight = tBitmap.bmHeight
        .biPlanes = 1&
        .biBitCount = 32&
        .biSizeImage = .biWidth * 4& * .biHeight
        hDib = CreateDIBSection(NULL_PTR, tBmpInf, 0&, NULL_PTR, NULL_PTR, 0&)
        If hDib = NULL_PTR Then
            MsgBox "Failed to create a DIB.": GoTo ReleaseHandles
        End If
        'OleLoadPicture expects the graphic byte array to include 54 bytes [file header + Inf header].
        ReDim bDIBBits(0& To .biSizeImage + 53&)
        'Fill bmp file header
        Call CopyMemory(bDIBBits(0&), &H4D42&, 2&)
        Call CopyMemory(bDIBBits(2&), (54& + .biSizeImage), 4&)
        Call CopyMemory(bDIBBits(10&), 54&, 4&)
        'Fill bmp info header
        Call CopyMemory(bDIBBits(14&), tBmpInf, 40&)
        hdc = GetDC(NULL_PTR)
        If GetDIBits(hdc, BMP, 0&, .biHeight, bDIBBits(54&), tBmpInf, DIB_RGB_COLORS) = NULL_PTR Then
            MsgBox "Failed to retrieve the bits of the bitmap.": GoTo ReleaseHandles
        End If
    End With
    GetDIBBits = bDIBBits
ReleaseHandles:
    Call ReleaseDC(NULL_PTR, hdc)
    Call DeleteObject(hDib)
End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX As Long = 88&, LOGPIXELSY As Long = 90&
    Static lDPI(1&) As Long, hdc As LongPtr

    If lDPI(0&) = 0& Then
        hdc = GetDC(NULL_PTR)
        lDPI(0&) = GetDeviceCaps(hdc, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(hdc, LOGPIXELSY)
        hdc = ReleaseDC(NULL_PTR, hdc)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    Const POINTSPERINCH As Long = 72&
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

2- Code Usage Test in the UserForm Module:

Option Explicit

Private Sub UserForm_Activate()
    ToggleButton1.BackColor = &H8ED0A9
    ToggleButton2.BackColor = vbWhite
    ToggleButton3.BackColor = vbYellow
End Sub

Private Sub ToggleButton1_Click()
    If ToggleButton1.Value Then
        SetBackColorAPI ToggleButton1, &HADCBF8
    Else
        SetBackColorAPI ToggleButton1, &H8ED0A9
    End If
End Sub

Private Sub ToggleButton2_Click()
    If ToggleButton2.Value Then
        SetBackColorAPI ToggleButton2, vbMagenta
    Else
        SetBackColorAPI ToggleButton2, vbWhite
    End If
End Sub

Private Sub ToggleButton3_Click()
    If ToggleButton3.Value Then
        SetBackColorAPI ToggleButton3, vbCyan
    Else
        SetBackColorAPI ToggleButton3, vbYellow
    End If
End Sub