Attribute VB_Name = "mDarkMode"
Option Explicit
'
' Most of the code from https://www.vbforums.com/showthread.php?900444-Windows-10-Dark-Mode-amp-VB6-apps
' Thanks to Mith, Fafalone, Diletante and vbforums users.
'
' Tested under Windows 11 with VBCCR v1.08.0092
'
' Everything does not render well in DarkMode,
' especially the OptionButtons and the CheckBoxes.
' Therefore, we need to place an invisible label called
' LabelOption(0) on the form.
' This will be used to create a clickable pseudo-caption
' for these objects.
' The OptionButtons and the Checkboxes will be shorten
' so that their real caption disappears leaving only
' their icon visible. Then a LabelOption() is created and
' positioned next to the icon. This way, the icon
' and the LabelOption are clickable.
' With VBCCR, LabelOption(0) can be a LabelW.
' We need to add the following to the form code :
'
'Private Sub LabelOption_Click(Index As Integer)
'    LabelOptionClick Me, Index
'End Sub
'
' If you don’t put a LabelOption(0) on the form,
' labels are dynamically created as captions but
' they won’t be clickable.
' It is also done this way for option buttons
' and check boxes that are in a container.
'
' For OptionButtonW and CheckBoxW, you can choose
' to draw the object. You have to change the
' property DrawMode of your object to 1.
' Then in your form add for each object (ex: OptionButtonW1 and CheckBoxW1):
'
'Private Sub OptionButtonW1_OwnerDraw(ByVal Action As Long, ByVal State As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long)
'    OwnerDrawOptionButtonW Me, OptionButtonW1, hDC, Left, Top, Right, Bottom
'End Sub
'
'Private Sub CheckBoxW1_OwnerDraw(ByVal Action As Long, ByVal State As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long)
'    OwnerDrawCheckBoxW Me, CheckBoxW1, hDC, Left, Top, Right, Bottom
'End Sub
'
' It's easier and cleaner to use BUT the drawn icons aren't in DarkMode.
'
Private Declare Function DwmSetWindowAttribute Lib "dwmapi.dll" (ByVal hWnd As Long, ByVal dwAttribute As Long, ByRef pvAttribute As Long, ByVal cbAttribute As Long) As Long
Private Const DWMWA_USE_IMMERSIVE_DARK_MODE = 20
Public Declare Function SetWindowTheme Lib "uxtheme" (ByVal hWnd As Long, ByVal pszSubAppName As Long, ByVal pszSubIdList As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' For drawing CheckBoxW1 and OptionButtonW1
' Comment if you don't use VBCCR
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function OpenThemeData Lib "uxtheme.dll" (ByVal hWnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme.dll" (ByVal hTheme As Long) As Long

Private Type SIZE
    cx As Long
    cy As Long
End Type
Private Const TS_DRAW = 2 ' TS_MIN = 0  TS_TRUE = 1
'Private Declare Function GetThemePartSize Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, ByVal prc As Long, ByVal eSize As Long, psz As SIZE) As Long
Private Declare Function GetThemePartSize Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, prc As RECT, ByVal eSize As Long, psz As SIZE) As Long
Private Declare Function GetThemeBackgroundContentRect Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, pBoundingRect As RECT, pContentRect As RECT) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
' DrawText flags
Private Const DT_LEFT = &H0
Private Const DT_VCENTER = &H4
Private Const DT_SINGLELINE = &H20
Private Const DT_END_ELLIPSIS = &H8000
Private Const DT_WORDBREAK = &H10

