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