'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
' module : fonction pour créer icones couleur dynamiquement (collection StdPicture)
' auteur : Patrick Verne alias patricktoulon sur ExcelDownload
' version : 1.0
' date version : 10/12/2025
'****************************************************************************************************
' peut être utiliser dans un userform(bloquer la ligne fillrect en blanc pour garder la transparence avec les label dans userform)
' exemple d'utilisation pour un control dans un userform
' préférer le control label qui garde le fond transparent ,le control image lui remplace le vide autour par du noir
' Set Label1.Picture = CreateColorBall(vbRed)
' ==========================================================
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
cbSizeofStruct As Long
picType As Long
hBmp As LongPtr
hPal As LongPtr
Reserved As LongPtr
End Type
Private Const PICTYPE_BITMAP As Long = 1
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
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 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, ByRef lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function Ellipse Lib "gdi32" (ByVal hdc As LongPtr, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) 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 OleCreatePictureIndirect Lib "oleaut32" (ByRef PicDesc As PICTDESC, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, ByRef IPic As IPicture) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As LongPtr, ByRef pclsid As GUID) As Long
' ==========================================================
' CRÉATION D'UNE BOULE DE COULEUR EN STDPICTURE
' ==========================================================
Public Function CreateColorBall(ByVal lngColor As Long, Optional ByVal W As Long = 32, Optional ByVal H As Long = 32) As StdPicture
Dim hdcScreen As LongPtr
Dim hdcMem As LongPtr
Dim hBmp As LongPtr
Dim hBrWhite As LongPtr
Dim hBrColor As LongPtr
Dim oldBmp As LongPtr
Dim pic As PICTDESC
Dim IPic As IPicture
Dim IID_IPicture As GUID
' GUID IPicture
CLSIDFromString StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture
' DC de référence : bureau
hdcScreen = GetDC(0)
hdcMem = CreateCompatibleDC(hdcScreen)
' Bitmap compatible
hBmp = CreateCompatibleBitmap(hdcScreen, W, H)
oldBmp = SelectObject(hdcMem, hBmp)
' --- Remplir le fond en blanc ---
hBrWhite = CreateSolidBrush(RGB(255, 255, 255))
Dim r As RECT
r.Left = 0
r.Top = 0
r.Right = W
r.Bottom = H
FillRect hdcMem, r, hBrWhite
DeleteObject hBrWhite
' --- Dessiner la boule ---
hBrColor = CreateSolidBrush(lngColor)
SelectObject hdcMem, hBrColor
Ellipse hdcMem, 0, 0, W, H
DeleteObject hBrColor
' --- Conversion en StdPicture ---
pic.cbSizeofStruct = Len(pic)
pic.picType = PICTYPE_BITMAP
pic.hBmp = hBmp
OleCreatePictureIndirect pic, IID_IPicture, 1, IPic
Set CreateColorBall = IPic
' Nettoyage
SelectObject hdcMem, oldBmp
ReleaseDC 0, hdcScreen
End Function