Private Declare Function DrawThemeBackground Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, ByVal pClipRect As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
'Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Const BP_RADIOBUTTON = 2
Private Const RBS_UNCHECKEDNORMAL = 1
Private Const RBS_UNCHECKEDHOT = 2
Private Const RBS_UNCHECKEDPRESSED = 3
Private Const RBS_UNCHECKEDDISABLED = 4
Private Const RBS_CHECKEDNORMAL = 5
Private Const RBS_CHECKEDHOT = 6
Private Const RBS_CHECKEDPRESSED = 7
Private Const RBS_CHECKEDDISABLED = 8
Private Const TRANSPARENT = 1
Private Const BP_CHECKBOX = 3
Private Const CBS_UNCHECKEDNORMAL = 1
Private Const CBS_UNCHECKEDHOT = 2
Private Const CBS_UNCHECKEDPRESSED = 3
Private Const CBS_UNCHECKEDDISABLED = 4
Private Const CBS_CHECKEDNORMAL = 5
Private Const CBS_CHECKEDHOT = 6
Private Const CBS_CHECKEDPRESSED = 7
Private Const CBS_CHECKEDDISABLED = 8
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' Main colors
Private Const FRMFORECOLOR       As Long = vbWhite
Private Const FRMBACKCOLOR       As Long = &H323232
Private Const CMDFORECOLOR       As Long = vbWhite
Private Const CMDBACKCOLOR       As Long = &H454545
Private Const TXTFORECOLOR       As Long = vbWhite
Private Const TXTBACKCOLOR       As Long = &H454545
Private Const TLBFORECOLOR       As Long = &H7F7F7F ' Color of text of toolbar's buttons
Private Const WINDOWTEXTCOLOR    As Long = vbWhite  ' vbWindowText
Private Const FRAMEBORDERCOL     As Long = &HDCDCDC
Private Const VBFLXGRD_GRIDCOLOR As Long = &H3E3E3E ' VbFlexGrid Grid Color

Private labelOptionIndex As Long

Public Sub DarkMode(frm As Form)
'
' At the end of your Form_Load(), put DarkMode Me
'
Dim ShiftY          As Long
    
    ' Title Bar
Dim bValue As Long
   bValue = 1
   Call DwmSetWindowAttribute(frm.hWnd, DWMWA_USE_IMMERSIVE_DARK_MODE, bValue, LenB(bValue))
    
    ' Form colors
    frm.BackColor = FRMBACKCOLOR
    frm.ForeColor = FRMFORECOLOR

Dim obj         As Object
Dim i           As Long
Dim idx         As Long
Dim lbl         As Label
Dim hCombo      As Long
Dim hUpDown     As Long
Dim pnl         As Object
Dim bFound      As Boolean
'Dim hTips As Long
'Const LVM_FIRST = &H1000
'Const LVM_GETTOOLTIPS = (LVM_FIRST + 78)


