Results 1 to 6 of 6

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

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Join Date
    Feb 2009
    Posts
    5,470

    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

Posting Permissions

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