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