Dim lIconWidth As Long
    Select Case frm.ScaleMode
    Case 1: lIconWidth = 240: ShiftY = 30 'Twips
    Case 3: lIconWidth = 16: ShiftY = 2 'Pixels
    End Select
    
    For Each obj In frm.Controls
        
        bFound = False
        
        'ComboBox
        If (TypeOf obj Is ComboBox) Then
            SetWindowTheme obj.hWnd, StrPtr("DarkMode_CFD"), 0&
            If obj.BackColor = vbWindowBackground Then obj.BackColor = FRMBACKCOLOR
            If obj.ForeColor = vbWindowText Then obj.ForeColor = FRMFORECOLOR
            bFound = True
        End If
        'Line
        If (TypeOf obj Is Line) Then
            If obj.BorderColor = vbWindowText Then obj.BorderColor = WINDOWTEXTCOLOR
            bFound = True
        End If
        'Shape
        If (TypeOf obj Is Shape) Then
            If obj.BorderColor = vbWindowText Then obj.BorderColor = WINDOWTEXTCOLOR
            If obj.FillColor = vbBlack Then obj.FillColor = vbWhite
            bFound = True
        End If
        'PictureBox
        If bFound = False And (TypeOf obj Is PictureBox) Then
            If obj.BackColor = vbButtonFace Then obj.BackColor = FRMBACKCOLOR
            If obj.ForeColor = vbButtonText Then obj.ForeColor = FRMFORECOLOR
            If obj.Appearance = 0 Then
                If obj.BackColor = vbWindowBackground Then obj.BackColor = FRMBACKCOLOR
                If obj.ForeColor = vbWindowText Then obj.ForeColor = FRMFORECOLOR
            End If
            bFound = True
        End If
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Comment if you don't use VBCCR
        '
        ' ComboBoxW
        If bFound = False And (TypeOf obj Is ComboBoxW) Then
            SetWindowTheme obj.hWnd, StrPtr("DarkMode_CFD"), 0&
            bFound = True
            If obj.BackColor = vbWindowBackground Then obj.BackColor = FRMBACKCOLOR
            If obj.ForeColor = vbWindowText Then obj.ForeColor = FRMFORECOLOR
        End If
        'VirtualCombo
        If bFound = False And (TypeOf obj Is VirtualCombo) Then
            SetWindowTheme obj.hWnd, StrPtr("DarkMode_CFD"), 0&
            bFound = True
            If obj.BackColor = vbWindowBackground Then obj.BackColor = FRMBACKCOLOR
            If obj.ForeColor = vbWindowText Then obj.ForeColor = FRMFORECOLOR
        End If
        'FontCombo
        If bFound = False And (TypeOf obj Is FontCombo) Then
            SetWindowTheme obj.hWnd, StrPtr("DarkMode_CFD"), 0&
            bFound = True
            If obj.BackColor = vbWindowBackground Then obj.BackColor = FRMBACKCOLOR
            If obj.ForeColor = vbWindowText Then obj.ForeColor = FRMFORECOLOR
        End If
        ' Image Combo : does not work 100%
        If bFound = False And (TypeOf obj Is ImageCombo) Then
            obj.VisualStyles = False
            SetWindowTheme obj.hWnd, StrPtr("DarkMode_CFD"), 0&
            If Not inIDE Then
                hCombo = FindWindowEx(obj.hWnd, 0, "ComboBox", vbNullString)
                If hCombo <> 0 Then
                    SetWindowTheme hCombo, StrPtr("DarkMode_CFD"), 0&
                End If
            End If
            bFound = True
        End If
        ' ListView
        If bFound = False And (TypeOf obj Is ListView) Then
            SetWindowTheme obj.hWnd, StrPtr("DarkMode_Explorer"), 0&
            SetWindowTheme obj.hWndHeader, StrPtr("DarkMode_ItemsView"), 0&
            For i = 1 To obj.ColumnHeaders.Count ' réglage des colonnes
                obj.ColumnHeaders(i).ForeColor = CMDFORECOLOR
            Next i
            ' does not work for me or I'm missing something :
            'hTips = SendMessage(obj.hWnd, LVM_GETTOOLTIPS, 0, ByVal 0)
            'Call Win32SetWindowTheme(hTips, "DarkMode_Explorer")
            If obj.BackColor = vbWindowBackground Then obj.BackColor = FRMBACKCOLOR
            If obj.ForeColor = vbWindowText Then obj.ForeColor = FRMFORECOLOR
           bFound = True
        End If
        ' Toolbar
        If bFound = False And (TypeOf obj Is ToolBar) Then
           SetWindowTheme obj.hWnd, StrPtr("DarkMode_Explorer"), 0&
            For i = 1 To obj.Buttons.Count
                obj.Buttons(i).ForeColor = TLBFORECOLOR
            Next i
            If obj.BackColor = vbButtonFace Then obj.BackColor = FRMBACKCOLOR
            If obj.InsertMarkColor = vbBlack Then obj.InsertMarkColor = vbWhite
           bFound = True
        End If
        'DTPicker
        If bFound = False And (TypeOf obj Is DTPicker) Then
            With obj
            .VisualStyles = False
            SetWindowTheme obj.hWnd, 0&, StrPtr("DarkMode::FileExplorerBannerContainer")
            .CalendarBackColor = FRMBACKCOLOR
            .CalendarForeColor = FRMFORECOLOR
            .CalendarTitleBackColor = FRMBACKCOLOR
            .CalendarTitleForeColor = FRMFORECOLOR
            If .UpDown = True Then
                hUpDown = FindWindowEx(obj.hWnd, 0&, "msctls_updown32", "")
                If hUpDown <> 0 Then SetWindowTheme hUpDown, StrPtr("DarkMode_Explorer"), 0&
            End If
            End With
            bFound = True
        End If
        'MonthView
        If bFound = False And (TypeOf obj Is MonthView) Then
            With obj
            '.VisualStyles = False
            SetWindowTheme obj.hWnd, 0&, StrPtr("DarkMode::FileExplorerBannerContainer")
            .BackColor = FRMBACKCOLOR
            .ForeColor = FRMFORECOLOR
            .TitleBackColor = FRMBACKCOLOR
            .TitleForeColor = FRMFORECOLOR
            End With
            bFound = True
        End If
        ' RichTextBox
        If (TypeOf obj Is RichTextBox) Then
            obj.BorderStyle = 0
            obj.SelStart = 0
            obj.SelLength = Len(obj.Text)
            If obj.SelColor = vbBlack Then obj.SelColor = TXTFORECOLOR
            If obj.BackColor = vbWindowBackground Then obj.BackColor = TXTBACKCOLOR
             bFound = True
        End If
        ' StatusBar
        If (TypeOf obj Is StatusBar) Then
            SetWindowTheme obj.hWnd, 0&, StrPtr("DarkMode::ExplorerStatusBar")
            For Each pnl In obj.Panels
                pnl.ForeColor = TXTFORECOLOR
            Next
            bFound = True
        End If
        '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        If bFound = False Then
        
            '
            ' General case
            '
            On Error Resume Next ' in case of a missing property
            SetWindowTheme obj.hWnd, StrPtr("DarkMode_Explorer"), 0&
            obj.BackColor = FRMBACKCOLOR
            obj.ForeColor = FRMFORECOLOR
            On Error GoTo 0
        
            '
            ' Special cases
            '
        
            'CommandButton & CommandButtonW
            If (TypeOf obj Is CommandButton) Or (TypeOf obj Is CommandButtonW) Then ' comment if not using VBCCR
                obj.BackColor = CMDBACKCOLOR
                On Error Resume Next
                obj.ForeColor = CMDFORECOLOR ' only for CommandButtonW
                On Error GoTo 0
                bFound = True
            End If
            'TextBox,
            If (TypeOf obj Is TextBox) Then
                obj.BackColor = TXTBACKCOLOR
                obj.ForeColor = TXTFORECOLOR
                obj.Appearance = 0
                obj.BorderStyle = 0
                bFound = True
            End If
            'TextBoxW
            If (TypeOf obj Is TextBoxW) Then ' comment if not using VBCCR
                obj.BackColor = TXTBACKCOLOR
                obj.ForeColor = TXTFORECOLOR
                obj.BorderStyle = 0
                bFound = True
            End If
            
        End If
    Next
    
    'Option, Check,  Frame, VbFlexGrid
    If bFound = False Then
        idx = 0
        For Each obj In frm.Controls
            '
            ' Option Button
            '
            If (TypeOf obj Is OptionButton) Then
                If Not addLabelOption(frm, obj) Then
                    idx = idx + 1
                    Set lbl = frm.Controls.Add("vb.label", "lbob" & idx & obj.Name, obj.Container)
                    lbl.ForeColor = FRMFORECOLOR
                    lbl.BackColor = obj.Container.BackColor
                    lbl.Visible = True
                    lbl.Caption = obj.Caption
                    lbl.Width = obj.Width - lIconWidth
                    lbl.Height = obj.Height
                    lbl.Font.Name = obj.Font.Name
                    lbl.Font.SIZE = obj.Font.SIZE
                    obj.Width = lIconWidth
                    lbl.Move obj.Left + lIconWidth, obj.Top + ShiftY
                    obj.BackColor = obj.Container.BackColor
                End If
            End If
            '
            ' Check Box
            '
            If (TypeOf obj Is CheckBox) Then
                If Not addLabelOption(frm, obj) Then
                    idx = idx + 1
                    Set lbl = frm.Controls.Add("vb.label", "lbcb" & idx & obj.Name, obj.Container)
                    lbl.ForeColor = FRMFORECOLOR
                    lbl.BackColor = obj.Container.BackColor
                    lbl.Visible = True
                    lbl.Caption = obj.Caption
                    lbl.Width = obj.Width - lIconWidth
                    lbl.Height = obj.Height
                    lbl.Font.Name = obj.Font.Name
                    lbl.Font.SIZE = obj.Font.SIZE
                    obj.Width = lIconWidth
                    lbl.Move obj.Left + lIconWidth, obj.Top + ShiftY
                    obj.BackColor = obj.Container.BackColor
                End If
            End If
            '
            ' Frame
            '
            If (TypeOf obj Is Frame) Then darkFrame frm, obj
            
            ''''''''''''''''''''''''''''''''''''''''''''''''
            ' Comment if you don't use VBCCR
            '
            '
            ' OptionButtonW
            '
            If (TypeOf obj Is OptionButtonW) Then
                If obj.DrawMode <> OptDrawModeOwnerDraw Then
                    If Not addLabelOption(frm, obj) Then
                        idx = idx + 1
                        Set lbl = frm.Controls.Add("vb.label", "lbob" & idx & obj.Name, obj.Container)
                        lbl.ForeColor = FRMFORECOLOR
                        lbl.BackColor = obj.Container.BackColor
                        lbl.Visible = True
                        lbl.Caption = obj.Caption
                        lbl.Width = obj.Width - lIconWidth
                        lbl.Height = obj.Height
                        lbl.Font.Name = obj.Font.Name
                        lbl.Font.SIZE = obj.Font.SIZE
                        obj.Width = lIconWidth
                        lbl.Move obj.Left + lIconWidth, obj.Top + ShiftY
                        obj.BackColor = obj.Container.BackColor
                    End If
                End If
            End If
            '
            ' CheckBoxW
            '
            If (TypeOf obj Is CheckBoxW) Then
                If obj.DrawMode <> ChkDrawModeOwnerDraw Then
                    If Not addLabelOption(frm, obj) Then
                        idx = idx + 1
                        Set lbl = frm.Controls.Add("vb.label", "lbcb" & idx & obj.Name, obj.Container)
                        lbl.ForeColor = FRMFORECOLOR
                        lbl.BackColor = obj.Container.BackColor
                        lbl.Visible = True
                        lbl.Caption = obj.Caption
                        lbl.Width = obj.Width - lIconWidth
                        lbl.Height = obj.Height
                        lbl.Font.Name = obj.Font.Name
                        lbl.Font.SIZE = obj.Font.SIZE
                        obj.Width = lIconWidth
                        lbl.Move obj.Left + lIconWidth, obj.Top + ShiftY
                        obj.BackColor = obj.Container.BackColor
                    End If
                End If
            End If
            '
            ''''''''''''''''''''''''''''''''''''''''''''''''
            
            ''''''''''''''''''''''''''''''''''''''''''''''''
            ' Comment if you don't use VbFelxGrid
            '
            If (TypeOf obj Is VBFlexGrid) Then
                obj.GridColor = VBFLXGRD_GRIDCOLOR
                obj.BackColorFixed = TXTBACKCOLOR
            End If
            '
            ''''''''''''''''''''''''''''''''''''''''''''''''
    
        Next
    End If
    
