Results 1 to 6 of 6

Thread: Unfinished variation on a checkbox with focus rect, bold and keeps theme

  1. #1
    Join Date
    Feb 2009
    Posts
    5,467

    Default Unfinished variation on a checkbox with focus rect, bold and keeps theme

    Raveen's recent post reminded me of something I'd had a half go at some time ago

    This is most definitely INCOMPLETE and IT DOES NOT WORK FULLY

    But I just thought I would post it here in case it was of general interest and someone might want to take it forward/have a play

    The idea was to create a checkbox and dbcheckbox that has all the existing features of the out of the box ones but with the addition of a focus rectangle, a bold label option and maintain the current windows theme behaviour for a checkbox. From memory the checkbox is mostly there it is the db part that is incomplete

    Anyway here it is as is as i'm not going to be doing anything with it anytime soon

    Code:
    Use cCharTranslate.pkg
    Use Dftypes.pkg
    Use tWinStructs.pkg
    Use dfclient.pkg
    
    External_Function WINAPI_OpenThemeData "OpenThemeData" uxtheme.dll Handle hWnd Pointer pszClassList Returns Pointer
    External_Function WINAPI_CloseThemeData "CloseThemeData" uxtheme.dll Handle hWnd Returns Integer
    External_Function WINAPI_DrawThemeBackground "DrawThemeBackground" uxtheme.dll Handle hTheme Handle hHDC Integer iPartId Integer iStateId Pointer pRECT Pointer pClipRect Returns Pointer
    External_Function WINAPI_GetObject "GetObjectA" GDI32.dll Handle hgdiobj Integer iBuffer Pointer lpvObj  Returns Integer
    External_Function WINAPI_SetBkColor "SetBkColor" GDI32.dll Handle hgdiobj Integer iColorRef Returns Integer
    External_Function WINAPI_DrawFocusRect "DrawFocusRect" User32.dll Handle hDC Pointer pRect Returns Integer
    
    Define ODA_DRAWENTIRE  for 1
    Define ODA_SELECT      for 2
    Define ODA_FOCUS       for 4
    Define ODS_SELECTED    for 1
    Define ODS_GRAYED      for 2
    Define ODS_DISABLED    for 4
    Define ODS_CHECKED     for 8
    Define ODS_FOCUS       for |CI$10
    Define ODS_HOTLIGHT    for |CI$40
    Define ODS_INACTIVE    for |CI$80
    Define BP_CHECKBOX for 3
    Define CBS_UNCHECKEDNORMAL for 1
    Define CBS_UNCHECKEDHOT for 2
    Define CBS_UNCHECKEDPRESSED for 3
    Define CBS_UNCHECKEDDISABLED for 4
    Define CBS_CHECKEDNORMAL for 5
    Define CBS_CHECKEDHOT for 6
    Define CBS_CHECKEDPRESSED for 7
    Define CBS_CHECKEDDISABLED for 8
    Define BN_SETFOCUS  for  6
    Define BN_KILLFOCUS for  7
    
    Struct tdRect
        Integer iLeft 
        Integer iTop
        Integer iRight
        Integer iBottom
    End_Struct
    
    Struct tdDrawItem
        Integer iCtlType
        Integer iCtlID
        Integer iitemID
        Integer itemAction
        Integer itemState
        Handle  hwndItem
        Handle  hDC
        tdRect   rc
        Pointer pitemData
    End_Struct
    
    Struct tdTRACKMOUSEEVENT 
      DWord  cbSize
      DWord  dwFlags
      Handle hwndTrack
      DWord  dwHoverTime
    End_Struct
    
    Register_Procedure OnWmDrawItem
    Register_Procedure OnWmMouseHover
    Register_Procedure OnWmMouseLeave
    
    // https://social.msdn.microsoft.com/Forums/windowsdesktop/en-US/3570eb99-ac51-48fc-910d-d8c7fc38945a/checkbox-text-style-without-removing-theme?forum=windowsuidevelopment
    
    { DesignerClass = cDTCheckBox }
    Class cCheckBoxCustom is a cWinControl
        Import_Class_Protocol ToolTip_Support_Mixin
        Import_Class_Protocol Standard_Object_Mixin
        Import_Class_Protocol Shadow_Mixin
        Import_Class_Protocol Bitmap_Support_Mixin  
        Procedure Construct_Object
            Set External_Class_Name "cCheckBoxCustom" to "Button"        
            Forward Send Construct_Object
            Set Delegation_Mode to Delegate_To_Parent
    
            Set Window_Style    to WS_CHILD True
            Set Window_Style    to WS_TABSTOP True
            Set Window_Style    to WS_GROUP True
            Set Window_Style    to BS_CHECKBOX True
            Set Window_Style    to BS_AUTOCHECKBOX True
            Set Window_Style    to BS_OWNERDRAW True
            Set Window_Style    to BS_NOTIFY True
    
            {Visibility=Private}
            Property Boolean pbChecked False
            {Visibility=Private}
            Property Boolean pbTracking False
            {Visibility=Private}
            Property Boolean pbHover False
            { InitialValue=False Category=Appearance PropertyType=Boolean }
            Property Boolean pbShowFocus  False
            { InitialValue=False Category=Appearance PropertyType=Boolean }
            Property Boolean pbLabelBold False
            { EnumList="taRightJustify, taLeftJustify"}
            { Category=Appearance }
            Property Integer AlignmentMode taRightJustify
            {Visibility=Private}
            Property String Private.Label
            {Visibility=Private}
            Property Boolean Changed_State
            {Visibility=Private}
            Property Integer Private.Shadow_State
    
            Send Define_Standard_Object_Mixin
            Send Define_Shadow_Mixin
            Send Define_Bitmap_Support_Mixin
            Send Define_ToolTip_Support_Mixin
        End_Procedure
    
        Procedure End_Construct_Object
            Forward Send End_Construct_Object
            Set External_Message WM_DRAWITEM    to (RefProc(OnWmDrawItem))
            Set External_Message WM_MOUSEHOVER  to (RefProc(OnWmMouseHover))
            Set External_Message WM_MOUSELEAVE  to (RefProc(OnWmMouseLeave))
        End_Procedure
    
        { MethodType=Property }
        Procedure Set Label String Val
            Set Private.Label to Val
        End_Procedure
    
        { MethodType=Property }
        Function Label Returns String
            Function_Return (Private.Label(Self))
        End_Function
    
        { MethodType=Property Visibility=Private Obsolete=True }
        Procedure Set Shadow_State Integer iItem Integer iState
            Set Private.Shadow_State to iState
        End_Procedure
    
        { MethodType=Property Visibility=Private Obsolete=True }
        Function Shadow_State Integer iItem Returns Integer
            Function_Return (Private.Shadow_State(Self))
        End_Function
    
        {Visibility=Private}
        Procedure Command Integer wPara Integer lPara
           Forward Send Command wPara lPara
    
           Integer iID iNotify
    
           Move (Hi(wPara))  to iNotify
           Move (Low(wPara)) to iID
    
           Case Begin 
               Case (iNotify=BN_CLICKED)
                   Send OnBnClicked
                   Case Break
               Case (iNotify=BN_SETFOCUS)
                   Send OnSetFocus
                   Case Break
               Case (iNotify=BN_KILLFOCUS)
                   Send OnKillFocus
                   Case Break
           Case End
        End_Procedure
    
        {Visibility=Private}
        Procedure OnBnClicked
            //note don't code this in mouse up
            Set Checked_State to (not(Checked_State(Self)))
        End_Procedure
    
        {MethodType=Event}
        Procedure OnMouseMove Integer x Integer y Integer fKeys
            tdTRACKMOUSEEVENT tMe
            Integer bTracked
    
            If (not(pbTracking(Self))) Begin 
                Move (SizeOfType(tdTRACKMOUSEEVENT)) to tMe.cbSize
                Get Window_Handle to tMe.hwndTrack
                Move (TME_LEAVE ior TME_HOVER) to tMe.dwFlags
                Move 1 to tMe.dwHoverTime
                Move (TrackMouseEventEf(AddressOf(tMe)))  to bTracked
                Set pbTracking to bTracked
            End
        End_Procedure
    
        {MethodType=Event}
        Procedure OnWmMouseHover Integer wParam Integer lParam
            Set pbHover to True
            Send Repaint
        End_Procedure  
    
        {MethodType=Event}
        Procedure OnWmMouseLeave Integer wParam Integer lParam
            Set pbHover to False
            Set pbTracking to False
            Send Repaint
        End_Procedure  
    
        Procedure Repaint
            Handle hWnd
            Integer iResult
            Get Window_Handle to hWnd
            If (hWnd<>0) Begin
                Move (InvalidateRect(hWnd,0,True)) to iResult
            End
        End_Procedure
    
        { MethodType=Property }
        Function Checked_State Returns Integer
            Function_Return (pbChecked(Self))
        End_Function
    
        { MethodType=Property }
        { InitialValue=False }
        { Category=Appearance }
        { PropertyType=Boolean }
        Procedure Set Checked_State Integer bCheck
            Set pbChecked to bCheck
            Send Repaint
            Send OnChange           
        End_Procedure
    
        {MethodType=Event}
        Procedure OnChange
        End_Procedure
    
        { MethodType=Property }
        Procedure Set Item_Changed_State Integer iItem Integer iState
            Set Changed_State to iState
        End_Procedure
    
        { MethodType=Property }
        Function Item_Changed_State Integer iItem Returns Integer
            Function_Return (Changed_State(Self))
        End_Function
    
        {MethodType=Event}
        Procedure OnWmDrawItem Integer wParam Integer lParam
            Handle hTheme hCT hFont hFontNew hFontOld
            String sClass sLabel sFont
            Integer iVoid iLen iLoop
            Address aUTF16Buffer
            tWinLogFont tLogFont
            tdDrawItem tDrawItem
            tdRect     tRect 
            tdRect     tRectCheck
            String sItemStr 
            Integer iRet 
    
            Move 0 to tDrawItem.hDC
            Move (CopyMemory(AddressOf(tDrawItem), lParam, SizeOfType(tdDrawItem))) to iRet
    
            Move tDrawItem.rc to tRect
            Move tDrawItem.rc to tRectCheck
    
            If ((tDrawItem.itemAction iand ODA_SELECT) or (tDrawItem.itemAction iand ODA_DRAWENTIRE)) Begin
    
                Move (SetTextColor(tDrawItem.hDC, GetSysColor(COLOR_BTNTEXT))) to iVoid
                Move (SetBkMode(tDrawItem.hDC, TRANSPARENT)) to iRet
                Move (FillRect(tDrawItem.hDC,AddressOf(tRect),GetSysColorBrushEf(COLOR_BTNFACE))) to iVoid
    
                Move (GetStockObject(SYSTEM_FONT)) to hFont
                Move 0 to tLogFont.lfOrientation
                Move (WINAPI_GetObject(hFont,SizeOfType(tWinLogFont),AddressOf(tLogFont))) to iVoid
    
                Get WindowsTypeFace to sFont
                Move (Length(sFont)) to iLen
                For iLoop from 0 to 31
                    If (iLoop<iLen) Begin 
                       Move (Ascii(Mid(sFont,1,iLoop+1))) to tLogFont.lfFaceName[iloop]
                    End
                    Else Begin 
                       Move 0 to tLogFont.lfFaceName[iLoop]
                    End
                Loop
                If (pbLabelBold(Self)) Begin 
                    Move FW_HEAVY to tlogfont.lfWeight
                End
                Move (CreateFontIndirect(AddressOf(tLogFont))) to hFontNew   
                Move (SelectObject(tDrawItem.hDC, hFontNew)) to hFontOld     
    
                Get Create (RefClass(cCharTranslate)) to hCT
    
                Move ("Button"+Character(0)) to sClass
    
                Get Utf16FromStr of hCT sClass CP_OEMCP (&iLen) to aUTF16Buffer
    
                Move (WINAPI_OpenThemeData(0,aUTF16Buffer)) to hTheme
    
                If (hTheme) Begin
                    If (AlignmentMode(Self)=taRightJustify or AlignmentMode(Self)=taCenterJustify) Begin
                        Move 13 to tRectCheck.iRight
                    End
                    Else Begin 
                        Move (tRectCheck.iRight-13) to tRectCheck.iLeft
                    End
                    
                    Case Begin 
                        Case (tDrawItem.itemState iand ODS_SELECTED) 
                            Move (WINAPI_DrawThemeBackground(hTheme,tDrawItem.hDC,BP_CHECKBOX,If (pbChecked(Self),CBS_CHECKEDPRESSED,CBS_UNCHECKEDPRESSED),AddressOf(tRectCheck),0)) to iVoid
                            Case Break
                        Case Else
                            If (pbHover(Self)) Begin 
                                Move (WINAPI_DrawThemeBackground(hTheme,tDrawItem.hDC,BP_CHECKBOX,If (pbChecked(Self),CBS_CHECKEDHOT,CBS_UNCHECKEDHOT),AddressOf(tRectCheck),0)) to iVoid
                            End
                            Else Begin 
                                Move (WINAPI_DrawThemeBackground(hTheme,tDrawItem.hDC,BP_CHECKBOX,If (pbChecked(Self),CBS_CHECKEDNORMAL,CBS_UNCHECKEDNORMAL),AddressOf(tRectCheck),0)) to iVoid
                            End
                    Case End
    
                    Move (WINAPI_CloseThemeData(hTheme)) to iVoid
    
                    Move (Label(Self)+Character(0)) to sLabel
    
                    If (AlignmentMode(Self)=taRightJustify or AlignmentMode(Self)=taCenterJustify) Begin
                        Move (tRect.iLeft+16) to tRect.iLeft
                        Move (DrawText(tDrawItem.hDC,AddressOf(sLabel),-1,AddressOf(tRect),DT_SINGLELINE ior DT_VCENTER ior DT_END_ELLIPSIS)) to iVoid
                        Move (tRect.iLeft-16) to tRect.iLeft
                    End
                    Else Begin 
                        Move (tRectCheck.iRight+13) to tRectCheck.iLeft
                        Move (DrawText(tDrawItem.hDC,AddressOf(sLabel),-1,AddressOf(tRect),DT_SINGLELINE ior DT_VCENTER ior DT_END_ELLIPSIS)) to iVoid
                    End
    
                    Move (SelectObject(tDrawItem.hDC, hFontOld)) to hFontOld     
                    Move (DeleteObject(hFontNew)) to iVoid
                End
    
                If (tDrawItem.itemState iand ODS_FOCUS) Begin 
                    If (pbShowFocus(Self)) Begin 
                        Move (WINAPI_DrawFocusRect(tDrawItem.hDC,AddressOf(tRect))) to iVoid
                    End
                End
    
                Send Destroy of hCT
                Move (Free(aUTF16Buffer)) to iVoid
                Procedure_Return True
            End
            Else Begin 
                If (tDrawItem.itemAction iand ODA_FOCUS) Begin 
                    If (tDrawItem.itemState iand ODS_FOCUS) Begin 
                        If (pbShowFocus(Self)) Begin 
                            Move (WINAPI_DrawFocusRect(tDrawItem.hDC,AddressOf(tRect))) to iVoid
                            Procedure_Return True
                        End
                    End
                    Else Begin 
                    End
                End
            End
            Procedure_Return False
        End_Procedure
    End_Class
    
    Class cdbCheckboxCustom is a cCheckBoxCustom
        Procedure Construct_Object
    
            Forward Send Construct_Object
    
            // Private properties
            { Visibility = Private }
            Property Integer ppiDataFile
            { Visibility = Private }
            Property Integer ppiDataField
    
            Send Define_Nesting
            Send Define_Navigation
            Send Define_Server
            Send Define_Validate
        End_Procedure
    
        Import_Class_Protocol Nesting_Mixin
        Import_Class_Protocol Navigate_Mixin
        Import_Class_Protocol Server_Mixin
        Import_Class_Protocol Validate_Mixin 
    
        {Visibility=Private}
        Procedure OnBnClicked
            Forward Send OnBnClicked
            Set Changed_State to True
        End_Procedure    
    
        // ******************************************************************************************** //
        // ** Database support                                                                       ** //
        // ******************************************************************************************** //
    
        // Binds to a database field
        { Visibility = Private }
        Procedure Bind_Data Integer iFile Integer iField
            Set Data_File to iFile
            Set Data_Field to iField
        End_Procedure
    
        // Returns the Data_File
        { Visibility = Private }
        Function Data_File Integer iItem Returns Integer
            Integer iDataFile
    
            Get ppiDataFile to iDataFile
    
            Function_Return iDataFile
        End_Function
    
        // Sets the Data_File
        { Visibility = Private }
        Procedure Set Data_File Integer iItem Integer iFile
            Set ppiDataFile to iFile
        End_Procedure
    
        // Returns the Data_Field
        { Visibility = Private }
        Function Data_Field Integer iItem Returns Integer
            Integer iDataField
    
            Get ppiDataField to iDataField
    
            Function_Return iDataField
        End_Function
    
        // Sets the Data_Field
        { Visibility = Private }
        Procedure Set Data_Field Integer iItem Integer iField
            Set ppiDataField to iField
        End_Procedure
    
        { Visibility = Private }
        Procedure Entry_Display Integer iFile Integer iFlag
            Integer iDataFile iDataField
            Boolean bFound
    
            Get Data_File to iDataFile
            Get Data_Field to iDataField
    
            If (iFile = 0) Begin
                Is_File_Included iDataFile 1
            End
    
            Move (Found) to bFound
            If (iFile <> 0) Begin
                Move (iFile = iDataFile or iFlag = True) to bFound
            End
            If (bFound) Begin
                Send Read_Data
                Set Changed_State to False
            End
        End_Procedure
    
        { Visibility = Private }
        Procedure Entry_Clear Integer iFile
            Boolean bFound
            Integer iDataFile
    
            Move (iFile = 0) to bFound
            If (bFound = False) Begin
                Get Data_File to iDataFile
                Is_File_Included iDataFile 0
            End
            Move (Found) to bFound
            If (bFound) Begin
                Send Clear_Data
                Set Changed_State to False
            End
        End_Procedure
    
        { Visibility = Private }
        Procedure Entry_Clear_All Integer iFile
            Send Entry_Clear iFile
        End_Procedure
    
        { Visibility = Private }
        Procedure Entry_Update Integer iFile Integer iFlag
            Integer iDataFile iDataField iItem iStat
            Handle hoServer
            Boolean bFound bChanged
            String sValue
    
            Get Server to hoServer
            Get Data_File to iDataFile
            Get Data_Field to iDataField
    
            If (iFile = 0 and iFlag = 3) Begin
                Is_File_Included iDataFile 1
                Move (Found) to bFound
            End
            Else Begin
                Move (iFile = iDataFile or iFile = 0) to bFound
            End
            If (bFound) Begin
                Get Changed_State to bChanged
                If (iFlag <> 1 and (not (bChanged))) Begin
                    Get_Attribute DF_FILE_STATUS of iDataFile to iStat
                    If (iStat <> DF_FILE_INACTIVE) Begin
                        Move False to bFound
                    End
                End
                If (bFound) Begin
                    Send Write_Data
                End
            End
        End_Procedure
    
        { Visibility = Private }
        Procedure Read_Data
            Integer iFile iField iFldLen 
            String sValue sTrue sFalse
            Handle hServer
            Get Data_File to iFile
            Get Data_Field to iField
            Get Server to hServer
            If (iFile>0 and iField>0) Begin
                Get_Field_Value iFile iField to sValue
                Get Field_CheckBox_Value of hServer iField 1 to sTrue
                Get Field_CheckBox_Value of hServer iField 0 to sFalse
                Set Checked_State to (sValue=sTrue)
            End
        End_Procedure
    
        { Visibility = Private }
        Procedure Clear_Data
            Set Checked_State to False
        End_Procedure
    
        Procedure Set Changed_State Boolean bChanged
            Integer iDataFile iDataField
            Handle hoServer
    
            Forward Set Changed_State to bChanged
    
            Get Server to hoServer
            Get Data_File to iDataFile
            Get Data_Field to iDataField
    
            If (hoServer <> 0 and iDataFile <> 0 and iDataField <> 0) Begin
                Set File_Field_Changed_State of hoServer iDataFile iDataField to bChanged
            End
        End_Procedure
    
        Function Changed_State Returns Boolean 
            Integer iDataFile iDataField
            Handle hoServer
            Boolean bChanged
    
            Get Server to hoServer
            Get Data_File to iDataFile
            Get Data_Field to iDataField
    
            If (hoServer <> 0 and iDataFile <> 0 and iDataField <> 0) Begin
                Get File_Field_Changed_State of hoServer iDataFile iDataField to bChanged
            End
            Function_Return bChanged
        End_Function
        
        { Visibility = Private }
        Procedure Write_Data
            Integer iFile iField 
            String sValue sTrue sFalse
            Handle hServer
            Boolean bChecked
    
            Get Data_File to iFile
            Get Data_Field to iField
            Get Server to hServer
            If (iFile>0 and iField>0 and hServer>0) Begin
                Get Checked_State to bChecked
                Get Field_CheckBox_Value of hServer iField 1 to sTrue
                Get Field_CheckBox_Value of hServer iField 0 to sFalse
                Set_Field_Value iFile iField to (If(bChecked,sTrue,sFalse))
            End
        End_Procedure
    
        { Visibility = Private }
        Procedure Refresh Integer iMode
            If (iMode = MODE_CLEAR_ALL) Begin
                Send Entry_Clear_All 1
            End
            Else Begin
                Send Entry_Clear 1
                Send Entry_Display 0 0
            End
        End_Procedure
        
        { Visibility = Private }
        Procedure Update_Dependent_Items
        End_Procedure
    
        { Visibility = Private }
        Function Item_Count Returns Integer
            Function_Return 1
        End_Function
    
        { Visibility = Private }
        Function DEO_Control_Object Returns Integer
            Function_Return 1
        End_Function
    End_Class
    Last edited by Focus; 26-Jan-2018 at 09:50 AM.
    Success consists of going from failure to failure without loss of enthusiasm - Winston Churchill

  2. #2
    Join Date
    Feb 2009
    Posts
    5,467

    Default Re: Unfinished variation on a checkbox with focus rect, bold and keeps theme

    @wil Hi Wil great to see you again today. This is the checkbox I was talking about. If your bored sometime if you could have a look at what it would take to make data aware that would be great. Its not important or something we need it is more just a curiosity as to could it be done. Cheers
    Success consists of going from failure to failure without loss of enthusiasm - Winston Churchill

  3. #3

    Default Re: Unfinished variation on a checkbox with focus rect, bold and keeps theme

    Andrew,

    Ok, try this.
    Not perfect, but does work.

    PS: FillRect wasn't declared in the WindowsEx library.
    You did send me a bit on a goose chase as I first had to upgrade the cWindowsEx project to DF18.1 to at least be able to compile your code from above.
    PPS: I'm stealing the "db" logic from the cComdbActiveXControl package.

    Code:
    Use cCharTranslate.pkg
    Use Dftypes.pkg
    Use tWinStructs.pkg
    Use dfclient.pkg
    Use cComDbActiveXControl.pkg
    
    External_Function WINAPI_OpenThemeData "OpenThemeData" uxtheme.dll Handle hWnd Pointer pszClassList Returns Pointer
    External_Function WINAPI_CloseThemeData "CloseThemeData" uxtheme.dll Handle hWnd Returns Integer
    External_Function WINAPI_DrawThemeBackground "DrawThemeBackground" uxtheme.dll Handle hTheme Handle hHDC Integer iPartId Integer iStateId Pointer pRECT Pointer pClipRect Returns Pointer
    External_Function WINAPI_GetObject "GetObjectA" GDI32.dll Handle hgdiobj Integer iBuffer Pointer lpvObj  Returns Integer
    External_Function WINAPI_SetBkColor "SetBkColor" GDI32.dll Handle hgdiobj Integer iColorRef Returns Integer
    External_function WINAPI_DrawFocusRect "DrawFocusRect" User32.dll Handle hDC Pointer pRect Returns Integer
    External_Function FillRect   "FillRect"   User32.dll Handle hdc Pointer pRect Handle hBruch Returns Integer
    
    
    Define ODA_DRAWENTIRE  for 1
    Define ODA_SELECT      for 2
    Define ODA_FOCUS       for 4
    Define ODS_SELECTED    for 1
    Define ODS_GRAYED      for 2
    Define ODS_DISABLED    for 4
    Define ODS_CHECKED     for 8
    Define ODS_FOCUS       for |CI$10
    Define ODS_HOTLIGHT    for |CI$40
    Define ODS_INACTIVE    for |CI$80
    Define BP_CHECKBOX for 3
    Define CBS_UNCHECKEDNORMAL for 1
    Define CBS_UNCHECKEDHOT for 2
    Define CBS_UNCHECKEDPRESSED for 3
    Define CBS_UNCHECKEDDISABLED for 4
    Define CBS_CHECKEDNORMAL for 5
    Define CBS_CHECKEDHOT for 6
    Define CBS_CHECKEDPRESSED for 7
    Define CBS_CHECKEDDISABLED for 8
    Define BN_SETFOCUS  for  6
    Define BN_KILLFOCUS for  7
    
    Struct tdRect
        Integer iLeft
        Integer iTop
        Integer iRight
        Integer iBottom
    End_Struct
    
    Struct tdDrawItem
        Integer iCtlType
        Integer iCtlID
        Integer iitemID
        Integer itemAction
        Integer itemState
        Handle  hwndItem
        Handle  hDC
        tdRect   rc
        Pointer pitemData
    End_Struct
    
    Struct tdTRACKMOUSEEVENT
      DWord  cbSize
      DWord  dwFlags
      Handle hwndTrack
      DWord  dwHoverTime
    End_Struct
    
    Register_Procedure OnWmDrawItem
    Register_Procedure OnWmMouseHover
    Register_Procedure OnWmMouseLeave
    
    // https://social.msdn.microsoft.com/Forums/windowsdesktop/en-US/3570eb99-ac51-48fc-910d-d8c7fc38945a/checkbox-text-style-without-removing-theme?forum=windowsuidevelopment
    
    { DesignerClass = cDTCheckBox }
    Class cCheckBoxCustom is a cWinControl
        Import_Class_Protocol ToolTip_Support_Mixin
        Import_Class_Protocol Standard_Object_Mixin
        Import_Class_Protocol Shadow_Mixin
        Import_Class_Protocol Bitmap_Support_Mixin
        Procedure Construct_Object
            Set External_Class_Name "cCheckBoxCustom" to "Button"
            Forward Send Construct_Object
            Set Delegation_Mode to Delegate_To_Parent
    
            Set Window_Style    to WS_CHILD True
            Set Window_Style    to WS_TABSTOP True
            Set Window_Style    to WS_GROUP True
            Set Window_Style    to BS_CHECKBOX True
            Set Window_Style    to BS_AUTOCHECKBOX True
            Set Window_Style    to BS_OWNERDRAW True
            Set Window_Style    to BS_NOTIFY True
    
            {Visibility=Private}
            Property Boolean pbChecked False
            {Visibility=Private}
            Property Boolean pbTracking False
            {Visibility=Private}
            Property Boolean pbHover False
            { InitialValue=False Category=Appearance PropertyType=Boolean }
            Property Boolean pbShowFocus  False
            { InitialValue=False Category=Appearance PropertyType=Boolean }
            Property Boolean pbLabelBold False
            { EnumList="taRightJustify, taLeftJustify"}
            { Category=Appearance }
            Property Integer AlignmentMode taRightJustify
            {Visibility=Private}
            Property String Private.Label
            {Visibility=Private}
            Property Boolean Changed_State
            {Visibility=Private}
            Property Integer Private.Shadow_State
    
            Send Define_Standard_Object_Mixin
            Send Define_Shadow_Mixin
            Send Define_Bitmap_Support_Mixin
            Send Define_ToolTip_Support_Mixin
    
            // If set true, then the control will attempt to bind the value property in the object to the
            // comValue in the control. It will try to keep these values in synch at all times. This allows a
            // control to be used as a Form style value control. the default is true. Even when true if the
            // get/set ComValue methods are not set up to do anything, this will do nothing.
            { Category=Behavior }
            Property boolean pbBindValue True
    
            // internal: set true object is notified that the OCX value has changed.
            { Visibility=Private }
            Property Boolean pbPrivateControlChanging false
    
            // Class sets this true when making a local (externally triggered) change. This is
            // set when a Set Value change is made to prevent recursion
            { Visibility=Private }
            property Boolean pbPrivateControlRefresh false
    
            // added to eumlate a single item form support
            { Visibility=Private }
            property Boolean pbPrivateItem_Changed_State false
    
            // This keeps track of value, even when control is not created
            { Visibility=Private }
            Property String psPrivateValue ''
        End_Procedure
    
        Procedure End_Construct_Object
            Forward Send End_Construct_Object
            Set External_Message WM_DRAWITEM    to (RefProc(OnWmDrawItem))
            Set External_Message WM_MOUSEHOVER  to (RefProc(OnWmMouseHover))
            Set External_Message WM_MOUSELEAVE  to (RefProc(OnWmMouseLeave))
        End_Procedure
    
        { MethodType=Property }
        Procedure Set Label String Val
            Set Private.Label to Val
        End_Procedure
    
        { MethodType=Property }
        Function Label Returns String
            Function_Return (Private.Label(Self))
        End_Function
    
        { MethodType=Property Visibility=Private Obsolete=True }
        Procedure Set Shadow_State Integer iItem Integer iState
            Set Private.Shadow_State to iState
        End_Procedure
    
        { MethodType=Property Visibility=Private Obsolete=True }
        Function Shadow_State Integer iItem Returns Integer
            Function_Return (Private.Shadow_State(Self))
        End_Function
    
        {Visibility=Private}
        Procedure Command Integer wPara Integer lPara
           Forward Send Command wPara lPara
    
           Integer iID iNotify
    
           Move (Hi(wPara))  to iNotify
           Move (Low(wPara)) to iID
    
           Case Begin
               Case (iNotify=BN_CLICKED)
                   Send OnBnClicked
                   Case Break
               Case (iNotify=BN_SETFOCUS)
                   Send OnSetFocus
                   Case Break
               Case (iNotify=BN_KILLFOCUS)
                   Send OnKillFocus
                   Case Break
           Case End
        End_Procedure
    
        {Visibility=Private}
        Procedure OnBnClicked
            //note don't code this in mouse up
            Set Checked_State to (not(Checked_State(Self)))
            Send OnControlValueChanged
        End_Procedure
    
        {MethodType=Event}
        Procedure OnMouseMove Integer x Integer y Integer fKeys
            tdTRACKMOUSEEVENT tMe
            Integer bTracked
    
            If (not(pbTracking(Self))) Begin
                Move (SizeOfType(tdTRACKMOUSEEVENT)) to tMe.cbSize
                Get Window_Handle to tMe.hwndTrack
                Move (TME_LEAVE ior TME_HOVER) to tMe.dwFlags
                Move 1 to tMe.dwHoverTime
                Move (TrackMouseEventEf(AddressOf(tMe)))  to bTracked
                Set pbTracking to bTracked
            End
        End_Procedure
    
        {MethodType=Event}
        Procedure OnWmMouseHover Integer wParam Integer lParam
            Set pbHover to True
            Send Repaint
        End_Procedure
    
        {MethodType=Event}
        Procedure OnWmMouseLeave Integer wParam Integer lParam
            Set pbHover to False
            Set pbTracking to False
            Send Repaint
        End_Procedure
    
        Procedure Repaint
            Handle hWnd
            Integer iResult
            Get Window_Handle to hWnd
            If (hWnd<>0) Begin
                Move (InvalidateRect(hWnd,0,True)) to iResult
            End
        End_Procedure
    
        { MethodType=Property }
        Function Checked_State Returns Integer
            Function_Return (pbChecked(Self))
        End_Function
    
        { MethodType=Property }
        { InitialValue=False }
        { Category=Appearance }
        { PropertyType=Boolean }
        Procedure Set Checked_State Integer bCheck
    //        If not (pbPrivateControlChanging(self)) ;
    //            Send OnRefreshControl bCheck
            Set pbChecked to bCheck
            Send Repaint
            Send OnChange
            //Set changed_state to True
            set item_changed_state 0 to true
        End_Procedure
    
        // Created to simulate get/Set value.
        { MethodType=Property }
        Procedure set Value integer iItem string sVal
            If not (pbPrivateControlChanging(self)) ;
                Send OnRefreshControl sVal
            Set psPrivateValue to sVal
            Send OnChange
            //Set changed_state to True
            set item_changed_state 0 to true
        End_Procedure
    
        { MethodType=Property }
        Function Value integer iItem returns string
            function_return (psPrivateValue(self))
            //function_return (Controlvalue(self))
        end_function
    
        {MethodType=Event}
        Procedure OnChange
        End_Procedure
    
        // added to eumlate a single item form support
        { MethodType=Property Visibility=Private }
        Function Item_Count returns integer
            function_return 1
        end_function
    
        // added to eumlate a single item form support
        { MethodType=Property Visibility=Private }
        Procedure Set Item_Changed_State integer iItem integer iState
           Set pbPrivateItem_changed_state to iState
            If (iState and changed_state(self)=false) set changed_state to true
        end_procedure
    
        { MethodType=Property Visibility=Private }
        Function Item_Changed_State integer iItem returns integer
            function_return (pbPrivateItem_changed_state(self))
        end_function
    
        {MethodType=Event}
        Procedure OnWmDrawItem Integer wParam Integer lParam
            Handle hTheme hCT hFont hFontNew hFontOld
            String sClass sLabel sFont
            Integer iVoid iLen iLoop
            Address aUTF16Buffer
            tWinLogFont tLogFont
            tdDrawItem tDrawItem
            tdRect     tRect
            tdRect     tRectCheck
            String sItemStr
            Integer iRet
    
            Move 0 to tDrawItem.hDC
            Move (CopyMemory(AddressOf(tDrawItem), lParam, SizeOfType(tdDrawItem))) to iRet
    
            Move tDrawItem.rc to tRect
            Move tDrawItem.rc to tRectCheck
    
            If ((tDrawItem.itemAction iand ODA_SELECT) or (tDrawItem.itemAction iand ODA_DRAWENTIRE)) Begin
    
                Move (SetTextColor(tDrawItem.hDC, GetSysColor(COLOR_BTNTEXT))) to iVoid
                Move (SetBkMode(tDrawItem.hDC, TRANSPARENT)) to iRet
                Move (FillRect(tDrawItem.hDC,AddressOf(tRect),GetSysColorBrushEf(COLOR_BTNFACE))) to iVoid
    
                Move (GetStockObject(SYSTEM_FONT)) to hFont
                Move 0 to tLogFont.lfOrientation
                Move (WINAPI_GetObject(hFont,SizeOfType(tWinLogFont),AddressOf(tLogFont))) to iVoid
    
                Get WindowsTypeFace to sFont
                Move (Length(sFont)) to iLen
                For iLoop from 0 to 31
                    If (iLoop<iLen) Begin
                       Move (Ascii(Mid(sFont,1,iLoop+1))) to tLogFont.lfFaceName[iloop]
                    End
                    Else Begin
                       Move 0 to tLogFont.lfFaceName[iLoop]
                    End
                Loop
                If (pbLabelBold(Self)) Begin
                    Move FW_HEAVY to tlogfont.lfWeight
                End
                Move (CreateFontIndirect(AddressOf(tLogFont))) to hFontNew
                Move (SelectObject(tDrawItem.hDC, hFontNew)) to hFontOld
    
                Get Create (RefClass(cCharTranslate)) to hCT
    
                Move ("Button"+Character(0)) to sClass
    
                Get Utf16FromStr of hCT sClass CP_OEMCP (&iLen) to aUTF16Buffer
    
                Move (WINAPI_OpenThemeData(0,aUTF16Buffer)) to hTheme
    
                If (hTheme) Begin
                    If (AlignmentMode(Self)=taRightJustify or AlignmentMode(Self)=taCenterJustify) Begin
                        Move 13 to tRectCheck.iRight
                    End
                    Else Begin
                        Move (tRectCheck.iRight-13) to tRectCheck.iLeft
                    End
                    
                    Case Begin
                        Case (tDrawItem.itemState iand ODS_SELECTED)
                            Move (WINAPI_DrawThemeBackground(hTheme,tDrawItem.hDC,BP_CHECKBOX,If (pbChecked(Self),CBS_CHECKEDPRESSED,CBS_UNCHECKEDPRESSED),AddressOf(tRectCheck),0)) to iVoid
                            Case Break
                        Case Else
                            If (pbHover(Self)) Begin
                                Move (WINAPI_DrawThemeBackground(hTheme,tDrawItem.hDC,BP_CHECKBOX,If (pbChecked(Self),CBS_CHECKEDHOT,CBS_UNCHECKEDHOT),AddressOf(tRectCheck),0)) to iVoid
                            End
                            Else Begin
                                Move (WINAPI_DrawThemeBackground(hTheme,tDrawItem.hDC,BP_CHECKBOX,If (pbChecked(Self),CBS_CHECKEDNORMAL,CBS_UNCHECKEDNORMAL),AddressOf(tRectCheck),0)) to iVoid
                            End
                    Case End
    
                    Move (WINAPI_CloseThemeData(hTheme)) to iVoid
    
                    Move (Label(Self)+Character(0)) to sLabel
    
                    If (AlignmentMode(Self)=taRightJustify or AlignmentMode(Self)=taCenterJustify) Begin
                        Move (tRect.iLeft+16) to tRect.iLeft
                        Move (DrawText(tDrawItem.hDC,AddressOf(sLabel),-1,AddressOf(tRect),DT_SINGLELINE ior DT_VCENTER ior DT_END_ELLIPSIS)) to iVoid
                        Move (tRect.iLeft-16) to tRect.iLeft
                    End
                    Else Begin
                        Move (tRectCheck.iRight+13) to tRectCheck.iLeft
                        Move (DrawText(tDrawItem.hDC,AddressOf(sLabel),-1,AddressOf(tRect),DT_SINGLELINE ior DT_VCENTER ior DT_END_ELLIPSIS)) to iVoid
                    End
    
                    Move (SelectObject(tDrawItem.hDC, hFontOld)) to hFontOld
                    Move (DeleteObject(hFontNew)) to iVoid
                End
    
                If (tDrawItem.itemState iand ODS_FOCUS) Begin
                    If (pbShowFocus(Self)) Begin
                        Move (WINAPI_DrawFocusRect(tDrawItem.hDC,AddressOf(tRect))) to iVoid
                    End
                End
    
                Send Destroy of hCT
                Move (Free(aUTF16Buffer)) to iVoid
                Procedure_Return True
            End
            Else Begin
                If (tDrawItem.itemAction iand ODA_FOCUS) Begin
                    If (tDrawItem.itemState iand ODS_FOCUS) Begin
                        If (pbShowFocus(Self)) Begin
                            Move (WINAPI_DrawFocusRect(tDrawItem.hDC,AddressOf(tRect))) to iVoid
                            Procedure_Return True
                        End
                    End
                    Else Begin
                    End
                End
            End
            Procedure_Return False
        End_Procedure
    
        // It is expected that the sub-class will provide functionality
        // for these messages. This gets and sets the value of the actual
        // window control. These should only be used to synchronize the window
        // control and the DF side. Do not use for any other purpose.
        { MethodType=Property }
        { DesignTime=False }
        Procedure Set ControlValue String sVal
          Set Checked_State to (sVal='1')
        End_Procedure
    
        { MethodType=Property }
        Function ControlValue Returns String
          Function_Return (Checked_State(Self))
        End_Function
        
    
        // Notification that the control's value has been changed
        // externally by the program (via set value). Use to synchronize
        // the control value.
        { MethodType=Event Visibility=Private }
        Procedure OnRefreshControl string sVal
            Boolean bOld
            If (pbBindValue(self) and pbPrivateControlChanging(self)=0) Begin
                Get pbPrivateControlRefresh to bOld
                Set pbPrivateControlRefresh to True
                set ControlValue to sval
                Set pbPrivateControlRefresh to bOld
            end
        End_Procedure
    
        // notification that the control has changed its value. Used to
        // synchronize the object with the change.
        { MethodType=Event }
        Procedure OnControlValueChanged
            String sVal
            Boolean bOld
            If (pbBindValue(self) and pbPrivateControlRefresh(self)=0) Begin
                Get pbPrivateControlChanging to bOld
                Set pbPrivateControlChanging to True
                Get ControlValue to sVal
                Set Value to sVal
                Set Item_Changed_State 0 to True
                Set pbPrivateControlChanging to bOld
            end
        End_Procedure
        
    End_Class
    
    
    
    // Create class that understands single item "dfentry" logic
    { ClassType=Abstract }
    { HelpTopic=cCheckBoxCustom_ }
    Class cCheckBoxCustom_ Is a cCheckBoxCustom
    
        Procedure Construct_Object
            Forward Send Construct_Object
            send define_dbItemMixin
        End_Procedure
    
        Import_class_protocol dbItemMixin
    
    End_Class
    
    // Mixes in the Entry_Form DEO logic to control
    { ClassType=Abstract }
    { HelpTopic=cdbCheckBoxCustom_ }
    Class cdbCheckBoxCustom_ is a cCheckBoxCustom_
        Import_Class_Protocol Entry_Form_DS_mixin
    End_Class
    
    
    Class cdbCheckboxCustom is a cdbCheckBoxCustom_
    
        Procedure Construct_Object
            Forward Send Construct_Object no_image
    
            Send Define_DFNavigation  // GUI navigate changes
            Set Validate_Mode to VALIDATE_ON_SAVE_NEXT
    
        End_Procedure // Construct_Object
    
        Import_Class_Protocol DFNavigate_Mixin
        Import_Class_Protocol DFCode_DEO_Mixin
    
        Import_Class_Protocol Extended_DEO_Mixin
        Import_Class_Protocol Extended_DEO_Status_Help_Mixin
        // Import_Class_Protocol Extended_DEO_Prompt_Mixin // not currently supported
    
        //  Returns TRUE to indicate that this is a DEO control. This is used by
        //  if you are within a DEO control message and should therefore
        //  send a DEO message.
        { MethodType=Property }
        Function DEO_Control_Object Returns integer
            Function_Return 1
        End_Function // DEO_Control_Object
    
        // This is called by the entry_item command to assign data_file and data_field. Normally
        // you would never use this message to bind the data, but you could
        Procedure Bind_Data integer iFile Integer iField
            Set Data_File   0 to iFile
            Set Data_Field  0 to iField
        End_Procedure // Bind_Data
    
        // added to improve autofind logic
        { Visibility=Private }
       procedure DoAutoFind
            Integer bChanged bOn
            // both changed_state and item_changed_state must be set for an autofind. If a default
            // value is set item_changed_state will be true and changed_state will be false. We want to
            // ignore these conditions
            get item_changed_State item 0 to bChanged
            if (bChanged and changed_state(self)) begin
                get item_option item 0 AUTOFIND_BIT to bOn
                if bOn begin
                    get item_option item 0 AUTOFIND_GE_BIT to bOn
                    Send entry_autofind (if(bOn,GE,EQ)) 0
                end
            end
        end_procedure
    
        // added to improve autofind
        { NoDoc=True }
        Procedure Exiting Handle hoDestination Returns Integer
            integer bErr
            // although exiting does not do a validate it should do an
            // autofind (if autofind is needed). This is consisent with
            // character mode behavior.
            send doAutofind // // this does an autofind if needed, this is needed before save
            Forward get msg_exiting hoDestination to bErr
            function_return bErr
        end_procedure
    
        { NoDoc=True }
        procedure Request_Save
            Send doAutofind // this does an autofind if needed, this is needed before save
            forward send request_save
        end_procedure
    
    End_Class
    --
    Wil

  4. #4
    Join Date
    Feb 2009
    Posts
    5,467

    Default Re: Unfinished variation on a checkbox with focus rect, bold and keeps theme

    Thanks Wil

    I will take a look sometime.

    I mentioned it as I thought it might help with Garret's thread with the desire to change the background colour with a bit more modification
    Success consists of going from failure to failure without loss of enthusiasm - Winston Churchill

  5. #5
    Join Date
    Feb 2009
    Location
    Somewhere in Vermont, USA - unless I'm not
    Posts
    11,085

    Default Re: Unfinished variation on a checkbox with focus rect, bold and keeps theme

    Hey Andrew - while I appreciate it, it was the forecolor, not backcolor. Backcolor changes just fine.
    Garret

    Time for an oldie but goodie:

    "If it ain't broke, you're not trying." - Red Green

  6. #6
    Join Date
    Feb 2009
    Posts
    5,467

    Default Re: Unfinished variation on a checkbox with focus rect, bold and keeps theme

    OK the forecolor then. It currently set the forecolour to the widows button text but you should be able set it to any RGB value

    Code:
    Move (SetTextColor(tDrawItem.hDC, GetSysColor(COLOR_BTNTEXT))) to iVoid
    Success consists of going from failure to failure without loss of enthusiasm - Winston Churchill

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •