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
[/code]
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
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
[/code]
--
Wil
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
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.
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[/code]