End Sub

Private Function addLabelOption(frm As Form, obj As Object) As Boolean
' Shortens the obj to display a LabelOption() as if it was its caption.
' This allows to keep the 'caption' clickable (see LabelOptionClick).
'
' obj is an OptionButton or a CheckBox (or OptionButtonW or a CheckBoxW) which is on frm.
'
Dim lShiftY     As Long
Dim lIconWidth As Long
    
    ' We add a LabelOption() only on the form. We use another technic for containers
    If obj.Container.Name <> frm.Name Then Exit Function
        
    Select Case frm.ScaleMode
    Case 1: lShiftY = 30: lIconWidth = 240      'twips
    Case 3: lShiftY = 2:  lIconWidth = 16       'pixels
    End Select
    
    On Error GoTo ERREUR
    
    'Create a new LabelOption()
    labelOptionIndex = labelOptionIndex + 1
    Load frm.LabelOption(labelOptionIndex)
    
    With frm.LabelOption(labelOptionIndex)
    .ForeColor = frm.ForeColor
    .BackColor = frm.BackColor
    .Caption = obj.Caption
    .Width = obj.Width - lIconWidth
    .Height = obj.Height
    .Font.Name = obj.Font.Name
    .Font.SIZE = obj.Font.SIZE
    obj.Width = lIconWidth 'to display only the icon (option button or check box)
    .Move obj.Left + lIconWidth, obj.Top + lShiftY
    .Tag = obj.Name ' used in LabelOptionClick
    .Visible = True
    End With
    addLabelOption = True
