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
--