CheckBox & Option Color Theme ? (Solved)

Windows specific forum
User avatar
ChrisR
Addict
Addict
Posts: 1127
Joined: Sun Jan 08, 2017 10:27 pm
Location: France

CheckBox & Option Color Theme ? (Solved)

Post by ChrisR »

To change the background color and text color of the options and checkboxes, the previous theme is remove (for SetTextColor).
But then, the style is different. Is there a way to do the same thing while keeping the original style ?

Image

Based on TI-994A's code CheckOptionColor() but with a map instead of SetProp/GetProp to avoid managing RemoveProp.

Code: Select all

EnableExplicit

Enumeration
  #MainWindow
  #Option1
  #Option2
  #Option3
  #Check1
  #Check2
  #Check3
EndEnumeration

Structure PropColors
  BackColor.i
  TextColor.i
EndStructure
Global NewMap PropColor.PropColors()

Procedure MainWindow_Callback(hWnd, uMsg, wParam, lParam)
  Protected Gadget, Result = #PB_ProcessPureBasicEvents
  Select uMsg
    Case #WM_CTLCOLORSTATIC
      Gadget = GetDlgCtrlID_(lparam)
      If FindMapElement(PropColor(), Str(Gadget))
        SetTextColor_(wParam, PropColor(Str(Gadget))\TextColor)
        SetBkMode_(wParam, #TRANSPARENT)
        ProcedureReturn CreateSolidBrush_(PropColor(Str(Gadget))\BackColor)
      EndIf
  EndSelect
  ProcedureReturn Result
EndProcedure

Procedure CheckOptionColor(Gadget, BackColor = #PB_Default, TextColor = #PB_Default)
  Protected None
  If Not(IsGadget(Gadget)) : ProcedureReturn : EndIf
  If GadgetType(Gadget) = #PB_GadgetType_CheckBox Or GadgetType(Gadget) = #PB_GadgetType_Option
    If BackColor = #PB_Default And TextColor = #PB_Default
      DeleteMapElement(PropColor(), Str(Gadget))
      ProcedureReturn
    EndIf
    If BackColor = #PB_Default
      If OSVersion() < #PB_OS_Windows_10
        BackColor = GetSysColor_(#COLOR_BTNFACE)
      Else
        BackColor = GetSysColor_(#COLOR_3DFACE)
      EndIf
    EndIf
    If TextColor = #PB_Default
      TextColor = GetSysColor_(#COLOR_BTNTEXT)
    EndIf
    PropColor(Str(Gadget))\BackColor = BackColor
    PropColor(Str(Gadget))\TextColor = TextColor
    SetWindowTheme_(GadgetID(Gadget), @None, @None)
  EndIf
EndProcedure

OpenWindow(#MainWindow, #PB_Any, #PB_Any, 340, 150, "Option and CheckBox Color", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
SetWindowColor(#MainWindow, #Black)
SetWindowCallback(@MainWindow_Callback(), #MainWindow)

OptionGadget(#Option1, 20, 20, 140, 30, "Black/Yellow")
CheckOptionColor(#Option1, #Black, #Yellow)

OptionGadget(#Option3, 20, 100, 140, 30, "Default/Blue")
CheckOptionColor(#Option3, #PB_Default, #Blue)

CheckBoxGadget(#Check1, 180, 20, 140, 30, "Cyan/Default")
CheckOptionColor(#Check1, #Cyan)

OptionGadget(#Option2, 20, 60, 140, 30, "Default")
;CheckOptionColor(#Option2, #Gray, #Blue)   ;"Gray/Blue"            

CheckBoxGadget(#Check2, 180, 60, 140, 30, "Default")
;CheckOptionColor(#Check2, #White, #Red)   ;"White/Red"

CheckBoxGadget(#Check3, 180, 100, 140, 30, "Black/Green or Default")
CheckOptionColor(#Check3, #Black, #Green)

Repeat
  Select WaitWindowEvent()
    Case #PB_Event_CloseWindow
      Break
    Case #PB_Event_Gadget
      Select EventGadget()
        Case #Check3
          If GetGadgetState(#Check3)
            CheckOptionColor(#Check3, #PB_Default, #PB_Default)   ; Remove Properties
          Else
            CheckOptionColor(#Check3, #Black, #Green)
          EndIf
      EndSelect
  EndSelect
ForEver
Last edited by ChrisR on Thu Apr 14, 2022 10:34 am, edited 1 time in total.
User avatar
blueb
Addict
Addict
Posts: 1041
Joined: Sat Apr 26, 2003 2:15 pm
Location: Cuernavaca, Mexico

Re: CheckBox & Option Color Theme ?

Post by blueb »

Hi Chris,

I use a WindowsCallback as below..

Code: Select all

Procedure myCallback(hWnd, uMsg, wParam, lParam)
   ;used for Option Button background color
   Global Optioncolor = CreateSolidBrush_(myBackgroundColor) ; uses the same background as screen
   
   Select uMsg
      Case #WM_CTLCOLORSTATIC
         If lparam = GadgetID(#Option_1)
            ProcedureReturn Optioncolor
         EndIf
         If lparam = GadgetID(#Option_2)
            ProcedureReturn Optioncolor
         EndIf
         If lparam = GadgetID(#Option_3)
            ProcedureReturn Optioncolor
         EndIf
         If lparam = GadgetID(#Option_4)
            ProcedureReturn Optioncolor
         EndIf
   EndSelect
   
   ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure
- It was too lonely at the top.

System : PB 6.10 Beta 9 (x64) and Win Pro 11 (x64)
Hardware: AMD Ryzen 9 5900X w/64 gigs Ram, AMD RX 6950 XT Graphics w/16gigs Mem
User avatar
ChrisR
Addict
Addict
Posts: 1127
Joined: Sun Jan 08, 2017 10:27 pm
Location: France

Re: CheckBox & Option Color Theme ?

Post by ChrisR »

Hi blueb,
I improved my previous code so that it can be done automatically for one or all Gadgets.
With an option for the background color (#PB_Auto) to automatically use the parent container's color.
And an option for the text color (#PB_Auto) to use white or black depending on the parent container color, light or dark.
See usage.

Code: Select all

; -------------------------------------------------------------------------------------------------
;        Name: CheckOptionColor.pbi
; Description: Set Background and Text Colors of OptionGadget() and CheckBoxGadget() automatically based on the parent container's color or on the colors passed in parameters
;      Author: ChrisR
;        Date: 2022-04-11
;  PB-Version: 5.73 x64/x86
;          OS: Windows only
;      Credit: TI-994A https://www.purebasic.fr/english/viewtopic.php?t=61096
;       Forum: https://www.purebasic.fr/english/viewtopic.php?t=78966
; -------------------------------------------------------------------------------------------------
; Add: XIncludeFile CheckOptionColor.pbi
; Add: SetWindowCallback(@WinCallback()[, #Window]) to associates a callback to all open windows or for a specific window only
;
; Usages:
;   CheckOptionColor([#Gadget, BackColor, TextColor])
;     - #Gadget:   #PB_All = All Option and CheckBox Gadgets (Default)
;                  The gadget to use.  
;     - BackColor: #PB_Auto = Same as parent container's color (Default)
;                  The new backgound color. RGB() can be used to get a valid color value
;                  #PB_Default = to go back to the default system backgound color
;     - TextColor: #PB_Auto = White or Black depending on whether the background color is dark or light (Default) 
;                  The new text color. RGB() can be used to get a valid color value
;                  #PB_Default: to go back to the default system text color
;
;   For all gadgets with automatic background color and text color use: CheckOptionColor()
; -------------------------------------------------------------------------------------------------

EnableExplicit

Import ""
  PB_Object_EnumerateStart(PB_Objects)
  PB_Object_EnumerateNext(PB_Objects, *ID.Integer)
  PB_Object_EnumerateAbort(PB_Objects)
  PB_Gadget_Objects.i
EndImport

#PB_Auto = -2

Structure PropColors
  BackColor.i
  TextColor.i
EndStructure
Global NewMap PropColor.PropColors()

Global NewMap hBrush()

Procedure IsDarkColor(iColor)
  If Red(iColor)*0.299 + Green(iColor)*0.587 +Blue(iColor)*0.114 < 128   ; Based on Human perception of color, following the RGB values (0.299, 0.587, 0.114)
    ProcedureReturn #True
  EndIf
  ProcedureReturn #False
EndProcedure

Procedure WinCallback(hWnd, uMsg, wParam, lParam)
  Protected Result = #PB_ProcessPureBasicEvents
  Select uMsg
    Case #WM_NCDESTROY
      ; Delete map element for all children's gadgets that no longer exist after CloseWindow(). Useful in case of multiple windows
      If MapSize(PropColor()) > 0
        ResetMap(PropColor())
        While NextMapElement(PropColor())
          If Not(IsGadget(Val(MapKey(PropColor()))))
            ;Debug "Delete Map Element Gadget: " + MapKey(PropColor())
            DeleteMapElement(PropColor())
          EndIf
        Wend 
      EndIf
      ;Delete all brushes and map element. If there are used brushes in other windows, they will be recreated
      If MapSize(hBrush()) > 0
        ResetMap(hBrush())
        While NextMapElement(hBrush())
          DeleteObject_(hBrush())
          DeleteMapElement(hBrush())
        Wend 
      EndIf
      
    Case #WM_CTLCOLORSTATIC
      Protected Gadget, BackColor, FrontColor, hdc
      Gadget = GetDlgCtrlID_(lparam)
      If FindMapElement(PropColor(), Str(Gadget))
        If PropColor(Str(Gadget))\BackColor = #PB_Auto
          hdc = GetDC_(GetParent_(lparam))
          BackColor = GetPixel_(hdc, 0, 0)
          ReleaseDC_(GetParent_(lparam), hdc)
        Else
          BackColor = PropColor(Str(Gadget))\BackColor
        EndIf
        If PropColor(Str(Gadget))\TextColor = #PB_Auto
          If IsDarkColor(BackColor) : FrontColor = #White : Else : FrontColor = #Black : EndIf
        Else
          FrontColor = PropColor(Str(Gadget))\TextColor
        EndIf
        SetTextColor_(wParam, FrontColor)
        SetBkMode_(wParam, #TRANSPARENT)
        If Not(FindMapElement(hBrush(), Str(BackColor)))
          hBrush(Str(BackColor)) = CreateSolidBrush_(BackColor)
        EndIf
        ProcedureReturn hBrush(Str(BackColor))
      EndIf
  EndSelect
  ProcedureReturn Result
EndProcedure

Procedure CheckOptionColor(Gadget = #PB_All, BackColor = #PB_Auto, TextColor = #PB_Auto)
  Protected None
  If Gadget <> #PB_All And Not(IsGadget(Gadget)) : ProcedureReturn : EndIf
  
  If BackColor = #PB_Default
    If OSVersion() < #PB_OS_Windows_10
      BackColor = GetSysColor_(#COLOR_BTNFACE)
    Else
      BackColor = GetSysColor_(#COLOR_3DFACE)
    EndIf
  EndIf
  If TextColor = #PB_Default
    TextColor = GetSysColor_(#COLOR_BTNTEXT)
  EndIf
  
  If Gadget = #PB_All
    PB_Object_EnumerateStart(PB_Gadget_Objects)
    While PB_Object_EnumerateNext(PB_Gadget_Objects, @Gadget)
      Select GadgetType(Gadget)
        Case #PB_GadgetType_CheckBox, #PB_GadgetType_Option
          PropColor(Str(Gadget))\BackColor = BackColor
          PropColor(Str(Gadget))\TextColor = TextColor
          SetWindowTheme_(GadgetID(Gadget), @None, @None)
      EndSelect
    Wend
    PB_Object_EnumerateAbort(PB_Gadget_Objects)
  Else
    Select GadgetType(Gadget)
      Case #PB_GadgetType_CheckBox, #PB_GadgetType_Option
        PropColor(Str(Gadget))\BackColor = BackColor 
        PropColor(Str(Gadget))\TextColor = TextColor
        SetWindowTheme_(GadgetID(Gadget), @None, @None)
    EndSelect
  EndIf
EndProcedure

;- Demo
CompilerIf (#PB_Compiler_IsMainFile)
  Enumeration Window
    #MainWindow
  EndEnumeration
  
  Enumeration Gadgets
    #Check_1
    #Opt_1
    #Cont_2
    #Txt_2
    #Check_2
    #Opt_2
    #Cont_3
    #Txt_3
    #Check_3
    #Opt_3
    #Check_4
    #Opt_4
    #Check_5
    #Opt_5
    #Check_6
    #Opt_6
  EndEnumeration
  
  Procedure Open_Window_0(X = 0, Y = 0, Width = 390, Height = 350)
    If OpenWindow(#MainWindow, X, Y, Width, Height, "Check & Option Color", #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_ScreenCentered)
      SetWindowColor(#MainWindow, RGB(54, 54, 54))
      CheckBoxGadget(#Check_1, 20, 20, 160, 30, "#PB_Auto/#PB_Auto")
      OptionGadget(#Opt_1, 200, 20, 160, 30, "#PB_Auto/#PB_Auto")
      ContainerGadget(#Cont_2, 10, 60, 370, 70, #PB_Container_Flat)
      SetGadgetColor(#Cont_2, #PB_Gadget_BackColor, RGB(128, 128, 128))
      TextGadget(#Txt_2, 5, 5, 160, 20, "Container_1")
      SetGadgetColor(#Txt_2, #PB_Gadget_BackColor, GetGadgetColor(#Cont_2, #PB_Gadget_BackColor)) 
      CheckBoxGadget(#Check_2, 10, 25, 160, 30, "#PB_Auto/#PB_Auto")
      OptionGadget(#Opt_2, 190, 25, 160, 30, "#PB_Auto/#PB_Auto")
      CloseGadgetList()   ; #Cont_2
      ContainerGadget(#Cont_3, 10, 140, 370, 70, #PB_Container_Flat)
      SetGadgetColor(#Cont_3, #PB_Gadget_BackColor, RGB(23, 23, 23))
      TextGadget(#Txt_3, 5, 5, 160, 20, "Container_2")
      SetGadgetColor(#Txt_3, #PB_Gadget_BackColor, GetGadgetColor(#Cont_3, #PB_Gadget_BackColor))
      SetGadgetColor(#Txt_3, #PB_Gadget_FrontColor, #White)
      CheckBoxGadget(#Check_3, 10, 25, 160, 30, "#PB_Auto/#PB_Auto")
      OptionGadget(#Opt_3, 190, 25, 160, 30, "#PB_Auto/#PB_Auto")
      CloseGadgetList()   ; #Cont_3   
      CheckBoxGadget(#Check_4, 20, 220, 160, 30, "#Cyan/#Blue")
      CheckBoxGadget(#Check_5, 20, 260, 160, 30, "#PB_Default/#PB_Default")
      CheckBoxGadget(#Check_6, 20, 300, 160, 30, "#PB_Auto/#Yellow")
      OptionGadget(#Opt_4, 200, 220, 160, 30, "#Green/#Red")
      OptionGadget(#Opt_5, 200, 260, 160, 30, "#PB_Default/#PB_Auto")
      OptionGadget(#Opt_6, 200, 300, 160, 30, "#Gray/#PB_Auto")
      
      ; CheckOptionColor Examples
      CheckOptionColor()   
      ;CheckOptionColor(#PB_All, #PB_Auto, #Yellow)
      CheckOptionColor(#Check_4, #Cyan, #Blue)
      CheckOptionColor(#Check_5, #PB_Default, #PB_Default)
      CheckOptionColor(#Check_6, #PB_Auto, #Yellow)
      CheckOptionColor(#Opt_4, #Green, #Red)
      CheckOptionColor(#Opt_5, #PB_Default, #PB_Auto)
      CheckOptionColor(#Opt_6, #Gray, #PB_Auto)
      SetWindowCallback(@WinCallback())   
      ;SetWindowCallback(@WinCallback(), #MainWindow)
    EndIf
  EndProcedure
  
  Open_Window_0()

  Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
CompilerEndIf
Last edited by ChrisR on Tue Apr 12, 2022 1:52 pm, edited 5 times in total.
User avatar
ChrisR
Addict
Addict
Posts: 1127
Joined: Sun Jan 08, 2017 10:27 pm
Location: France

Re: CheckBox & Option Color Theme ?

Post by ChrisR »

@ChrisR: Your code doesn't address the given problem -> the gadgets are still not drawn in the default way (see first post picture).
Hi jacdelad,
Yes, I know, the style is changed but I wanted to keep it simple with just WM_CTLCOLORSTATIC. After searching a bit, it does not seem possible without going through BS_OWNERDRAW.
In the latest code, it is made for all the gadgets in automatic with only CheckOptionColor(). So they all have the same style but unfortunately not the default Windows "Button" style.
User avatar
chi
Addict
Addict
Posts: 1028
Joined: Sat May 05, 2007 5:31 pm
Location: Linz, Austria

Re: CheckBox & Option Color Theme ?

Post by chi »

@ChrisR: You are leaking GDI Brushes... Every custom brush needs a 'DeleteObject_(brush)' after you're done using it.
You can inspect GDI leaks with Process Explorer (View/Select Columns.../Process Memory/[x] GDI Objects) or, if you want more details, with GDIView.
Et cetera is my worst enemy
User avatar
ChrisR
Addict
Addict
Posts: 1127
Joined: Sun Jan 08, 2017 10:27 pm
Location: France

Re: CheckBox & Option Color Theme ?

Post by ChrisR »

Thanks a lot chi :)
I had read it though but as the brush must be passed in ProcedureReturn, I thought wrongly that it was managed by the callback.
I have updated my previous post by using a static variable for the brush (not sure it is the best method!)
And thanks also for ProcessExplorer to see the GDI leaks, it looks better.
RASHAD
PureBasic Expert
PureBasic Expert
Posts: 4637
Joined: Sun Apr 12, 2009 6:27 am

Re: CheckBox & Option Color Theme ?

Post by RASHAD »

Hi ChrisR
- Define your Brushes as Global so you don't have to create it each cycle
- To change the Color just delete the brush and create the new one using the same var name
- Before you quit delete all brushes
Egypt my love
User avatar
ChrisR
Addict
Addict
Posts: 1127
Joined: Sun Jan 08, 2017 10:27 pm
Location: France

Re: CheckBox & Option Color Theme ?

Post by ChrisR »

Hi RASHAD,
As I can have several background colors, brushes, I used a global map to avoid recreating the brushes.
Thanks :)
breeze4me
Enthusiast
Enthusiast
Posts: 511
Joined: Thu Mar 09, 2006 9:24 am
Location: S. Kor

Re: CheckBox & Option Color Theme ?

Post by breeze4me »

It is possible to change the text color of a themed gadget by hooking a specific API in a process.
The code below applies only to Windows Vista and later.


Code: Select all

; https://www.purebasic.fr/english/viewtopic.php?t=64746

; ====================================================================================================
; Title:        API_HookEngine Module
; Description:  With this module you can hook procedures and api in windows
; Author:       Peyman
; Version:      1.0 (02 FEB 2016) initial version
;               1.1 (07 FEB 2016) added Inject DLL
;               1.2 (11 FEB 2016) improved injector, added Eject DLL & CallRemoteFunction with parrameter
; Platform:     Windows (X64 And X86) Unicode And Ansi
; License:      Free But Any improvements to be shared with the community.
; ====================================================================================================

DeclareModule API_HookEngine
  Declare.i Hook(*OldFunctionAddress, *NewFunctionAddress)
  Declare.i UnHook(*hook_ptr)
  Declare.i ProcAddress(ModuleName$, ProcName$)
EndDeclareModule


Module API_HookEngine  
  EnableExplicit
  
  Structure opcode
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      mov.u
    CompilerElse
      mov.a
    CompilerEndIf
    addr.i
    push.a
    ret.a
  EndStructure
  
  Structure hookstruct
    addr.i
    hook.opcode
    orig.a[SizeOf(opcode)]
  EndStructure
  
  CompilerIf #PB_Compiler_Unicode
    Import "kernel32.lib"
      GetProcAddress(hModule, lpProcName.p-ascii)
    EndImport
  CompilerElse
    Import "kernel32.lib"
      GetProcAddress(hModule, lpProcName.s)
    EndImport
  CompilerEndIf
  
  Procedure.i ProcAddress(ModuleName$, ProcName$)
    Protected moduleH.i
    
    moduleH = GetModuleHandle_(ModuleName$)
    If moduleH = #Null
      moduleH = LoadLibrary_(ModuleName$)
      If moduleH = #Null
        ProcedureReturn #Null
      EndIf
    EndIf
    
    ProcedureReturn GetProcAddress(moduleH, ProcName$)
  EndProcedure
  
  Procedure Hook(*OldFunctionAddress, *NewFunctionAddress)
    Protected *hook_ptr.hookstruct
    
    If Not *OldFunctionAddress
      ProcedureReturn #Null
    EndIf
    
    *hook_ptr = AllocateMemory(SizeOf(hookstruct))
    *hook_ptr\addr = *OldFunctionAddress
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      *hook_ptr\hook\mov = $B848
    CompilerElse
      *hook_ptr\hook\mov = $B8
    CompilerEndIf
    *hook_ptr\hook\addr = *NewFunctionAddress
    *hook_ptr\hook\push = $50
    *hook_ptr\hook\ret = $C3
     
    CopyMemory(*OldFunctionAddress, @*hook_ptr\orig, SizeOf(opcode))
    If Not WriteProcessMemory_(GetCurrentProcess_(), *OldFunctionAddress, @*hook_ptr\hook, SizeOf(opcode), #Null)
      FreeMemory(*hook_ptr)
      ProcedureReturn #Null
    Else
      ProcedureReturn *hook_ptr
    EndIf
  EndProcedure
  
  Procedure.i UnHook(*hook_ptr.hookstruct)
    Protected retValue.i
    
    If *hook_ptr
      If *hook_ptr\addr
        If WriteProcessMemory_(GetCurrentProcess_(), *hook_ptr\addr, @*hook_ptr\orig, SizeOf(opcode), #Null)
          retValue = *hook_ptr\addr
          FreeMemory(*hook_ptr)
          ProcedureReturn retValue
        EndIf
      EndIf
    EndIf
    
    ProcedureReturn #Null
  EndProcedure
EndModule



UseModule API_HookEngine

EnumerationBinary
  #DTT_TEXTCOLOR       ;(1 << 0)      ;// crText has been specified
  #DTT_BORDERCOLOR     ;(1 << 1)      ;// crBorder has been specified
  #DTT_SHADOWCOLOR     ;(1 << 2)      ;// crShadow has been specified
  #DTT_SHADOWTYPE      ;(1 << 3)      ;// iTextShadowType has been specified
  #DTT_SHADOWOFFSET    ;(1 << 4)      ;// ptShadowOffset has been specified
  #DTT_BORDERSIZE      ;(1 << 5)      ;// iBorderSize has been specified
  #DTT_FONTPROP        ;(1 << 6)      ;// iFontPropId has been specified
  #DTT_COLORPROP       ;(1 << 7)      ;// iColorPropId has been specified
  #DTT_STATEID         ;(1 << 8)      ;// IStateId has been specified
  #DTT_CALCRECT        ;(1 << 9)      ;// Use pRect as and in/out parameter
  #DTT_APPLYOVERLAY    ;(1 << 10)     ;// fApplyOverlay has been specified
  #DTT_GLOWSIZE        ;(1 << 11)     ;// iGlowSize has been specified
  #DTT_CALLBACK        ;(1 << 12)     ;// pfnDrawTextCallback has been specified
  #DTT_COMPOSITED      ;(1 << 13)     ;// Draws text with antialiased alpha (needs a DIB section)
EndEnumeration

#DTT_VALIDBITS = #DTT_TEXTCOLOR | #DTT_BORDERCOLOR | #DTT_SHADOWCOLOR | #DTT_SHADOWTYPE | #DTT_SHADOWOFFSET |
                 #DTT_BORDERSIZE | #DTT_FONTPROP | #DTT_COLORPROP | #DTT_STATEID | #DTT_CALCRECT |
                 #DTT_APPLYOVERLAY | #DTT_GLOWSIZE | #DTT_COMPOSITED

Structure DTTOPTS
  dwSize.l
  dwFlags.l
  crText.l
  crBorder.l
  crShadow.l
  iTextShadowType.l
  ptShadowOffset.POINT
  iBorderSize.l
  iFontPropId.l
  iColorPropId.l
  iStateId.l
  fApplyOverlay.l
  iGlowSize.l
  *pfnDrawTextCallback
  lParam.l
EndStructure

Global hMutexTextColor = CreateMutex()
Global gColor = #PB_Default

Prototype DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, pszText, cchText, dwTextFlags.l, pRect, *pOptions)
Global DrawThemeTextEx.DrawThemeTextEx

#App_OldWndProc = "MyAppWndProc"
#App_TextColor = "MyAppTextColor"

Procedure WndProc_SetTextColor(hwnd, message, wParam, lParam)
  Protected Result, Color, old = GetProp_(hwnd, #App_OldWndProc)
  
  If message = #WM_PAINT
    Color = GetProp_(hwnd, #App_TextColor)
    If Color <> #PB_Default
      LockMutex(hMutexTextColor)
      gColor = Color
      Result = CallWindowProc_(old, hwnd, message, wParam, lParam)
      gColor = #PB_Default
      UnlockMutex(hMutexTextColor)
      
      ProcedureReturn Result
    EndIf
  EndIf
  
  If message = #WM_NCDESTROY
    RemoveProp_(hwnd, #App_TextColor)
    RemoveProp_(hwnd, #App_OldWndProc)
  EndIf
  
  ProcedureReturn CallWindowProc_(old, hwnd, message, wParam, lParam)
EndProcedure

;Procedure PropEnumProc_FindWndProcProp(hWnd, *string, hData)
;  Protected String$
;  
;  If *string & -65536
;    String$ = PeekS(*string)
;    If String$
;      If FindString(String$, #App_OldWndProc)
;        ProcedureReturn 0
;      EndIf
;    EndIf
;  EndIf
;  
;  ProcedureReturn 1
;EndProcedure

Procedure SetGadgetTextColor(Gadget, Color)
  Protected Result, hwnd, old  ;,NotFound
  If IsGadget(Gadget)
    If GadgetType(Gadget) <> #PB_GadgetType_Option And GadgetType(Gadget) <> #PB_GadgetType_CheckBox
      ProcedureReturn 0
    EndIf
    hwnd = GadgetID(Gadget)
    If hwnd
      Result = GetProp_(hwnd, #App_OldWndProc)
      If Result = 0 ;And GetLastError_() = #ERROR_FILE_NOT_FOUND
        old = SetWindowLongPtr_(hwnd, #GWLP_WNDPROC, @WndProc_SetTextColor())
        SetProp_(hwnd, #App_OldWndProc, old)
        Debug "Set new window procedure: " + Gadget
      EndIf
;      NotFound = EnumProps_(hwnd, @PropEnumProc_FindWndProcProp())
;      If NotFound   ; if previous window procedure not found
;        old = SetWindowLongPtr_(hwnd, #GWLP_WNDPROC, @WndProc_SetTextColor())
;        SetProp_(hwnd, #App_OldWndProc, old)
;        ;Debug "Set new window procedure: " + Gadget
;      EndIf
      
      SetProp_(hwnd, #App_TextColor, Color)
      ProcedureReturn 1
    EndIf
  EndIf
  ProcedureReturn 0
EndProcedure

Procedure My_DrawThemeText(hTheme, hdc, iPartId, iStateId, pszText, cchText, dwTextFlags, dwTextFlags2, pRect)
  Protected opt.DTTOPTS\dwSize = SizeOf(DTTOPTS)
  
  If gColor <> #PB_Default
    opt\dwFlags = #DTT_TEXTCOLOR
    opt\crText = gColor
  EndIf
  
  ProcedureReturn DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, pszText, cchText, dwTextFlags, pRect, opt)
EndProcedure


If OpenLibrary(0, "UxTheme.dll")
  DrawThemeTextEx = GetFunction(0, "DrawThemeTextEx")    ;There is no DrawThemeTextEx in Windows XP, so this method is not available.
EndIf

If DrawThemeTextEx
  *DrawThemeText = Hook(ProcAddress("UxTheme.dll", "DrawThemeText"), @My_DrawThemeText())
EndIf

Enumeration Window
  #MainWindow
EndEnumeration

Enumeration Gadgets
  #Check_1
  #Opt_1
  #Cont_2
  #Txt_2
  #Check_2
  #Opt_2
  #Cont_3
  #Txt_3
  #Check_3
  #Opt_3
  #Check_4
  #Opt_4
  #Check_5
  #Opt_5
  #Check_6
  #Opt_6
EndEnumeration

If OpenWindow(#MainWindow, 0, 0, 400, 350, "Check & Option Color", #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_ScreenCentered)
  SetWindowColor(#MainWindow, RGB(54, 54, 54))
  CheckBoxGadget(#Check_1, 20, 20, 160, 30, "$008000")
  OptionGadget(#Opt_1, 200, 20, 160, 30, "Default")
  ContainerGadget(#Cont_2, 10, 60, 370, 70, #PB_Container_Flat)
    SetGadgetColor(#Cont_2, #PB_Gadget_BackColor, RGB(128, 128, 128))
    TextGadget(#Txt_2, 5, 5, 160, 20, "Container_1")
    SetGadgetColor(#Txt_2, #PB_Gadget_BackColor, GetGadgetColor(#Cont_2, #PB_Gadget_BackColor)) 
    CheckBoxGadget(#Check_2, 10, 25, 160, 30, "$586CC2")
    OptionGadget(#Opt_2, 190, 25, 160, 30, "Default")
  CloseGadgetList()   ; #Cont_2
  ContainerGadget(#Cont_3, 10, 140, 370, 70, #PB_Container_Flat)
    SetGadgetColor(#Cont_3, #PB_Gadget_BackColor, RGB(23, 23, 23))
    TextGadget(#Txt_3, 5, 5, 160, 20, "Container_2")
    SetGadgetColor(#Txt_3, #PB_Gadget_BackColor, GetGadgetColor(#Cont_3, #PB_Gadget_BackColor))
    SetGadgetColor(#Txt_3, #PB_Gadget_FrontColor, #White)
    CheckBoxGadget(#Check_3, 10, 25, 160, 30, "Default")
    OptionGadget(#Opt_3, 190, 25, 160, 30, "Default")
  CloseGadgetList()   ; #Cont_3   
  CheckBoxGadget(#Check_4, 20, 220, 160, 30, "#Blue")
  CheckBoxGadget(#Check_5, 20, 260, 160, 30, "#PB_Default")
  CheckBoxGadget(#Check_6, 20, 300, 160, 30, "#Yellow")
  OptionGadget(#Opt_4, 200, 220, 160, 30, "#Red")
  OptionGadget(#Opt_5, 200, 260, 160, 30, "Default")
  OptionGadget(#Opt_6, 200, 300, 160, 40, "$FF00FF")
  
  hFont = LoadFont(0, "arial", 20, #PB_Font_Bold)
  SetGadgetFont(#Opt_6, hFont)
  
  SetGadgetTextColor(#Check_1, $008000)
  SetGadgetTextColor(#Check_2, $586CC2)
  
  SetGadgetTextColor(#Check_4, #Blue)
  SetGadgetTextColor(#Check_5, #PB_Default)
  SetGadgetTextColor(#Check_6, #Yellow)
  SetGadgetTextColor(#Opt_4, #Red)
  
  SetGadgetTextColor(#Opt_6, $FF00FF)
  
  Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
EndIf

If *DrawThemeText
  UnHook(*DrawThemeText)
EndIf

CloseLibrary(0)
RASHAD
PureBasic Expert
PureBasic Expert
Posts: 4637
Joined: Sun Apr 12, 2009 6:27 am

Re: CheckBox & Option Color Theme ?

Post by RASHAD »

Stylish XP Themed Colored Option Gadget
The Easy way :)

Code: Select all

If OpenWindow(0, 0, 0, 140, 150, "OptionGadget", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
    SetWindowColor(0,$AEFEDF)
    OptionGadget(0, 30, 20, 14,20, "")
    OptionGadget(1, 30, 45, 14,20, "")
    OptionGadget(2, 30, 70, 14,20, "")
    SetGadgetState(1, 1)   ; set second option as active one
    
    TextGadget(10,44,20,70, 20, " Option 1",#SS_NOTIFY|#SS_CENTERIMAGE)
    SetGadgetColor(10,#PB_Gadget_BackColor ,$00FFFF)
    SetGadgetColor(10,#PB_Gadget_FrontColor ,$0000FF)
    
    TextGadget(11,44,45,70, 20, " Option 2",#SS_NOTIFY|#SS_CENTERIMAGE)
    SetGadgetColor(11,#PB_Gadget_BackColor ,$0000FF)
    SetGadgetColor(11,#PB_Gadget_FrontColor ,$00FFFF)
    
    TextGadget(12,44,70,70, 20, " Option 3",#SS_NOTIFY|#SS_CENTERIMAGE)
    SetGadgetColor(12,#PB_Gadget_BackColor ,$000000)
    SetGadgetColor(12,#PB_Gadget_FrontColor ,$FFFFFF)

    Repeat
      Select WaitWindowEvent()
        Case #PB_Event_CloseWindow
          Quit = 1
          
        Case #PB_Event_Gadget
          Select EventGadget()
            Case 10
              SendMessage_(GadgetID(0), #BM_CLICK, 0, 0)
            Case 11
              SendMessage_(GadgetID(1), #BM_CLICK, 0, 0)
            Case 12
              SendMessage_(GadgetID(2), #BM_CLICK, 0, 0)
              
          EndSelect
      EndSelect
    Until Quit = 1
  EndIf
Egypt my love
User avatar
ChrisR
Addict
Addict
Posts: 1127
Joined: Sun Jan 08, 2017 10:27 pm
Location: France

Re: CheckBox & Option Color Theme ?

Post by ChrisR »

Hi breeze4me,
Your DrawThemeText Color Hook is Superb and it also works for buttons.
Even if I understand a bit the hook concept, it's very far from my skills.
And even with your code as a base, I would be unable to see how it could be done or if it is possible for the theme background color.
Thanks for sharing it :)

For your 2nd code, I had already tried this workaround but just to play with it, I don't like it more than that.
breeze4me
Enthusiast
Enthusiast
Posts: 511
Joined: Thu Mar 09, 2006 9:24 am
Location: S. Kor

Re: CheckBox & Option Color Theme ?

Post by breeze4me »

This is an example of changing the background color as well. It seems that the method of the callback function is still valid for changing the background color.
Because the gadget handle is not available within My_DrawThemeText() function, a tricky way is used to distinguish the colored gadgets. So the global "gColor" variable is gone.

Edit:
Fixed bug in Array version code.
Added Map version code. It is more flexible than the array version. But it may be slow.

Edit 2:
Added a pattern brush trick. It is much better.

Code: Select all

; https://www.purebasic.fr/english/viewtopic.php?t=64746

; ====================================================================================================
; Title:        API_HookEngine Module
; Description:  With this module you can hook procedures and api in windows
; Author:       Peyman
; Version:      1.0 (02 FEB 2016) initial version
;               1.1 (07 FEB 2016) added Inject DLL
;               1.2 (11 FEB 2016) improved injector, added Eject DLL & CallRemoteFunction with parrameter
; Platform:     Windows (X64 And X86) Unicode And Ansi
; License:      Free But Any improvements to be shared with the community.
; ====================================================================================================

DeclareModule API_HookEngine
  Declare.i Hook(*OldFunctionAddress, *NewFunctionAddress)
  Declare.i UnHook(*hook_ptr)
  Declare.i ProcAddress(ModuleName$, ProcName$)
EndDeclareModule

Module API_HookEngine  
  EnableExplicit
  
  Structure opcode
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      mov.u
    CompilerElse
      mov.a
    CompilerEndIf
    addr.i
    push.a
    ret.a
  EndStructure
  
  Structure hookstruct
    addr.i
    hook.opcode
    orig.a[SizeOf(opcode)]
  EndStructure
  
  CompilerIf #PB_Compiler_Unicode
    Import "kernel32.lib"
      GetProcAddress(hModule, lpProcName.p-ascii)
    EndImport
  CompilerElse
    Import "kernel32.lib"
      GetProcAddress(hModule, lpProcName.s)
    EndImport
  CompilerEndIf
  
  Procedure.i ProcAddress(ModuleName$, ProcName$)
    Protected moduleH.i
    
    moduleH = GetModuleHandle_(ModuleName$)
    If moduleH = #Null
      moduleH = LoadLibrary_(ModuleName$)
      If moduleH = #Null
        ProcedureReturn #Null
      EndIf
    EndIf
    
    ProcedureReturn GetProcAddress(moduleH, ProcName$)
  EndProcedure
  
  Procedure Hook(*OldFunctionAddress, *NewFunctionAddress)
    Protected *hook_ptr.hookstruct
    
    If Not *OldFunctionAddress
      ProcedureReturn #Null
    EndIf
    
    *hook_ptr = AllocateMemory(SizeOf(hookstruct))
    *hook_ptr\addr = *OldFunctionAddress
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      *hook_ptr\hook\mov = $B848
    CompilerElse
      *hook_ptr\hook\mov = $B8
    CompilerEndIf
    *hook_ptr\hook\addr = *NewFunctionAddress
    *hook_ptr\hook\push = $50
    *hook_ptr\hook\ret = $C3
     
    CopyMemory(*OldFunctionAddress, @*hook_ptr\orig, SizeOf(opcode))
    If Not WriteProcessMemory_(GetCurrentProcess_(), *OldFunctionAddress, @*hook_ptr\hook, SizeOf(opcode), #Null)
      FreeMemory(*hook_ptr)
      ProcedureReturn #Null
    Else
      ProcedureReturn *hook_ptr
    EndIf
  EndProcedure
  
  Procedure.i UnHook(*hook_ptr.hookstruct)
    Protected retValue.i
    
    If *hook_ptr
      If *hook_ptr\addr
        If WriteProcessMemory_(GetCurrentProcess_(), *hook_ptr\addr, @*hook_ptr\orig, SizeOf(opcode), #Null)
          retValue = *hook_ptr\addr
          FreeMemory(*hook_ptr)
          ProcedureReturn retValue
        EndIf
      EndIf
    EndIf
    
    ProcedureReturn #Null
  EndProcedure
EndModule



UseModule API_HookEngine

EnumerationBinary
  #DTT_TEXTCOLOR       ;(1 << 0)      ;// crText has been specified
  #DTT_BORDERCOLOR     ;(1 << 1)      ;// crBorder has been specified
  #DTT_SHADOWCOLOR     ;(1 << 2)      ;// crShadow has been specified
  #DTT_SHADOWTYPE      ;(1 << 3)      ;// iTextShadowType has been specified
  #DTT_SHADOWOFFSET    ;(1 << 4)      ;// ptShadowOffset has been specified
  #DTT_BORDERSIZE      ;(1 << 5)      ;// iBorderSize has been specified
  #DTT_FONTPROP        ;(1 << 6)      ;// iFontPropId has been specified
  #DTT_COLORPROP       ;(1 << 7)      ;// iColorPropId has been specified
  #DTT_STATEID         ;(1 << 8)      ;// IStateId has been specified
  #DTT_CALCRECT        ;(1 << 9)      ;// Use pRect as and in/out parameter
  #DTT_APPLYOVERLAY    ;(1 << 10)     ;// fApplyOverlay has been specified
  #DTT_GLOWSIZE        ;(1 << 11)     ;// iGlowSize has been specified
  #DTT_CALLBACK        ;(1 << 12)     ;// pfnDrawTextCallback has been specified
  #DTT_COMPOSITED      ;(1 << 13)     ;// Draws text with antialiased alpha (needs a DIB section)
EndEnumeration

#DTT_VALIDBITS = #DTT_TEXTCOLOR | #DTT_BORDERCOLOR | #DTT_SHADOWCOLOR | #DTT_SHADOWTYPE | #DTT_SHADOWOFFSET |
                 #DTT_BORDERSIZE | #DTT_FONTPROP | #DTT_COLORPROP | #DTT_STATEID | #DTT_CALCRECT |
                 #DTT_APPLYOVERLAY | #DTT_GLOWSIZE | #DTT_COMPOSITED

#BP_RADIOBUTTON = 2
#BP_CHECKBOX = 3

Structure DTTOPTS
  dwSize.l
  dwFlags.l
  crText.l
  crBorder.l
  crShadow.l
  iTextShadowType.l
  ptShadowOffset.POINT
  iBorderSize.l
  iFontPropId.l
  iColorPropId.l
  iStateId.l
  fApplyOverlay.l
  iGlowSize.l
  *pfnDrawTextCallback
  lParam.l
EndStructure

Prototype DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, *pszText, cchText, dwTextFlags.l, *pRect, *pOptions)
Global DrawThemeTextEx.DrawThemeTextEx

Structure ColoredGadgetInfo
  FrontColor.i
  BackColor.i
  hBrushBackColor.i
EndStructure

Global MutexColoredGadget = CreateMutex()
Global NewMap ColoredGadget.ColoredGadgetInfo()

#App_BrushWidth = 2000         ;Set the value large enough in consideration of changing a gadget width.

Procedure MainWindow_Callback(hWnd, uMsg, wParam, lParam)
  Protected Gadget, Result = #PB_ProcessPureBasicEvents
  
  Select uMsg
    Case #WM_CTLCOLORSTATIC
      Gadget = GetProp_(lParam, "pb_id")
      If IsGadget(Gadget) And (GadgetType(Gadget) = #PB_GadgetType_Option Or GadgetType(Gadget) = #PB_GadgetType_CheckBox)
        LockMutex(MutexColoredGadget)
        If FindMapElement(ColoredGadget(), Str(lParam))
          SetBkMode_(wParam, #TRANSPARENT)
          Result = ColoredGadget()\hBrushBackColor
        EndIf
        UnlockMutex(MutexColoredGadget)
      EndIf
  EndSelect
  ProcedureReturn Result
EndProcedure

Procedure CreateBackgroundBrush(hwnd, BackColor)
  Protected hBrush, Img, Color
  If hwnd = 0 : ProcedureReturn 0 : EndIf
  
  If BackColor = #PB_Default
    Color = GetSysColor_(#COLOR_3DFACE)
  Else
    Color = BackColor
  EndIf
  Img = CreateImage(#PB_Any, #App_BrushWidth, 1, 24, Color)
  If Img
    If StartDrawing(ImageOutput(Img))
      ;Write the handle value in the last few bytes of the pattern brush.
      Plot(#App_BrushWidth - 1, 0, hwnd & $FFFF)
      Plot(#App_BrushWidth - 2, 0, (hwnd >> 16) & $FFFF)
      CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
        Plot(#App_BrushWidth - 3, 0, (hwnd >> 32) & $FFFF)
        Plot(#App_BrushWidth - 4, 0, (hwnd >> 48) & $FFFF)
      CompilerEndIf
      StopDrawing()
      hBrush = CreatePatternBrush_(ImageID(Img))
    EndIf
    FreeImage(Img)
  EndIf
  ProcedureReturn hBrush
EndProcedure

Procedure SetOptionCheckboxGadgetColor(Gadget, FrontColor = #PB_Default, BackColor = #PB_Default)
  Protected Result, hwnd, DummyString.s, Color, Img, hBrush
  
  If IsGadget(Gadget)
    If GadgetType(Gadget) <> #PB_GadgetType_Option And GadgetType(Gadget) <> #PB_GadgetType_CheckBox
      ProcedureReturn 0
    EndIf
    
    hwnd = GadgetID(Gadget)
    If hwnd
      SendMessage_(hwnd, #WM_SETREDRAW, 0, 0)
      LockMutex(MutexColoredGadget)
      
      Repeat
        With ColoredGadget()
          
          ;Check if the gadget already exists in the map.
          If FindMapElement(ColoredGadget(), Str(hwnd))
            
            If FrontColor = #PB_Default And BackColor = #PB_Default
              ;Remove the gadget from the map.
              DeleteObject_(\hBrushBackColor)
              DeleteMapElement(ColoredGadget())
              Result = 1
              Break
            EndIf
            
            \FrontColor = FrontColor
            If \BackColor <> BackColor
              \BackColor = BackColor
              If \hBrushBackColor
                DeleteObject_(\hBrushBackColor)
                \hBrushBackColor = 0
              EndIf
              \hBrushBackColor = CreateBackgroundBrush(hwnd, BackColor)
            EndIf
            Result = 1
            Break
          EndIf
          
          ;If not, add it to the map.
          If AddMapElement(ColoredGadget(), Str(hwnd))
            \FrontColor = FrontColor
            \BackColor = BackColor
            \hBrushBackColor = CreateBackgroundBrush(hwnd, BackColor)
            Result = 1
          EndIf
          
          Break
        EndWith
      ForEver
      
      UnlockMutex(MutexColoredGadget)
      SendMessage_(hwnd, #WM_SETREDRAW, 1, 0)
      RedrawWindow_(hwnd, 0, 0, #RDW_ERASE | #RDW_FRAME | #RDW_INVALIDATE | #RDW_ALLCHILDREN)
    EndIf
  EndIf
  ProcedureReturn Result
EndProcedure

Procedure My_DrawThemeText(hTheme, hdc, iPartId, iStateId, *pszText, cchText, dwTextFlags, dwTextFlags2, *pRect)
  Protected opt.DTTOPTS\dwSize = SizeOf(DTTOPTS)
  Protected hBrush, BrushInfo.LOGBRUSH, hdcTemp, rt.RECT, hBitmap, old, hwnd
  
  If iPartId = #BP_RADIOBUTTON Or iPartId = #BP_CHECKBOX   ;checkbox or option gadget.
    
    hBrush = GetCurrentObject_(hdc, #OBJ_BRUSH)
    If hBrush
      If GetObject_(hBrush, SizeOf(LOGBRUSH), @BrushInfo)
        If BrushInfo\lbStyle = #BS_PATTERN
          hdcTemp = CreateCompatibleDC_(hdc)
          If hdcTemp
            hBitmap = CreateCompatibleBitmap_(hdc, #App_BrushWidth, 1)
            If hBitmap
              old = SelectObject_(hdcTemp, hBitmap)
              rt\right = #App_BrushWidth
              rt\bottom = 1
              FillRect_(hdcTemp, rt, hBrush)
              CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
                hwnd = (GetPixel_(hdcTemp, #App_BrushWidth - 1, 0) & $FFFF) | ((GetPixel_(hdcTemp, #App_BrushWidth - 2, 0) & $FFFF) << 16) |
                       ((GetPixel_(hdcTemp, #App_BrushWidth - 3, 0) & $FFFF) << 32) | ((GetPixel_(hdcTemp, #App_BrushWidth - 4, 0) & $FFFF) << 48)
              CompilerElse
                hwnd = (GetPixel_(hdcTemp, #App_BrushWidth - 1, 0) & $FFFF) | ((GetPixel_(hdcTemp, #App_BrushWidth - 2, 0) & $FFFF) << 16)
              CompilerEndIf
              LockMutex(MutexColoredGadget)
              If FindMapElement(ColoredGadget(), Str(hwnd))
                If ColoredGadget()\FrontColor <> #PB_Default
                  opt\dwFlags = #DTT_TEXTCOLOR
                  opt\crText = ColoredGadget()\FrontColor
                EndIf
              EndIf
              UnlockMutex(MutexColoredGadget)
              DeleteObject_(SelectObject_(hdcTemp, old))
            EndIf
            DeleteDC_(hdcTemp)
          EndIf
        EndIf
      EndIf
    EndIf
    
  EndIf
  ProcedureReturn DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, *pszText, cchText, dwTextFlags, *pRect, @opt)
EndProcedure


If OpenLibrary(0, "UxTheme.dll")
  DrawThemeTextEx = GetFunction(0, "DrawThemeTextEx")   ;There is no DrawThemeTextEx in Windows XP, so this method is not available.
EndIf

If DrawThemeTextEx
  *DrawThemeText = Hook(ProcAddress("UxTheme.dll", "DrawThemeText"), @My_DrawThemeText())
EndIf

Enumeration Window
  #MainWindow
EndEnumeration

Enumeration Gadgets
  #Check_1
  #Opt_1
  #Cont_2
  #Txt_2
  #Check_2
  #Opt_2
  #Cont_3
  #Txt_3
  #Check_3
  #Opt_3
  #Check_4
  #Opt_4
  #Check_5
  #Opt_5
  #Check_6
  #Opt_6
EndEnumeration

If OpenWindow(#MainWindow, 0, 0, 400, 350, "Check & Option Color", #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_ScreenCentered)
  SetWindowColor(#MainWindow, RGB(54, 54, 54))
  
  CheckBoxGadget(#Check_1, 20, 20, 160, 30, "$008000/#Yellow")
  OptionGadget(#Opt_1, 200, 20, 160, 30, "Default")
  ContainerGadget(#Cont_2, 10, 60, 370, 70, #PB_Container_Flat)
    SetGadgetColor(#Cont_2, #PB_Gadget_BackColor, RGB(128, 128, 128))
    TextGadget(#Txt_2, 5, 5, 160, 20, "Container_1")
    SetGadgetColor(#Txt_2, #PB_Gadget_BackColor, GetGadgetColor(#Cont_2, #PB_Gadget_BackColor)) 
    CheckBoxGadget(#Check_2, 10, 25, 160, 30, "$586CC2/$70B0FB")
    OptionGadget(#Opt_2, 190, 25, 160, 30, "#PB_Default/$3E8479")
  CloseGadgetList()   ; #Cont_2
  ContainerGadget(#Cont_3, 10, 140, 370, 70, #PB_Container_Flat)
    SetGadgetColor(#Cont_3, #PB_Gadget_BackColor, RGB(23, 23, 23))
    TextGadget(#Txt_3, 5, 5, 160, 20, "Container_2")
    SetGadgetColor(#Txt_3, #PB_Gadget_BackColor, GetGadgetColor(#Cont_3, #PB_Gadget_BackColor))
    SetGadgetColor(#Txt_3, #PB_Gadget_FrontColor, #White)
    CheckBoxGadget(#Check_3, 10, 25, 160, 30, "Same text, Diff color")
    OptionGadget(#Opt_3, 190, 25, 160, 30, "Same text, Diff color")
  CloseGadgetList()   ; #Cont_3   
  CheckBoxGadget(#Check_4, 20, 220, 160, 30, "Default")
  CheckBoxGadget(#Check_5, 20, 260, 160, 30, "#PB_Default/#Cyan")
  CheckBoxGadget(#Check_6, 20, 300, 160, 30, "#Yellow/#Black")
  OptionGadget(#Opt_4, 200, 220, 160, 30, "#Red/#Green")
  OptionGadget(#Opt_5, 200, 260, 160, 30, "#Blue/Default")
  OptionGadget(#Opt_6, 200, 300, 270, 40, "$FF00FF/$DE23A9")
  
  hFont = LoadFont(0, "arial", 20, #PB_Font_Bold)
  SetGadgetFont(#Opt_6, hFont)
  
  SetOptionCheckboxGadgetColor(#Check_1, $008000, #Yellow)
  SetOptionCheckboxGadgetColor(#Check_2, $586CC2, $70B0FB)
  SetOptionCheckboxGadgetColor(#Opt_2, #PB_Default, $3E8479)
  SetOptionCheckboxGadgetColor(#Opt_3, #PB_Default, $2C5428)
  SetOptionCheckboxGadgetColor(#Check_3, #Magenta)
  SetOptionCheckboxGadgetColor(#Opt_5, #Blue)
  SetOptionCheckboxGadgetColor(#Check_5, #PB_Default, #Cyan)
  SetOptionCheckboxGadgetColor(#Check_6, #Yellow, #Black)
  SetOptionCheckboxGadgetColor(#Opt_4, #Red, #Green)
  SetOptionCheckboxGadgetColor(#Opt_6, $FF00FF, $DE23A9)
  
  ;SetOptionCheckboxGadgetColor(#Opt_6)  ;Remove color settings from the gadget.
  
  SetWindowCallback(@MainWindow_Callback(), #MainWindow)
  
  Repeat
    e = WaitWindowEvent()
;     If e = #PB_Event_Gadget And EventGadget() = #Check_6
;       DisableGadget(#Opt_6, GetGadgetState(#Check_6))
;       If GetGadgetState(#Check_6)
;         SetOptionCheckboxGadgetColor(#Opt_6, #PB_Default, $DE23A9)
;       Else
;         SetOptionCheckboxGadgetColor(#Opt_6, $FF00FF, $DE23A9)
;       EndIf
;       
;     EndIf
  Until e = #PB_Event_CloseWindow
EndIf

If *DrawThemeText
  UnHook(*DrawThemeText)
EndIf

CloseLibrary(0)

ForEach ColoredGadget()
  DeleteObject_(ColoredGadget()\hBrushBackColor)
Next
Map version.

Code: Select all

; https://www.purebasic.fr/english/viewtopic.php?t=64746

; ====================================================================================================
; Title:        API_HookEngine Module
; Description:  With this module you can hook procedures and api in windows
; Author:       Peyman
; Version:      1.0 (02 FEB 2016) initial version
;               1.1 (07 FEB 2016) added Inject DLL
;               1.2 (11 FEB 2016) improved injector, added Eject DLL & CallRemoteFunction with parrameter
; Platform:     Windows (X64 And X86) Unicode And Ansi
; License:      Free But Any improvements to be shared with the community.
; ====================================================================================================

DeclareModule API_HookEngine
  Declare.i Hook(*OldFunctionAddress, *NewFunctionAddress)
  Declare.i UnHook(*hook_ptr)
  Declare.i ProcAddress(ModuleName$, ProcName$)
EndDeclareModule

Module API_HookEngine  
  EnableExplicit
  
  Structure opcode
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      mov.u
    CompilerElse
      mov.a
    CompilerEndIf
    addr.i
    push.a
    ret.a
  EndStructure
  
  Structure hookstruct
    addr.i
    hook.opcode
    orig.a[SizeOf(opcode)]
  EndStructure
  
  CompilerIf #PB_Compiler_Unicode
    Import "kernel32.lib"
      GetProcAddress(hModule, lpProcName.p-ascii)
    EndImport
  CompilerElse
    Import "kernel32.lib"
      GetProcAddress(hModule, lpProcName.s)
    EndImport
  CompilerEndIf
  
  Procedure.i ProcAddress(ModuleName$, ProcName$)
    Protected moduleH.i
    
    moduleH = GetModuleHandle_(ModuleName$)
    If moduleH = #Null
      moduleH = LoadLibrary_(ModuleName$)
      If moduleH = #Null
        ProcedureReturn #Null
      EndIf
    EndIf
    
    ProcedureReturn GetProcAddress(moduleH, ProcName$)
  EndProcedure
  
  Procedure Hook(*OldFunctionAddress, *NewFunctionAddress)
    Protected *hook_ptr.hookstruct
    
    If Not *OldFunctionAddress
      ProcedureReturn #Null
    EndIf
    
    *hook_ptr = AllocateMemory(SizeOf(hookstruct))
    *hook_ptr\addr = *OldFunctionAddress
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      *hook_ptr\hook\mov = $B848
    CompilerElse
      *hook_ptr\hook\mov = $B8
    CompilerEndIf
    *hook_ptr\hook\addr = *NewFunctionAddress
    *hook_ptr\hook\push = $50
    *hook_ptr\hook\ret = $C3
     
    CopyMemory(*OldFunctionAddress, @*hook_ptr\orig, SizeOf(opcode))
    If Not WriteProcessMemory_(GetCurrentProcess_(), *OldFunctionAddress, @*hook_ptr\hook, SizeOf(opcode), #Null)
      FreeMemory(*hook_ptr)
      ProcedureReturn #Null
    Else
      ProcedureReturn *hook_ptr
    EndIf
  EndProcedure
  
  Procedure.i UnHook(*hook_ptr.hookstruct)
    Protected retValue.i
    
    If *hook_ptr
      If *hook_ptr\addr
        If WriteProcessMemory_(GetCurrentProcess_(), *hook_ptr\addr, @*hook_ptr\orig, SizeOf(opcode), #Null)
          retValue = *hook_ptr\addr
          FreeMemory(*hook_ptr)
          ProcedureReturn retValue
        EndIf
      EndIf
    EndIf
    
    ProcedureReturn #Null
  EndProcedure
EndModule



UseModule API_HookEngine

EnumerationBinary
  #DTT_TEXTCOLOR       ;(1 << 0)      ;// crText has been specified
  #DTT_BORDERCOLOR     ;(1 << 1)      ;// crBorder has been specified
  #DTT_SHADOWCOLOR     ;(1 << 2)      ;// crShadow has been specified
  #DTT_SHADOWTYPE      ;(1 << 3)      ;// iTextShadowType has been specified
  #DTT_SHADOWOFFSET    ;(1 << 4)      ;// ptShadowOffset has been specified
  #DTT_BORDERSIZE      ;(1 << 5)      ;// iBorderSize has been specified
  #DTT_FONTPROP        ;(1 << 6)      ;// iFontPropId has been specified
  #DTT_COLORPROP       ;(1 << 7)      ;// iColorPropId has been specified
  #DTT_STATEID         ;(1 << 8)      ;// IStateId has been specified
  #DTT_CALCRECT        ;(1 << 9)      ;// Use pRect as and in/out parameter
  #DTT_APPLYOVERLAY    ;(1 << 10)     ;// fApplyOverlay has been specified
  #DTT_GLOWSIZE        ;(1 << 11)     ;// iGlowSize has been specified
  #DTT_CALLBACK        ;(1 << 12)     ;// pfnDrawTextCallback has been specified
  #DTT_COMPOSITED      ;(1 << 13)     ;// Draws text with antialiased alpha (needs a DIB section)
EndEnumeration

#DTT_VALIDBITS = #DTT_TEXTCOLOR | #DTT_BORDERCOLOR | #DTT_SHADOWCOLOR | #DTT_SHADOWTYPE | #DTT_SHADOWOFFSET |
                 #DTT_BORDERSIZE | #DTT_FONTPROP | #DTT_COLORPROP | #DTT_STATEID | #DTT_CALCRECT |
                 #DTT_APPLYOVERLAY | #DTT_GLOWSIZE | #DTT_COMPOSITED

Structure DTTOPTS
  dwSize.l
  dwFlags.l
  crText.l
  crBorder.l
  crShadow.l
  iTextShadowType.l
  ptShadowOffset.POINT
  iBorderSize.l
  iFontPropId.l
  iColorPropId.l
  iStateId.l
  fApplyOverlay.l
  iGlowSize.l
  *pfnDrawTextCallback
  lParam.l
EndStructure

Global MutexColoredGadget = CreateMutex()

#BP_RADIOBUTTON = 2
#BP_CHECKBOX = 3

Structure ColoredGadgetInfo
  Gadget.i
  FrontColor.i
  BackColor.i
  hBrushBackColor.i
EndStructure

Global NewMap ColoredGadget.ColoredGadgetInfo()

Prototype DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, *pszText, cchText, dwTextFlags.l, *pRect, *pOptions)

Global DrawThemeTextEx.DrawThemeTextEx

Procedure MainWindow_Callback(hWnd, uMsg, wParam, lParam)
  Protected Gadget, Result = #PB_ProcessPureBasicEvents
  
  Select uMsg
    Case #WM_CTLCOLORSTATIC
      Gadget = GetProp_(lParam, "pb_id")
      If IsGadget(Gadget) And (GadgetType(Gadget) = #PB_GadgetType_Option Or GadgetType(Gadget) = #PB_GadgetType_CheckBox)
        LockMutex(MutexColoredGadget)
        ForEach ColoredGadget()
          With ColoredGadget()
            If \Gadget = Gadget
              If \BackColor <> #PB_Default
                Result = \hBrushBackColor
                SetBkMode_(wParam, #TRANSPARENT)
              EndIf
              Break
            EndIf
          EndWith
        Next
        UnlockMutex(MutexColoredGadget)
      EndIf
      
  EndSelect
  ProcedureReturn Result
EndProcedure

Procedure RemoveColoredGadget(Gadget)    ;Remove a gadget from the map.
  Protected hwnd
  
  If IsGadget(Gadget)
    hwnd = GadgetID(Gadget)
    If hwnd
      SendMessage_(hwnd, #WM_SETREDRAW, 0, 0)
      LockMutex(MutexColoredGadget)
      
      ForEach ColoredGadget()
        With ColoredGadget()
          If \Gadget = Gadget
            SetGadgetText(Gadget, RTrim(GetGadgetText(Gadget), Chr($200B))) ;recover the original string.
            DeleteObject_(\hBrushBackColor)
            DeleteMapElement(ColoredGadget())
            Break
          EndIf
        EndWith
      Next
      
      UnlockMutex(MutexColoredGadget)
      SendMessage_(hwnd, #WM_SETREDRAW, 1, 0)
      RedrawWindow_(hwnd, 0, 0, #RDW_ERASE | #RDW_FRAME | #RDW_INVALIDATE | #RDW_ALLCHILDREN)
    EndIf
  EndIf
EndProcedure

Procedure SetOptionCheckboxGadgetColor(Gadget, FrontColor, BackColor = #PB_Default)
  Protected Result, hwnd, DummyString.s
  Static MaxIndex
  
  If IsGadget(Gadget)
    If GadgetType(Gadget) <> #PB_GadgetType_Option And GadgetType(Gadget) <> #PB_GadgetType_CheckBox
      ProcedureReturn 0
    EndIf
    hwnd = GadgetID(Gadget)
    If hwnd
      ;Check if the gadget already exists in the array
      SendMessage_(hwnd, #WM_SETREDRAW, 0, 0)
      LockMutex(MutexColoredGadget)
      
      ForEach ColoredGadget()
        With ColoredGadget()
          If \Gadget = Gadget
            \FrontColor = FrontColor
            If \BackColor <> BackColor
              \BackColor = BackColor
              If \hBrushBackColor
                DeleteObject_(\hBrushBackColor)
                \hBrushBackColor = 0
              EndIf
              If BackColor <> #PB_Default
                \hBrushBackColor = CreateSolidBrush_(BackColor)
              EndIf
            EndIf
            
            UnlockMutex(MutexColoredGadget)
            SendMessage_(hwnd, #WM_SETREDRAW, 1, 0)
            RedrawWindow_(hwnd, 0, 0, #RDW_ERASE | #RDW_FRAME | #RDW_INVALIDATE | #RDW_ALLCHILDREN)
            ProcedureReturn 1
          EndIf
        EndWith
      Next
      
      ;If not, add to map
      MaxIndex + 1
      
      If AddMapElement(ColoredGadget(), Str(MaxIndex))
        
        ; https://en.wikipedia.org/wiki/Zero-width_space
        
        DummyString = Space(MaxIndex)
        If DummyString
          FillMemory(@DummyString, MaxIndex * SizeOf(Character), $200B, #PB_Unicode)
          
          ;SetGadgetText(Gadget, RTrim(GetGadgetText(Gadget), Chr($200B)) + DummyString)
          SetGadgetText(Gadget, GetGadgetText(Gadget) + DummyString)  ;Add the above string consisting of Zero-width spaces after an existing string as a marker.
          
          ColoredGadget()\Gadget = Gadget
          ColoredGadget()\FrontColor = FrontColor
          ColoredGadget()\BackColor = BackColor
          If BackColor <> #PB_Default
            ColoredGadget()\hBrushBackColor = CreateSolidBrush_(BackColor)
          EndIf
          
          Result = 1
        Else
          DeleteMapElement(ColoredGadget())  ;if failed.
        EndIf
      EndIf
      
      UnlockMutex(MutexColoredGadget)
      SendMessage_(hwnd, #WM_SETREDRAW, 1, 0)
      RedrawWindow_(hwnd, 0, 0, #RDW_ERASE | #RDW_FRAME | #RDW_INVALIDATE | #RDW_ALLCHILDREN)
    EndIf
  EndIf
  ProcedureReturn Result
EndProcedure

Procedure My_DrawThemeText(hTheme, hdc, iPartId, iStateId, *pszText, cchText, dwTextFlags, dwTextFlags2, *pRect)
  Protected opt.DTTOPTS\dwSize = SizeOf(DTTOPTS)
  Protected Text.s, Index
  
  If iPartId = #BP_RADIOBUTTON Or iPartId = #BP_CHECKBOX   ;checkbox or option gadget.
    LockMutex(MutexColoredGadget)
    If *pszText
      Text = PeekS(*pszText)
      If Text
        Index = CountString(Text, Chr($200B))
        If Index > 0
          If FindMapElement(ColoredGadget(), Str(Index))
            If ColoredGadget()\FrontColor <> #PB_Default
              opt\dwFlags = #DTT_TEXTCOLOR
              opt\crText = ColoredGadget()\FrontColor
            EndIf
          EndIf
        EndIf
      EndIf
    EndIf
    UnlockMutex(MutexColoredGadget)
  EndIf
  
  ProcedureReturn DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, *pszText, cchText, dwTextFlags, *pRect, @opt)
EndProcedure


If OpenLibrary(0, "UxTheme.dll")
  DrawThemeTextEx = GetFunction(0, "DrawThemeTextEx")   ;There is no DrawThemeTextEx in Windows XP, so this method is not available.
EndIf

If DrawThemeTextEx
  *DrawThemeText = Hook(ProcAddress("UxTheme.dll", "DrawThemeText"), @My_DrawThemeText())
EndIf

Enumeration Window
  #MainWindow
EndEnumeration

Enumeration Gadgets
  #Check_1
  #Opt_1
  #Cont_2
  #Txt_2
  #Check_2
  #Opt_2
  #Cont_3
  #Txt_3
  #Check_3
  #Opt_3
  #Check_4
  #Opt_4
  #Check_5
  #Opt_5
  #Check_6
  #Opt_6
EndEnumeration

If OpenWindow(#MainWindow, 0, 0, 400, 350, "Check & Option Color", #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_ScreenCentered)
  SetWindowColor(#MainWindow, RGB(54, 54, 54))
  
  CheckBoxGadget(#Check_1, 20, 20, 160, 30, "$008000/#Yellow")
  OptionGadget(#Opt_1, 200, 20, 160, 30, "Default")
  ContainerGadget(#Cont_2, 10, 60, 370, 70, #PB_Container_Flat)
    SetGadgetColor(#Cont_2, #PB_Gadget_BackColor, RGB(128, 128, 128))
    TextGadget(#Txt_2, 5, 5, 160, 20, "Container_1")
    SetGadgetColor(#Txt_2, #PB_Gadget_BackColor, GetGadgetColor(#Cont_2, #PB_Gadget_BackColor)) 
    CheckBoxGadget(#Check_2, 10, 25, 160, 30, "$586CC2/$70B0FB")
    OptionGadget(#Opt_2, 190, 25, 160, 30, "#PB_Default/$3E8479")
  CloseGadgetList()   ; #Cont_2
  ContainerGadget(#Cont_3, 10, 140, 370, 70, #PB_Container_Flat)
    SetGadgetColor(#Cont_3, #PB_Gadget_BackColor, RGB(23, 23, 23))
    TextGadget(#Txt_3, 5, 5, 160, 20, "Container_2")
    SetGadgetColor(#Txt_3, #PB_Gadget_BackColor, GetGadgetColor(#Cont_3, #PB_Gadget_BackColor))
    SetGadgetColor(#Txt_3, #PB_Gadget_FrontColor, #White)
    CheckBoxGadget(#Check_3, 10, 25, 160, 30, "Same text, Diff color")
    OptionGadget(#Opt_3, 190, 25, 160, 30, "Same text, Diff color")
  CloseGadgetList()   ; #Cont_3   
  CheckBoxGadget(#Check_4, 20, 220, 160, 30, "Default")
  CheckBoxGadget(#Check_5, 20, 260, 160, 30, "#PB_Default/#Cyan")
  CheckBoxGadget(#Check_6, 20, 300, 160, 30, "#Yellow/#Black")
  OptionGadget(#Opt_4, 200, 220, 160, 30, "#Red/#Green")
  OptionGadget(#Opt_5, 200, 260, 160, 30, "#Blue/Default")
  OptionGadget(#Opt_6, 200, 300, 270, 40, "$FF00FF/$DE23A9")
  
  hFont = LoadFont(0, "arial", 20, #PB_Font_Bold)
  SetGadgetFont(#Opt_6, hFont)
  
  SetOptionCheckboxGadgetColor(#Check_1, $008000, #Yellow)
  SetOptionCheckboxGadgetColor(#Check_2, $586CC2, $70B0FB)
  SetOptionCheckboxGadgetColor(#Opt_2, #PB_Default, $3E8479)
  SetOptionCheckboxGadgetColor(#Opt_3, #PB_Default, $2C5428)
  SetOptionCheckboxGadgetColor(#Check_3, #Magenta)
  SetOptionCheckboxGadgetColor(#Opt_5, #Blue)
  SetOptionCheckboxGadgetColor(#Check_5, #PB_Default, #Cyan)
  SetOptionCheckboxGadgetColor(#Check_6, #Yellow, #Black)
  SetOptionCheckboxGadgetColor(#Opt_4, #Red, #Green)
  SetOptionCheckboxGadgetColor(#Opt_6, $FF00FF, $DE23A9)
  
  SetWindowCallback(@MainWindow_Callback(), #MainWindow)
  
  Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
EndIf

If *DrawThemeText
  UnHook(*DrawThemeText)
EndIf

CloseLibrary(0)

ForEach ColoredGadget()
  DeleteObject_(ColoredGadget()\hBrushBackColor)
Next


Array version.

Code: Select all

; https://www.purebasic.fr/english/viewtopic.php?t=64746

; ====================================================================================================
; Title:        API_HookEngine Module
; Description:  With this module you can hook procedures and api in windows
; Author:       Peyman
; Version:      1.0 (02 FEB 2016) initial version
;               1.1 (07 FEB 2016) added Inject DLL
;               1.2 (11 FEB 2016) improved injector, added Eject DLL & CallRemoteFunction with parrameter
; Platform:     Windows (X64 And X86) Unicode And Ansi
; License:      Free But Any improvements to be shared with the community.
; ====================================================================================================

DeclareModule API_HookEngine
  Declare.i Hook(*OldFunctionAddress, *NewFunctionAddress)
  Declare.i UnHook(*hook_ptr)
  Declare.i ProcAddress(ModuleName$, ProcName$)
EndDeclareModule

Module API_HookEngine  
  EnableExplicit
  
  Structure opcode
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      mov.u
    CompilerElse
      mov.a
    CompilerEndIf
    addr.i
    push.a
    ret.a
  EndStructure
  
  Structure hookstruct
    addr.i
    hook.opcode
    orig.a[SizeOf(opcode)]
  EndStructure
  
  CompilerIf #PB_Compiler_Unicode
    Import "kernel32.lib"
      GetProcAddress(hModule, lpProcName.p-ascii)
    EndImport
  CompilerElse
    Import "kernel32.lib"
      GetProcAddress(hModule, lpProcName.s)
    EndImport
  CompilerEndIf
  
  Procedure.i ProcAddress(ModuleName$, ProcName$)
    Protected moduleH.i
    
    moduleH = GetModuleHandle_(ModuleName$)
    If moduleH = #Null
      moduleH = LoadLibrary_(ModuleName$)
      If moduleH = #Null
        ProcedureReturn #Null
      EndIf
    EndIf
    
    ProcedureReturn GetProcAddress(moduleH, ProcName$)
  EndProcedure
  
  Procedure Hook(*OldFunctionAddress, *NewFunctionAddress)
    Protected *hook_ptr.hookstruct
    
    If Not *OldFunctionAddress
      ProcedureReturn #Null
    EndIf
    
    *hook_ptr = AllocateMemory(SizeOf(hookstruct))
    *hook_ptr\addr = *OldFunctionAddress
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      *hook_ptr\hook\mov = $B848
    CompilerElse
      *hook_ptr\hook\mov = $B8
    CompilerEndIf
    *hook_ptr\hook\addr = *NewFunctionAddress
    *hook_ptr\hook\push = $50
    *hook_ptr\hook\ret = $C3
     
    CopyMemory(*OldFunctionAddress, @*hook_ptr\orig, SizeOf(opcode))
    If Not WriteProcessMemory_(GetCurrentProcess_(), *OldFunctionAddress, @*hook_ptr\hook, SizeOf(opcode), #Null)
      FreeMemory(*hook_ptr)
      ProcedureReturn #Null
    Else
      ProcedureReturn *hook_ptr
    EndIf
  EndProcedure
  
  Procedure.i UnHook(*hook_ptr.hookstruct)
    Protected retValue.i
    
    If *hook_ptr
      If *hook_ptr\addr
        If WriteProcessMemory_(GetCurrentProcess_(), *hook_ptr\addr, @*hook_ptr\orig, SizeOf(opcode), #Null)
          retValue = *hook_ptr\addr
          FreeMemory(*hook_ptr)
          ProcedureReturn retValue
        EndIf
      EndIf
    EndIf
    
    ProcedureReturn #Null
  EndProcedure
EndModule



UseModule API_HookEngine

EnumerationBinary
  #DTT_TEXTCOLOR       ;(1 << 0)      ;// crText has been specified
  #DTT_BORDERCOLOR     ;(1 << 1)      ;// crBorder has been specified
  #DTT_SHADOWCOLOR     ;(1 << 2)      ;// crShadow has been specified
  #DTT_SHADOWTYPE      ;(1 << 3)      ;// iTextShadowType has been specified
  #DTT_SHADOWOFFSET    ;(1 << 4)      ;// ptShadowOffset has been specified
  #DTT_BORDERSIZE      ;(1 << 5)      ;// iBorderSize has been specified
  #DTT_FONTPROP        ;(1 << 6)      ;// iFontPropId has been specified
  #DTT_COLORPROP       ;(1 << 7)      ;// iColorPropId has been specified
  #DTT_STATEID         ;(1 << 8)      ;// IStateId has been specified
  #DTT_CALCRECT        ;(1 << 9)      ;// Use pRect as and in/out parameter
  #DTT_APPLYOVERLAY    ;(1 << 10)     ;// fApplyOverlay has been specified
  #DTT_GLOWSIZE        ;(1 << 11)     ;// iGlowSize has been specified
  #DTT_CALLBACK        ;(1 << 12)     ;// pfnDrawTextCallback has been specified
  #DTT_COMPOSITED      ;(1 << 13)     ;// Draws text with antialiased alpha (needs a DIB section)
EndEnumeration

#DTT_VALIDBITS = #DTT_TEXTCOLOR | #DTT_BORDERCOLOR | #DTT_SHADOWCOLOR | #DTT_SHADOWTYPE | #DTT_SHADOWOFFSET |
                 #DTT_BORDERSIZE | #DTT_FONTPROP | #DTT_COLORPROP | #DTT_STATEID | #DTT_CALCRECT |
                 #DTT_APPLYOVERLAY | #DTT_GLOWSIZE | #DTT_COMPOSITED

Structure DTTOPTS
  dwSize.l
  dwFlags.l
  crText.l
  crBorder.l
  crShadow.l
  iTextShadowType.l
  ptShadowOffset.POINT
  iBorderSize.l
  iFontPropId.l
  iColorPropId.l
  iStateId.l
  fApplyOverlay.l
  iGlowSize.l
  *pfnDrawTextCallback
  lParam.l
EndStructure

Global MutexColoredGadget = CreateMutex()

#BP_RADIOBUTTON = 2
#BP_CHECKBOX = 3

Structure ColoredGadgetInfo
  Gadget.i
  FrontColor.i
  BackColor.i
  hBrushBackColor.i
EndStructure

Global Dim ColoredGadget.ColoredGadgetInfo(0)

Prototype DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, *pszText, cchText, dwTextFlags.l, *pRect, *pOptions)

Global DrawThemeTextEx.DrawThemeTextEx

Procedure MainWindow_Callback(hWnd, uMsg, wParam, lParam)
  Protected i, Max, Gadget, Result = #PB_ProcessPureBasicEvents
  
  Select uMsg
    Case #WM_CTLCOLORSTATIC
      Gadget = GetProp_(lParam, "pb_id")
      If IsGadget(Gadget) And (GadgetType(Gadget) = #PB_GadgetType_Option Or GadgetType(Gadget) = #PB_GadgetType_CheckBox)
        LockMutex(MutexColoredGadget)
        Max = ArraySize(ColoredGadget())
        For i = 0 To Max
          If ColoredGadget(i)\Gadget = Gadget
            If ColoredGadget(i)\BackColor <> #PB_Default
              Result = ColoredGadget(i)\hBrushBackColor
              SetBkMode_(wParam, #TRANSPARENT)
            EndIf
            Break
          EndIf
        Next
        UnlockMutex(MutexColoredGadget)
      EndIf
      
  EndSelect
  ProcedureReturn Result
EndProcedure

Procedure SetOptionCheckboxGadgetColor(Gadget, FrontColor, BackColor = #PB_Default)
  Protected Result, hwnd, i, DummyString.s
  Static MaxIndex = -1
  
  If IsGadget(Gadget)
    If GadgetType(Gadget) <> #PB_GadgetType_Option And GadgetType(Gadget) <> #PB_GadgetType_CheckBox
      ProcedureReturn 0
    EndIf
    hwnd = GadgetID(Gadget)
    If hwnd
      ;Check if the gadget already exists in the array
      SendMessage_(hwnd, #WM_SETREDRAW, 0, 0)
      LockMutex(MutexColoredGadget)
      For i = 0 To MaxIndex
        If ColoredGadget(i)\Gadget = Gadget
          ColoredGadget(i)\FrontColor = FrontColor
          If ColoredGadget(i)\BackColor <> BackColor
            ColoredGadget(i)\BackColor = BackColor
            If ColoredGadget(i)\hBrushBackColor
              DeleteObject_(ColoredGadget(i)\hBrushBackColor)
              ColoredGadget(i)\hBrushBackColor = 0
            EndIf
            If BackColor <> #PB_Default
              ColoredGadget(i)\hBrushBackColor = CreateSolidBrush_(BackColor)
            EndIf
          EndIf
          
          UnlockMutex(MutexColoredGadget)
          SendMessage_(hwnd, #WM_SETREDRAW, 1, 0)
          RedrawWindow_(hwnd, 0, 0, #RDW_ERASE | #RDW_FRAME | #RDW_INVALIDATE | #RDW_ALLCHILDREN)
          ProcedureReturn 1
        EndIf
      Next
      
      ;If not, add to array
      MaxIndex + 1
      ReDim ColoredGadget(MaxIndex)
      
      
      ; https://en.wikipedia.org/wiki/Zero-width_space
      
      ;array index = number of Zero-width spaces - 1
      DummyString = Space(MaxIndex + 1)
      If DummyString
        FillMemory(@DummyString, StringByteLength(DummyString), $200B, #PB_Unicode)
        
        ;SetGadgetText(Gadget, RTrim(GetGadgetText(Gadget), Chr($200B)) + DummyString)
        SetGadgetText(Gadget, GetGadgetText(Gadget) + DummyString)  ;Add the above string consisting of Zero-width spaces after an existing string as a marker.
        
        ColoredGadget(MaxIndex)\Gadget = Gadget
        ColoredGadget(MaxIndex)\FrontColor = FrontColor
        ColoredGadget(MaxIndex)\BackColor = BackColor
        If BackColor <> #PB_Default
          ColoredGadget(MaxIndex)\hBrushBackColor = CreateSolidBrush_(BackColor)
        EndIf
        
        Result = 1
      EndIf
      
      UnlockMutex(MutexColoredGadget)
      SendMessage_(hwnd, #WM_SETREDRAW, 1, 0)
      RedrawWindow_(hwnd, 0, 0, #RDW_ERASE | #RDW_FRAME | #RDW_INVALIDATE | #RDW_ALLCHILDREN)
    EndIf
  EndIf
  ProcedureReturn Result
EndProcedure

Procedure My_DrawThemeText(hTheme, hdc, iPartId, iStateId, *pszText, cchText, dwTextFlags, dwTextFlags2, *pRect)
  Protected opt.DTTOPTS\dwSize = SizeOf(DTTOPTS)
  Protected Text.s, Index
  
  If iPartId = #BP_RADIOBUTTON Or iPartId = #BP_CHECKBOX   ;checkbox or option gadget.
    LockMutex(MutexColoredGadget)
    If *pszText
      Text = PeekS(*pszText)
      If Text
        ;array index = number of Zero-width spaces - 1
        Index = CountString(Text, Chr($200B)) - 1
        If Index >= 0
          If ColoredGadget(Index)\FrontColor <> #PB_Default
            opt\dwFlags = #DTT_TEXTCOLOR
            opt\crText = ColoredGadget(Index)\FrontColor
          EndIf
        EndIf
      EndIf
    EndIf
    UnlockMutex(MutexColoredGadget)
  EndIf
  
  ProcedureReturn DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, *pszText, cchText, dwTextFlags, *pRect, @opt)
EndProcedure


If OpenLibrary(0, "UxTheme.dll")
  DrawThemeTextEx = GetFunction(0, "DrawThemeTextEx")   ;There is no DrawThemeTextEx in Windows XP, so this method is not available.
EndIf

If DrawThemeTextEx
  *DrawThemeText = Hook(ProcAddress("UxTheme.dll", "DrawThemeText"), @My_DrawThemeText())
EndIf

Enumeration Window
  #MainWindow
EndEnumeration

Enumeration Gadgets
  #Check_1
  #Opt_1
  #Cont_2
  #Txt_2
  #Check_2
  #Opt_2
  #Cont_3
  #Txt_3
  #Check_3
  #Opt_3
  #Check_4
  #Opt_4
  #Check_5
  #Opt_5
  #Check_6
  #Opt_6
EndEnumeration

If OpenWindow(#MainWindow, 0, 0, 400, 350, "Check & Option Color", #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_ScreenCentered)
  SetWindowColor(#MainWindow, RGB(54, 54, 54))
  
  CheckBoxGadget(#Check_1, 20, 20, 160, 30, "$008000/#Yellow")
  OptionGadget(#Opt_1, 200, 20, 160, 30, "Default")
  ContainerGadget(#Cont_2, 10, 60, 370, 70, #PB_Container_Flat)
    SetGadgetColor(#Cont_2, #PB_Gadget_BackColor, RGB(128, 128, 128))
    TextGadget(#Txt_2, 5, 5, 160, 20, "Container_1")
    SetGadgetColor(#Txt_2, #PB_Gadget_BackColor, GetGadgetColor(#Cont_2, #PB_Gadget_BackColor)) 
    CheckBoxGadget(#Check_2, 10, 25, 160, 30, "$586CC2/$70B0FB")
    OptionGadget(#Opt_2, 190, 25, 160, 30, "#PB_Default/$3E8479")
  CloseGadgetList()   ; #Cont_2
  ContainerGadget(#Cont_3, 10, 140, 370, 70, #PB_Container_Flat)
    SetGadgetColor(#Cont_3, #PB_Gadget_BackColor, RGB(23, 23, 23))
    TextGadget(#Txt_3, 5, 5, 160, 20, "Container_2")
    SetGadgetColor(#Txt_3, #PB_Gadget_BackColor, GetGadgetColor(#Cont_3, #PB_Gadget_BackColor))
    SetGadgetColor(#Txt_3, #PB_Gadget_FrontColor, #White)
    CheckBoxGadget(#Check_3, 10, 25, 160, 30, "Same text, Diff color")
    OptionGadget(#Opt_3, 190, 25, 160, 30, "Same text, Diff color")
  CloseGadgetList()   ; #Cont_3   
  CheckBoxGadget(#Check_4, 20, 220, 160, 30, "Default")
  CheckBoxGadget(#Check_5, 20, 260, 160, 30, "#PB_Default/#Cyan")
  CheckBoxGadget(#Check_6, 20, 300, 160, 30, "#Yellow/#Black")
  OptionGadget(#Opt_4, 200, 220, 160, 30, "#Red/#Green")
  OptionGadget(#Opt_5, 200, 260, 160, 30, "#Blue/Default")
  OptionGadget(#Opt_6, 200, 300, 270, 40, "$FF00FF/$DE23A9")
  
  hFont = LoadFont(0, "arial", 20, #PB_Font_Bold)
  SetGadgetFont(#Opt_6, hFont)
  
  SetOptionCheckboxGadgetColor(#Check_1, $008000, #Yellow)
  SetOptionCheckboxGadgetColor(#Check_2, $586CC2, $70B0FB)
  SetOptionCheckboxGadgetColor(#Opt_2, #PB_Default, $3E8479)
  SetOptionCheckboxGadgetColor(#Opt_3, #PB_Default, $2C5428)
  SetOptionCheckboxGadgetColor(#Check_3, #Magenta)
  SetOptionCheckboxGadgetColor(#Opt_5, #Blue)
  SetOptionCheckboxGadgetColor(#Check_5, #PB_Default, #Cyan)
  SetOptionCheckboxGadgetColor(#Check_6, #Yellow, #Black)
  SetOptionCheckboxGadgetColor(#Opt_4, #Red, #Green)
  SetOptionCheckboxGadgetColor(#Opt_6, $FF00FF, $DE23A9)
  
  SetWindowCallback(@MainWindow_Callback(), #MainWindow)
  
  Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
EndIf

If *DrawThemeText
  UnHook(*DrawThemeText)
EndIf

CloseLibrary(0)

MaxIndex = ArraySize(ColoredGadget())
For i = 0 To MaxIndex
  DeleteObject_(ColoredGadget(i)\hBrushBackColor)
Next
Last edited by breeze4me on Fri Apr 15, 2022 12:59 pm, edited 1 time in total.
User avatar
ChrisR
Addict
Addict
Posts: 1127
Joined: Sun Jan 08, 2017 10:27 pm
Location: France

Re: CheckBox & Option Color Theme ?

Post by ChrisR »

Thanks breeze4me
I didn't realize when I wrote that the background color could be done without removing the theme.
It is still surprising that MS has not developed the possibility to change the text color, with SetTextColor API, without having to remove the theme.

I continue my code for automatic Gadget color, based on the Parent container color.
Without the hook at first, I'll see if I add it later.

In any case the theme problem on the 1st post is solved, with your hook :)
Post Reply