ERREUR:
End Function

Private Sub darkFrame(frm As Form, oFrame As Object)
    
    ' Better use FrameW, the solution below is not very good.
    
    ' With Frame, you can't change the color of the caption.
    ' So we delete Border, we create a shape surrounding the frame
    ' to simulate the border and we create a label to simulate the caption
    
    If oFrame.BorderStyle = 0 Then Exit Sub
    If LenB(oFrame.Caption) = 0 Then Exit Sub

Dim oShape      As Shape
Dim OnePixel    As Long
Dim TwoPixels   As Long
Dim FourPixels  As Long

    Select Case frm.ScaleMode
    Case 1: OnePixel = 15: TwoPixels = 30: FourPixels = 60 'Twips
    Case 3: OnePixel = 1:  TwoPixels = 2:  FourPixels = 4  'Pixels
    End Select
    
On Error GoTo ERREUR
    
    Set oShape = oFrame.Container.Controls.Add("vb.shape", "shp" & oFrame.Name, oFrame.Container)
    oShape.BorderColor = FRAMEBORDERCOL
    oShape.Left = oFrame.Left - OnePixel
    oShape.Top = oFrame.Top - OnePixel
    oShape.Width = oFrame.Width + TwoPixels
    oShape.Height = oFrame.Height + TwoPixels
    oFrame.BorderStyle = 0
    oShape.Visible = True

Dim lbl As Label
    Set lbl = oFrame.Container.Controls.Add("vb.label", "lblFrm" & oFrame.Name, oFrame)
    lbl.Caption = oFrame.Caption
    lbl.BackStyle = 0
    lbl.ForeColor = oFrame.ForeColor
    lbl.Move FourPixels, 0
    lbl.Font.Name = oFrame.Font.Name
    lbl.Font.SIZE = oFrame.Font.SIZE - 1
    lbl.Visible = True
ERREUR:
End Sub

Public Sub LabelOptionClick(frm As Form, Index As Integer)
'
' Don't forget to add in your Form a LabelOption(0) and this code:
'
'Private Sub LabelOption_Click(Index As Integer)
'    LabelOptionClick Me, Index
'End Sub
'
Dim obj As Object
    
    On Error GoTo ERREUR
    
    For Each obj In frm.Controls
        If obj.Name = frm.LabelOption(Index).Tag Then
           
           If TypeOf obj Is OptionButton Then obj.Value = True: Exit Sub
           
           If TypeOf obj Is CheckBox Then
                 If obj.Value = vbUnchecked Then obj.Value = vbChecked Else obj.Value = vbUnchecked
                 Exit Sub
           End If
           
           ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
           ' Comment this part if you don't use VBCCR
           If TypeOf obj Is OptionButtonW Then obj.Value = True: Exit Sub
           
           If TypeOf obj Is CheckBoxW Then
                 If obj.Value = vbUnchecked Then obj.Value = vbChecked Else obj.Value = vbUnchecked
                 Exit Sub
           End If
           '
           ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        End If
    Next
    
ERREUR:
End Sub

Public Sub OwnerDrawCheckBoxW(frm As Form, obj As Object, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long)
'
' Draw a CheckBoxW
' obj.DrawMode must be = 1 = ChkDrawModeOwnerDraw
'
' In your form, add something like this for each of your CheckBoxW:
'
'Private Sub CheckBoxW1_OwnerDraw(ByVal Action As Long, ByVal State As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long)
'    OwnerDrawCheckBoxW Me, CheckBoxW1, hDC, Left, Top, Right, Bottom
'End Sub
'
Dim hTheme  As Long
Dim rc      As RECT
Dim ST      As Long
Dim sz      As SIZE
 
 Dim rcGlyph As RECT
 Dim rcText  As RECT
 Dim rcFull  As RECT
    
    initOwnerDraws frm ' move obj for alignment
    
    hTheme = OpenThemeData(frm.hWnd, StrPtr("DarkMode_Explorer::Button")) 'BUTTON
    
    If obj.Value = vbChecked Then
        ST = CBS_CHECKEDNORMAL
    Else
        ST = CBS_UNCHECKEDNORMAL
    End If
    
    'Check box size
    GetThemePartSize hTheme, hDC, BP_CHECKBOX, ST, rcGlyph, TS_DRAW, sz
    rcGlyph.Left = Left + 2
    rcGlyph.Top = Top + ((Bottom - Top - sz.cy) \ 2)
    rcGlyph.Right = rcGlyph.Left + sz.cx: If rcGlyph.Right < 15 Then rcGlyph.Right = 15
    rcGlyph.Bottom = rcGlyph.Top + sz.cy: If rcGlyph.Bottom < 15 Then rcGlyph.Bottom = 15
    
    rc.Left = 2
    rc.Top = 2
    rc.Right = rc.Left + sz.cx: If rc.Right < 15 Then rc.Right = 15 '    rc.Right = 18
    rc.Bottom = rc.Top + sz.cy: If rc.Bottom < 15 Then rc.Bottom = 15 '    rc.Bottom = 18
    
    'Draw Check Box
    DrawThemeBackground hTheme, hDC, BP_CHECKBOX, ST, rc, 0
    
    ' Text zone
    GetThemeBackgroundContentRect hTheme, hDC, BP_CHECKBOX, ST, rcFull, rcText
    rcText.Left = rcGlyph.Right + 4
    rcText.Top = Top
    rcText.Right = Right - 4
    rcText.Bottom = Bottom
    
    SetBkMode hDC, TRANSPARENT
    SetTextColor hDC, frm.ForeColor

    DrawText hDC, obj.Caption, -1, rcText, _
             DT_LEFT Or DT_WORDBREAK 'DT_LEFT Or DT_VCENTER Or DT_SINGLELINE Or DT_END_ELLIPSIS
    CloseThemeData hTheme
End Sub

Public Sub OwnerDrawOptionButtonW(frm As Form, obj As Object, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long)
'
' Draw an OptionButtonW
' obj.DrawMode must be = 1 = OptDrawModeOwnerDraw
'
' In your form, add something like this for each of your OptionButtonWs:
'
'Private Sub OptionButtonW1_OwnerDraw(ByVal Action As Long, ByVal State As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long)
'    OwnerDrawOptionButtonW Me, OptionButtonW1, hDC, Left, Top, Right, Bottom
'End Sub
'
Dim hTheme  As Long
Dim rc      As RECT
Dim ST      As Long
Dim sz      As SIZE

 Dim rcGlyph As RECT
 Dim rcText  As RECT
 Dim rcFull  As RECT

    initOwnerDraws frm ' move obj for alignment

    hTheme = OpenThemeData(frm.hWnd, StrPtr("DarkMode_Explorer::Button")) 'BUTTON

    If obj.Value = True Then
        ST = RBS_CHECKEDNORMAL
    Else
        ST = RBS_UNCHECKEDNORMAL
    End If
    
    'Radio button size
    GetThemePartSize hTheme, hDC, BP_RADIOBUTTON, ST, rcGlyph, TS_DRAW, sz
    rcGlyph.Left = Left + 2
    rcGlyph.Top = Top + ((Bottom - Top - sz.cy) \ 2)
    rcGlyph.Right = rcGlyph.Left + sz.cx: If rcGlyph.Right < 15 Then rcGlyph.Right = 15
    rcGlyph.Bottom = rcGlyph.Top + sz.cy: If rcGlyph.Bottom < 15 Then rcGlyph.Bottom = 15

    rc.Left = 2
    rc.Top = 2
    rc.Right = rc.Left + sz.cx: If rc.Right < 15 Then rc.Right = 15
    rc.Bottom = rc.Top + sz.cy: If rc.Bottom < 15 Then rc.Bottom = 15

    'Draw radio button
    DrawThemeBackground hTheme, hDC, BP_RADIOBUTTON, ST, rc, 0
    
    ' Text zone
    GetThemeBackgroundContentRect hTheme, hDC, BP_CHECKBOX, ST, rcFull, rcText
    rcText.Left = rcGlyph.Right + 4
    rcText.Top = Top
    rcText.Right = Right - 4
    rcText.Bottom = Bottom
    
    SetBkMode hDC, TRANSPARENT
    SetTextColor hDC, frm.ForeColor

    DrawText hDC, obj.Caption, -1, rcText, _
             DT_LEFT Or DT_WORDBREAK 'DT_LEFT Or DT_VCENTER Or DT_SINGLELINE Or DT_END_ELLIPSIS

    CloseThemeData hTheme
End Sub

Private Sub initOwnerDraws(frm As Form)
'
' When we draw the CheckBoxWs and the OptionButtonWs,
' they're not aligned with the normal objects, so
' we just move them so that they fit properly.
'
Static bDone As Boolean
    If bDone = True Then Exit Sub ' To do it only one time
    bDone = True

Dim obj As Object
Dim X As Long
    
    Select Case frm.ScaleMode
    Case 1: X = -30 'Twips
    Case 3: X = -2  'Pixels
    End Select
        
    For Each obj In frm.Controls
        If (TypeOf obj Is CheckBoxW) Or (TypeOf obj Is OptionButtonW) Then
            If obj.DrawMode = 1 Then
                obj.Left = obj.Left + X
            End If
        End If
    Next
        
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Uncomment for UI Ribbon
'
'Public Function SetRibbonDarkMode(ByVal fDark As Boolean) As Long
'        'Thanks to https://github.com/stefankueng/BowPad for this technique
'        On Error Resume Next
'        If pFramework Is Nothing Then Exit Function
'        Dim ps As IPropertyStore
'        Set ps = pFramework
'        If (ps Is Nothing) = False Then
'            Dim pvDark As Variant
'            pvDark = CVar(fDark)
'            ps.SetValue UI_PKEY_DarkModeRibbon, pvDark
'            ps.Commit
'        End If
'    End Function
'Public Function UI_PKEY_DarkModeRibbon() As PROPERTYKEY
''{000007d4-7363-696e-8441-798acf5aebb7, 11
'Static iid As PROPERTYKEY
' If (iid.fmtid.Data1 = 0) Then Call DEFINE_PROPERTYKEY(iid, &H7D4, CInt(&H7363), CInt(&H696E), &H84, &H41, &H79, &H8A, &HCF, &H5A, &HEB, &HB7, 11)
' UI_PKEY_DarkModeRibbon = iid
'End Function
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''