From a0f6fd68a56068a20e7186e2dd2d7daccfbce4aa Mon Sep 17 00:00:00 2001 From: Pavel Perminov Date: Wed, 26 Sep 2012 19:02:53 +0000 Subject: Chess4Net_MI 2010.0 release (106 rev. truncated adjusted copy) git-svn-id: http://svn.miranda-ng.org/main/trunk@1666 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c --- .../TntUnicodeControls/Source/ActiveIMM_TLB.pas | 1374 ++++++ .../lib/TntUnicodeControls/Source/TntActnList.pas | 835 ++++ .../lib/TntUnicodeControls/Source/TntAxCtrls.pas | 191 + .../lib/TntUnicodeControls/Source/TntBandActn.pas | 92 + .../lib/TntUnicodeControls/Source/TntButtons.pas | 982 ++++ .../lib/TntUnicodeControls/Source/TntCheckLst.pas | 184 + .../lib/TntUnicodeControls/Source/TntClasses.pas | 1780 +++++++ .../lib/TntUnicodeControls/Source/TntClipBrd.pas | 86 + .../lib/TntUnicodeControls/Source/TntComCtrls.pas | 5058 ++++++++++++++++++++ .../lib/TntUnicodeControls/Source/TntCompilers.inc | 356 ++ .../lib/TntUnicodeControls/Source/TntControls.pas | 1099 +++++ .../lib/TntUnicodeControls/Source/TntDB.pas | 900 ++++ .../lib/TntUnicodeControls/Source/TntDBActns.pas | 594 +++ .../TntUnicodeControls/Source/TntDBClientActns.pas | 197 + .../lib/TntUnicodeControls/Source/TntDBCtrls.pas | 2195 +++++++++ .../lib/TntUnicodeControls/Source/TntDBGrids.pas | 1175 +++++ .../lib/TntUnicodeControls/Source/TntDBLogDlg.dfm | 108 + .../lib/TntUnicodeControls/Source/TntDBLogDlg.pas | 133 + .../lib/TntUnicodeControls/Source/TntDialogs.pas | 981 ++++ .../lib/TntUnicodeControls/Source/TntExtActns.pas | 1400 ++++++ .../lib/TntUnicodeControls/Source/TntExtCtrls.pas | 1062 ++++ .../lib/TntUnicodeControls/Source/TntExtDlgs.pas | 317 ++ .../lib/TntUnicodeControls/Source/TntFileCtrl.pas | 118 + .../Source/TntFormatStrUtils.pas | 503 ++ .../lib/TntUnicodeControls/Source/TntForms.pas | 873 ++++ .../lib/TntUnicodeControls/Source/TntGraphics.pas | 142 + .../lib/TntUnicodeControls/Source/TntGrids.pas | 675 +++ .../lib/TntUnicodeControls/Source/TntIniFiles.pas | 1011 ++++ .../TntUnicodeControls/Source/TntIniFilesEx.pas | 205 + .../lib/TntUnicodeControls/Source/TntListActns.pas | 207 + .../lib/TntUnicodeControls/Source/TntMenus.pas | 1146 +++++ .../lib/TntUnicodeControls/Source/TntRegistry.pas | 148 + .../lib/TntUnicodeControls/Source/TntStdActns.pas | 1922 ++++++++ .../lib/TntUnicodeControls/Source/TntStdCtrls.pas | 3215 +++++++++++++ .../lib/TntUnicodeControls/Source/TntSysUtils.pas | 1699 +++++++ .../lib/TntUnicodeControls/Source/TntSystem.pas | 1384 ++++++ .../TntUnicodeControls/Source/TntWideStrUtils.pas | 451 ++ .../TntUnicodeControls/Source/TntWideStrings.pas | 831 ++++ .../lib/TntUnicodeControls/Source/TntWindows.pas | 1452 ++++++ 39 files changed, 37081 insertions(+) create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas create mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas (limited to 'plugins/Chess4Net/lib/TntUnicodeControls/Source') diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas new file mode 100644 index 0000000000..c515cf9a36 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas @@ -0,0 +1,1374 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit ActiveIMM_TLB; + +{$INCLUDE TntCompilers.inc} + +{TNT-IGNORE-UNIT} + +// ************************************************************************ // +// WARNING +// ------- +// The types declared in this file were generated from data read from a +// Type Library. If this type library is explicitly or indirectly (via +// another type library referring to this type library) re-imported, or the +// 'Refresh' command of the Type Library Editor activated while editing the +// Type Library, the contents of this file will be regenerated and all +// manual modifications will be lost. +// ************************************************************************ // + +// PASTLWTR : $Revision: 1.1 $ +// File generated on 04/03/2001 11:32:13 PM from Type Library described below. + +// *************************************************************************// +// NOTE: +// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties +// which return objects that may need to be explicitly created via a function +// call prior to any access via the property. These items have been disabled +// in order to prevent accidental use from within the object inspector. You +// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively +// removing them from the $IFDEF blocks. However, such items must still be +// programmatically created via a method of the appropriate CoClass before +// they can be used. +// ************************************************************************ // +// Type Lib: C:\Program Files\Microsoft Platform SDK\Include\dimm.tlb (1) +// IID\LCID: {4955DD30-B159-11D0-8FCF-00AA006BCC59}\0 +// Helpfile: +// DepndLst: +// (1) v2.0 stdole, (C:\WINNT\System32\Stdole2.tlb) +// (2) v4.0 StdVCL, (C:\WINNT\System32\STDVCL40.DLL) +// Errors: +// Hint: Member 'End' of 'IActiveIMMMessagePumpOwner' changed to 'End_' +// Error creating palette bitmap of (TCActiveIMM) : Server D:\D5Addons\Dimm\dimm.dll contains no icons +// ************************************************************************ // +{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. +interface + +uses + Windows, ActiveX, Classes, OleServer; + +// *********************************************************************// +// GUIDS declared in the TypeLibrary. Following prefixes are used: +// Type Libraries : LIBID_xxxx +// CoClasses : CLASS_xxxx +// DISPInterfaces : DIID_xxxx +// Non-DISP interfaces: IID_xxxx +// *********************************************************************// +const + // TypeLibrary Major and minor versions + ActiveIMMMajorVersion = 0; + ActiveIMMMinorVersion = 1; + + LIBID_ActiveIMM: TGUID = '{4955DD30-B159-11D0-8FCF-00AA006BCC59}'; + + IID_IEnumRegisterWordA: TGUID = '{08C03412-F96B-11D0-A475-00AA006BCC59}'; + IID_IEnumRegisterWordW: TGUID = '{4955DD31-B159-11D0-8FCF-00AA006BCC59}'; + IID_IEnumInputContext: TGUID = '{09B5EAB0-F997-11D1-93D4-0060B067B86E}'; + IID_IActiveIMMRegistrar: TGUID = '{B3458082-BD00-11D1-939B-0060B067B86E}'; + IID_IActiveIMMMessagePumpOwner: TGUID = '{B5CF2CFA-8AEB-11D1-9364-0060B067B86E}'; + IID_IActiveIMMApp: TGUID = '{08C0E040-62D1-11D1-9326-0060B067B86E}'; + IID_IActiveIMMIME: TGUID = '{08C03411-F96B-11D0-A475-00AA006BCC59}'; + IID_IActiveIME: TGUID = '{6FE20962-D077-11D0-8FE7-00AA006BCC59}'; + IID_IActiveIME2: TGUID = '{E1C4BF0E-2D53-11D2-93E1-0060B067B86E}'; + CLASS_CActiveIMM: TGUID = '{4955DD33-B159-11D0-8FCF-00AA006BCC59}'; +type + +// *********************************************************************// +// Forward declaration of types defined in TypeLibrary +// *********************************************************************// + IEnumRegisterWordA = interface; + IEnumRegisterWordW = interface; + IEnumInputContext = interface; + IActiveIMMRegistrar = interface; + IActiveIMMMessagePumpOwner = interface; + IActiveIMMApp = interface; + IActiveIMMIME = interface; + IActiveIME = interface; + IActiveIME2 = interface; + +// *********************************************************************// +// Declaration of CoClasses defined in Type Library +// (NOTE: Here we map each CoClass to its Default Interface) +// *********************************************************************// + CActiveIMM = IActiveIMMApp; + + +// *********************************************************************// +// Declaration of structures, unions and aliases. +// *********************************************************************// + wireHBITMAP = ^_userHBITMAP; + wireHWND = ^_RemotableHandle; + PUserType1 = ^TGUID; {*} + PUserType2 = ^tagMSG; {*} + PUserType3 = ^REGISTERWORDA; {*} + PUserType4 = ^REGISTERWORDW; {*} + PUserType5 = ^CANDIDATEFORM; {*} + PUserType6 = ^LOGFONTA; {*} + PUserType7 = ^LOGFONTW; {*} + PUserType8 = ^COMPOSITIONFORM; {*} + PUserType9 = ^tagPOINT; {*} + PWord1 = ^Word; {*} + PUserType10 = ^IMEMENUITEMINFOA; {*} + PUserType11 = ^IMEMENUITEMINFOW; {*} + PUserType12 = ^INPUTCONTEXT; {*} + PByte1 = ^Byte; {*} + + __MIDL___MIDL_itf_dimm_0000_0001 = packed record + lpReading: PAnsiChar; + lpWord: PAnsiChar; + end; + + REGISTERWORDA = __MIDL___MIDL_itf_dimm_0000_0001; + + __MIDL___MIDL_itf_dimm_0000_0002 = packed record + lpReading: PWideChar; + lpWord: PWideChar; + end; + + REGISTERWORDW = __MIDL___MIDL_itf_dimm_0000_0002; + + __MIDL___MIDL_itf_dimm_0000_0003 = packed record + lfHeight: Integer; + lfWidth: Integer; + lfEscapement: Integer; + lfOrientation: Integer; + lfWeight: Integer; + lfItalic: Byte; + lfUnderline: Byte; + lfStrikeOut: Byte; + lfCharSet: Byte; + lfOutPrecision: Byte; + lfClipPrecision: Byte; + lfQuality: Byte; + lfPitchAndFamily: Byte; + lfFaceName: array[0..31] of Shortint; + end; + + LOGFONTA = __MIDL___MIDL_itf_dimm_0000_0003; + + __MIDL___MIDL_itf_dimm_0000_0004 = packed record + lfHeight: Integer; + lfWidth: Integer; + lfEscapement: Integer; + lfOrientation: Integer; + lfWeight: Integer; + lfItalic: Byte; + lfUnderline: Byte; + lfStrikeOut: Byte; + lfCharSet: Byte; + lfOutPrecision: Byte; + lfClipPrecision: Byte; + lfQuality: Byte; + lfPitchAndFamily: Byte; + lfFaceName: array[0..31] of Word; + end; + + LOGFONTW = __MIDL___MIDL_itf_dimm_0000_0004; + + tagPOINT = packed record + x: Integer; + y: Integer; + end; + + tagRECT = packed record + left: Integer; + top: Integer; + right: Integer; + bottom: Integer; + end; + + __MIDL___MIDL_itf_dimm_0000_0005 = packed record + dwIndex: LongWord; + dwStyle: LongWord; + ptCurrentPos: tagPOINT; + rcArea: tagRECT; + end; + + CANDIDATEFORM = __MIDL___MIDL_itf_dimm_0000_0005; + + __MIDL___MIDL_itf_dimm_0000_0006 = packed record + dwStyle: LongWord; + ptCurrentPos: tagPOINT; + rcArea: tagRECT; + end; + + COMPOSITIONFORM = __MIDL___MIDL_itf_dimm_0000_0006; + + __MIDL___MIDL_itf_dimm_0000_0007 = packed record + dwSize: LongWord; + dwStyle: LongWord; + dwCount: LongWord; + dwSelection: LongWord; + dwPageStart: LongWord; + dwPageSize: LongWord; + dwOffset: array[0..0] of LongWord; + end; + + CANDIDATELIST = __MIDL___MIDL_itf_dimm_0000_0007; + + __MIDL___MIDL_itf_dimm_0000_0008 = packed record + dwStyle: LongWord; + szDescription: array[0..31] of Shortint; + end; + + STYLEBUFA = __MIDL___MIDL_itf_dimm_0000_0008; + + __MIDL___MIDL_itf_dimm_0000_0009 = packed record + dwStyle: LongWord; + szDescription: array[0..31] of Word; + end; + + STYLEBUFW = __MIDL___MIDL_itf_dimm_0000_0009; + + __MIDL___MIDL_itf_dimm_0000_0010 = packed record + cbSize: SYSUINT; + fType: SYSUINT; + fState: SYSUINT; + wID: SYSUINT; + hbmpChecked: wireHBITMAP; + hbmpUnchecked: wireHBITMAP; + dwItemData: LongWord; + szString: array[0..79] of Shortint; + hbmpItem: wireHBITMAP; + end; + + IMEMENUITEMINFOA = __MIDL___MIDL_itf_dimm_0000_0010; + + _userBITMAP = packed record + bmType: Integer; + bmWidth: Integer; + bmHeight: Integer; + bmWidthBytes: Integer; + bmPlanes: Word; + bmBitsPixel: Word; + cbSize: LongWord; + pBuffer: ^Byte; + end; + + __MIDL_IWinTypes_0007 = record + case Integer of + 0: (hInproc: Integer); + 1: (hRemote: ^_userBITMAP); + end; + + _userHBITMAP = packed record + fContext: Integer; + u: __MIDL_IWinTypes_0007; + end; + + __MIDL___MIDL_itf_dimm_0000_0011 = packed record + cbSize: SYSUINT; + fType: SYSUINT; + fState: SYSUINT; + wID: SYSUINT; + hbmpChecked: wireHBITMAP; + hbmpUnchecked: wireHBITMAP; + dwItemData: LongWord; + szString: array[0..79] of Word; + hbmpItem: wireHBITMAP; + end; + + IMEMENUITEMINFOW = __MIDL___MIDL_itf_dimm_0000_0011; + + __MIDL___MIDL_itf_dimm_0000_0013 = record + case Integer of + 0: (A: LOGFONTA); + 1: (W: LOGFONTW); + end; + + __MIDL___MIDL_itf_dimm_0000_0012 = packed record + hWnd: wireHWND; + fOpen: Integer; + ptStatusWndPos: tagPOINT; + ptSoftKbdPos: tagPOINT; + fdwConversion: LongWord; + fdwSentence: LongWord; + lfFont: __MIDL___MIDL_itf_dimm_0000_0013; + cfCompForm: COMPOSITIONFORM; + cfCandForm: array[0..3] of CANDIDATEFORM; + hCompStr: LongWord; + hCandInfo: LongWord; + hGuideLine: LongWord; + hPrivate: LongWord; + dwNumMsgBuf: LongWord; + hMsgBuf: LongWord; + fdwInit: LongWord; + dwReserve: array[0..2] of LongWord; + end; + + __MIDL_IWinTypes_0009 = record + case Integer of + 0: (hInproc: Integer); + 1: (hRemote: Integer); + end; + + _RemotableHandle = packed record + fContext: Integer; + u: __MIDL_IWinTypes_0009; + end; + + INPUTCONTEXT = __MIDL___MIDL_itf_dimm_0000_0012; + + __MIDL___MIDL_itf_dimm_0000_0014 = packed record + dwPrivateDataSize: LongWord; + fdwProperty: LongWord; + fdwConversionCaps: LongWord; + fdwSentenceCaps: LongWord; + fdwUICaps: LongWord; + fdwSCSCaps: LongWord; + fdwSelectCaps: LongWord; + end; + + IMEINFO = __MIDL___MIDL_itf_dimm_0000_0014; + UINT_PTR = LongWord; + LONG_PTR = Integer; + + tagMSG = packed record + hWnd: wireHWND; + message: SYSUINT; + wParam: UINT_PTR; + lParam: LONG_PTR; + time: LongWord; + pt: tagPOINT; + end; + + +// *********************************************************************// +// Interface: IEnumRegisterWordA +// Flags: (0) +// GUID: {08C03412-F96B-11D0-A475-00AA006BCC59} +// *********************************************************************// + IEnumRegisterWordA = interface(IUnknown) + ['{08C03412-F96B-11D0-A475-00AA006BCC59}'] + function Clone(out ppEnum: IEnumRegisterWordA): HResult; stdcall; + function Next(ulCount: LongWord; out rgRegisterWord: REGISTERWORDA; out pcFetched: LongWord): HResult; stdcall; + function Reset: HResult; stdcall; + function Skip(ulCount: LongWord): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IEnumRegisterWordW +// Flags: (0) +// GUID: {4955DD31-B159-11D0-8FCF-00AA006BCC59} +// *********************************************************************// + IEnumRegisterWordW = interface(IUnknown) + ['{4955DD31-B159-11D0-8FCF-00AA006BCC59}'] + function Clone(out ppEnum: IEnumRegisterWordW): HResult; stdcall; + function Next(ulCount: LongWord; out rgRegisterWord: REGISTERWORDW; out pcFetched: LongWord): HResult; stdcall; + function Reset: HResult; stdcall; + function Skip(ulCount: LongWord): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IEnumInputContext +// Flags: (0) +// GUID: {09B5EAB0-F997-11D1-93D4-0060B067B86E} +// *********************************************************************// + IEnumInputContext = interface(IUnknown) + ['{09B5EAB0-F997-11D1-93D4-0060B067B86E}'] + function Clone(out ppEnum: IEnumInputContext): HResult; stdcall; + function Next(ulCount: LongWord; out rgInputContext: LongWord; out pcFetched: LongWord): HResult; stdcall; + function Reset: HResult; stdcall; + function Skip(ulCount: LongWord): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IActiveIMMRegistrar +// Flags: (0) +// GUID: {B3458082-BD00-11D1-939B-0060B067B86E} +// *********************************************************************// + IActiveIMMRegistrar = interface(IUnknown) + ['{B3458082-BD00-11D1-939B-0060B067B86E}'] + function RegisterIME(var rclsid: TGUID; lgid: Word; pszIconFile: PWideChar; pszDesc: PWideChar): HResult; stdcall; + function UnregisterIME(var rclsid: TGUID): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IActiveIMMMessagePumpOwner +// Flags: (0) +// GUID: {B5CF2CFA-8AEB-11D1-9364-0060B067B86E} +// *********************************************************************// + IActiveIMMMessagePumpOwner = interface(IUnknown) + ['{B5CF2CFA-8AEB-11D1-9364-0060B067B86E}'] + function Start: HResult; stdcall; + function End_: HResult; stdcall; + function OnTranslateMessage(var pMsg: tagMSG): HResult; stdcall; + function Pause(out pdwCookie: LongWord): HResult; stdcall; + function Resume(dwCookie: LongWord): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IActiveIMMApp +// Flags: (0) +// GUID: {08C0E040-62D1-11D1-9326-0060B067B86E} +// *********************************************************************// + IActiveIMMApp = interface(IUnknown) + ['{08C0E040-62D1-11D1-9326-0060B067B86E}'] + function AssociateContext(var hWnd: _RemotableHandle; hIME: LongWord; out phPrev: LongWord): HResult; stdcall; + function ConfigureIMEA(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; + var pData: REGISTERWORDA): HResult; stdcall; + function ConfigureIMEW(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; + var pData: REGISTERWORDW): HResult; stdcall; + function CreateContext(out phIMC: LongWord): HResult; stdcall; + function DestroyContext(hIME: LongWord): HResult; stdcall; + function EnumRegisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; + szRegister: PAnsiChar; var pData: Pointer; out pEnum: IEnumRegisterWordA): HResult; stdcall; + function EnumRegisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szRegister: PWideChar; var pData: Pointer; + out pEnum: IEnumRegisterWordW): HResult; stdcall; + function EscapeA(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; + out plResult: LONG_PTR): HResult; stdcall; + function EscapeW(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; + out plResult: LONG_PTR): HResult; stdcall; + function GetCandidateListA(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; + out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; + function GetCandidateListW(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; + out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; + function GetCandidateListCountA(hIMC: LongWord; out pdwListSize: LongWord; + out pdwBufLen: LongWord): HResult; stdcall; + function GetCandidateListCountW(hIMC: LongWord; out pdwListSize: LongWord; + out pdwBufLen: LongWord): HResult; stdcall; + function GetCandidateWindow(hIMC: LongWord; dwIndex: LongWord; out pCandidate: CANDIDATEFORM): HResult; stdcall; + function GetCompositionFontA(hIMC: LongWord; out plf: LOGFONTA): HResult; stdcall; + function GetCompositionFontW(hIMC: LongWord; out plf: LOGFONTW): HResult; stdcall; + function GetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + out plCopied: Integer; out pBuf: Pointer): HResult; stdcall; + function GetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + out plCopied: Integer; out pBuf: Pointer): HResult; stdcall; + function GetCompositionWindow(hIMC: LongWord; out pCompForm: COMPOSITIONFORM): HResult; stdcall; + function GetContext(var hWnd: _RemotableHandle; out phIMC: LongWord): HResult; stdcall; + function GetConversionListA(var hKL: Pointer; hIMC: LongWord; pSrc: PAnsiChar; uBufLen: SYSUINT; + uFlag: SYSUINT; out pDst: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; + function GetConversionListW(var hKL: Pointer; hIMC: LongWord; pSrc: PWideChar; + uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; + out puCopied: SYSUINT): HResult; stdcall; + function GetConversionStatus(hIMC: LongWord; out pfdwConversion: LongWord; + out pfdwSentence: LongWord): HResult; stdcall; + function GetDefaultIMEWnd(var hWnd: _RemotableHandle; out phDefWnd: wireHWND): HResult; stdcall; + function GetDescriptionA(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PAnsiChar; + out puCopied: SYSUINT): HResult; stdcall; + function GetDescriptionW(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PWideChar; + out puCopied: SYSUINT): HResult; stdcall; + function GetGuideLineA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PAnsiChar; + out pdwResult: LongWord): HResult; stdcall; + function GetGuideLineW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PWideChar; + out pdwResult: LongWord): HResult; stdcall; + function GetIMEFileNameA(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PAnsiChar; + out puCopied: SYSUINT): HResult; stdcall; + function GetIMEFileNameW(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PWideChar; + out puCopied: SYSUINT): HResult; stdcall; + function GetOpenStatus(hIMC: LongWord): HResult; stdcall; + function GetProperty(var hKL: Pointer; fdwIndex: LongWord; out pdwProperty: LongWord): HResult; stdcall; + function GetRegisterWordStyleA(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFA; + out puCopied: SYSUINT): HResult; stdcall; + function GetRegisterWordStyleW(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFW; + out puCopied: SYSUINT): HResult; stdcall; + function GetStatusWindowPos(hIMC: LongWord; out pptPos: tagPOINT): HResult; stdcall; + function GetVirtualKey(var hWnd: _RemotableHandle; out puVirtualKey: SYSUINT): HResult; stdcall; + function InstallIMEA(szIMEFileName: PAnsiChar; szLayoutText: PAnsiChar; out phKL: Pointer): HResult; stdcall; + function InstallIMEW(szIMEFileName: PWideChar; szLayoutText: PWideChar; out phKL: Pointer): HResult; stdcall; + function IsIME(var hKL: Pointer): HResult; stdcall; + function IsUIMessageA(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR): HResult; stdcall; + function IsUIMessageW(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR): HResult; stdcall; + function NotifyIME(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; dwValue: LongWord): HResult; stdcall; + function REGISTERWORDA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; szRegister: PAnsiChar): HResult; stdcall; + function REGISTERWORDW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szRegister: PWideChar): HResult; stdcall; + function ReleaseContext(var hWnd: _RemotableHandle; hIMC: LongWord): HResult; stdcall; + function SetCandidateWindow(hIMC: LongWord; var pCandidate: CANDIDATEFORM): HResult; stdcall; + function SetCompositionFontA(hIMC: LongWord; var plf: LOGFONTA): HResult; stdcall; + function SetCompositionFontW(hIMC: LongWord; var plf: LOGFONTW): HResult; stdcall; + function SetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; + dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; + function SetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; + dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; + function SetCompositionWindow(hIMC: LongWord; var pCompForm: COMPOSITIONFORM): HResult; stdcall; + function SetConversionStatus(hIMC: LongWord; fdwConversion: LongWord; fdwSentence: LongWord): HResult; stdcall; + function SetOpenStatus(hIMC: LongWord; fOpen: Integer): HResult; stdcall; + function SetStatusWindowPos(hIMC: LongWord; var pptPos: tagPOINT): HResult; stdcall; + function SimulateHotKey(var hWnd: _RemotableHandle; dwHotKeyID: LongWord): HResult; stdcall; + function UnregisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; + szUnregister: PAnsiChar): HResult; stdcall; + function UnregisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szUnregister: PWideChar): HResult; stdcall; + function Activate(fRestoreLayout: Integer): HResult; stdcall; + function Deactivate: HResult; stdcall; + function OnDefWindowProc(var hWnd: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR; out plResult: LONG_PTR): HResult; stdcall; + function FilterClientWindows(var aaClassList: Word; uSize: SYSUINT): HResult; stdcall; + function GetCodePageA(var hKL: Pointer; out uCodePage: SYSUINT): HResult; stdcall; + function GetLangId(var hKL: Pointer; out plid: Word): HResult; stdcall; + function AssociateContextEx(var hWnd: _RemotableHandle; hIMC: LongWord; dwFlags: LongWord): HResult; stdcall; + function DisableIME(idThread: LongWord): HResult; stdcall; + function GetImeMenuItemsA(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; + var pImeParentMenu: IMEMENUITEMINFOA; + out pImeMenu: IMEMENUITEMINFOA; dwSize: LongWord; + out pdwResult: LongWord): HResult; stdcall; + function GetImeMenuItemsW(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; + var pImeParentMenu: IMEMENUITEMINFOW; + out pImeMenu: IMEMENUITEMINFOW; dwSize: LongWord; + out pdwResult: LongWord): HResult; stdcall; + function EnumInputContext(idThread: LongWord; out ppEnum: IEnumInputContext): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IActiveIMMIME +// Flags: (0) +// GUID: {08C03411-F96B-11D0-A475-00AA006BCC59} +// *********************************************************************// + IActiveIMMIME = interface(IUnknown) + ['{08C03411-F96B-11D0-A475-00AA006BCC59}'] + function AssociateContext(var hWnd: _RemotableHandle; hIME: LongWord; out phPrev: LongWord): HResult; stdcall; + function ConfigureIMEA(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; + var pData: REGISTERWORDA): HResult; stdcall; + function ConfigureIMEW(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; + var pData: REGISTERWORDW): HResult; stdcall; + function CreateContext(out phIMC: LongWord): HResult; stdcall; + function DestroyContext(hIME: LongWord): HResult; stdcall; + function EnumRegisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; + szRegister: PAnsiChar; var pData: Pointer; out pEnum: IEnumRegisterWordA): HResult; stdcall; + function EnumRegisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szRegister: PWideChar; var pData: Pointer; + out pEnum: IEnumRegisterWordW): HResult; stdcall; + function EscapeA(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; + out plResult: LONG_PTR): HResult; stdcall; + function EscapeW(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; + out plResult: LONG_PTR): HResult; stdcall; + function GetCandidateListA(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; + out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; + function GetCandidateListW(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; + out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; + function GetCandidateListCountA(hIMC: LongWord; out pdwListSize: LongWord; + out pdwBufLen: LongWord): HResult; stdcall; + function GetCandidateListCountW(hIMC: LongWord; out pdwListSize: LongWord; + out pdwBufLen: LongWord): HResult; stdcall; + function GetCandidateWindow(hIMC: LongWord; dwIndex: LongWord; out pCandidate: CANDIDATEFORM): HResult; stdcall; + function GetCompositionFontA(hIMC: LongWord; out plf: LOGFONTA): HResult; stdcall; + function GetCompositionFontW(hIMC: LongWord; out plf: LOGFONTW): HResult; stdcall; + function GetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + out plCopied: Integer; out pBuf: Pointer): HResult; stdcall; + function GetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + out plCopied: Integer; out pBuf: Pointer): HResult; stdcall; + function GetCompositionWindow(hIMC: LongWord; out pCompForm: COMPOSITIONFORM): HResult; stdcall; + function GetContext(var hWnd: _RemotableHandle; out phIMC: LongWord): HResult; stdcall; + function GetConversionListA(var hKL: Pointer; hIMC: LongWord; pSrc: PAnsiChar; uBufLen: SYSUINT; + uFlag: SYSUINT; out pDst: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; + function GetConversionListW(var hKL: Pointer; hIMC: LongWord; pSrc: PWideChar; + uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; + out puCopied: SYSUINT): HResult; stdcall; + function GetConversionStatus(hIMC: LongWord; out pfdwConversion: LongWord; + out pfdwSentence: LongWord): HResult; stdcall; + function GetDefaultIMEWnd(var hWnd: _RemotableHandle; out phDefWnd: wireHWND): HResult; stdcall; + function GetDescriptionA(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PAnsiChar; + out puCopied: SYSUINT): HResult; stdcall; + function GetDescriptionW(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PWideChar; + out puCopied: SYSUINT): HResult; stdcall; + function GetGuideLineA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PAnsiChar; + out pdwResult: LongWord): HResult; stdcall; + function GetGuideLineW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PWideChar; + out pdwResult: LongWord): HResult; stdcall; + function GetIMEFileNameA(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PAnsiChar; + out puCopied: SYSUINT): HResult; stdcall; + function GetIMEFileNameW(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PWideChar; + out puCopied: SYSUINT): HResult; stdcall; + function GetOpenStatus(hIMC: LongWord): HResult; stdcall; + function GetProperty(var hKL: Pointer; fdwIndex: LongWord; out pdwProperty: LongWord): HResult; stdcall; + function GetRegisterWordStyleA(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFA; + out puCopied: SYSUINT): HResult; stdcall; + function GetRegisterWordStyleW(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFW; + out puCopied: SYSUINT): HResult; stdcall; + function GetStatusWindowPos(hIMC: LongWord; out pptPos: tagPOINT): HResult; stdcall; + function GetVirtualKey(var hWnd: _RemotableHandle; out puVirtualKey: SYSUINT): HResult; stdcall; + function InstallIMEA(szIMEFileName: PAnsiChar; szLayoutText: PAnsiChar; out phKL: Pointer): HResult; stdcall; + function InstallIMEW(szIMEFileName: PWideChar; szLayoutText: PWideChar; out phKL: Pointer): HResult; stdcall; + function IsIME(var hKL: Pointer): HResult; stdcall; + function IsUIMessageA(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR): HResult; stdcall; + function IsUIMessageW(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR): HResult; stdcall; + function NotifyIME(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; dwValue: LongWord): HResult; stdcall; + function REGISTERWORDA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; szRegister: PAnsiChar): HResult; stdcall; + function REGISTERWORDW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szRegister: PWideChar): HResult; stdcall; + function ReleaseContext(var hWnd: _RemotableHandle; hIMC: LongWord): HResult; stdcall; + function SetCandidateWindow(hIMC: LongWord; var pCandidate: CANDIDATEFORM): HResult; stdcall; + function SetCompositionFontA(hIMC: LongWord; var plf: LOGFONTA): HResult; stdcall; + function SetCompositionFontW(hIMC: LongWord; var plf: LOGFONTW): HResult; stdcall; + function SetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; + dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; + function SetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; + dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; + function SetCompositionWindow(hIMC: LongWord; var pCompForm: COMPOSITIONFORM): HResult; stdcall; + function SetConversionStatus(hIMC: LongWord; fdwConversion: LongWord; fdwSentence: LongWord): HResult; stdcall; + function SetOpenStatus(hIMC: LongWord; fOpen: Integer): HResult; stdcall; + function SetStatusWindowPos(hIMC: LongWord; var pptPos: tagPOINT): HResult; stdcall; + function SimulateHotKey(var hWnd: _RemotableHandle; dwHotKeyID: LongWord): HResult; stdcall; + function UnregisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; + szUnregister: PAnsiChar): HResult; stdcall; + function UnregisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szUnregister: PWideChar): HResult; stdcall; + function GenerateMessage(hIMC: LongWord): HResult; stdcall; + function LockIMC(hIMC: LongWord; out ppIMC: PUserType12): HResult; stdcall; + function UnlockIMC(hIMC: LongWord): HResult; stdcall; + function GetIMCLockCount(hIMC: LongWord; out pdwLockCount: LongWord): HResult; stdcall; + function CreateIMCC(dwSize: LongWord; out phIMCC: LongWord): HResult; stdcall; + function DestroyIMCC(hIMCC: LongWord): HResult; stdcall; + function LockIMCC(hIMCC: LongWord; out ppv: Pointer): HResult; stdcall; + function UnlockIMCC(hIMCC: LongWord): HResult; stdcall; + function ReSizeIMCC(hIMCC: LongWord; dwSize: LongWord; out phIMCC: LongWord): HResult; stdcall; + function GetIMCCSize(hIMCC: LongWord; out pdwSize: LongWord): HResult; stdcall; + function GetIMCCLockCount(hIMCC: LongWord; out pdwLockCount: LongWord): HResult; stdcall; + function GetHotKey(dwHotKeyID: LongWord; out puModifiers: SYSUINT; out puVKey: SYSUINT; + out phKL: Pointer): HResult; stdcall; + function SetHotKey(dwHotKeyID: LongWord; uModifiers: SYSUINT; uVKey: SYSUINT; var hKL: Pointer): HResult; stdcall; + function CreateSoftKeyboard(uType: SYSUINT; var hOwner: _RemotableHandle; x: SYSINT; + y: SYSINT; out phSoftKbdWnd: wireHWND): HResult; stdcall; + function DestroySoftKeyboard(var hSoftKbdWnd: _RemotableHandle): HResult; stdcall; + function ShowSoftKeyboard(var hSoftKbdWnd: _RemotableHandle; nCmdShow: SYSINT): HResult; stdcall; + function GetCodePageA(var hKL: Pointer; out uCodePage: SYSUINT): HResult; stdcall; + function GetLangId(var hKL: Pointer; out plid: Word): HResult; stdcall; + function KeybdEvent(lgidIME: Word; bVk: Byte; bScan: Byte; dwFlags: LongWord; + dwExtraInfo: LongWord): HResult; stdcall; + function LockModal: HResult; stdcall; + function UnlockModal: HResult; stdcall; + function AssociateContextEx(var hWnd: _RemotableHandle; hIMC: LongWord; dwFlags: LongWord): HResult; stdcall; + function DisableIME(idThread: LongWord): HResult; stdcall; + function GetImeMenuItemsA(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; + var pImeParentMenu: IMEMENUITEMINFOA; + out pImeMenu: IMEMENUITEMINFOA; dwSize: LongWord; + out pdwResult: LongWord): HResult; stdcall; + function GetImeMenuItemsW(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; + var pImeParentMenu: IMEMENUITEMINFOW; + out pImeMenu: IMEMENUITEMINFOW; dwSize: LongWord; + out pdwResult: LongWord): HResult; stdcall; + function EnumInputContext(idThread: LongWord; out ppEnum: IEnumInputContext): HResult; stdcall; + function RequestMessageA(hIMC: LongWord; wParam: UINT_PTR; lParam: LONG_PTR; + out plResult: LONG_PTR): HResult; stdcall; + function RequestMessageW(hIMC: LongWord; wParam: UINT_PTR; lParam: LONG_PTR; + out plResult: LONG_PTR): HResult; stdcall; + function SendIMCA(var hWnd: _RemotableHandle; uMsg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR; out plResult: LONG_PTR): HResult; stdcall; + function SendIMCW(var hWnd: _RemotableHandle; uMsg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR; out plResult: LONG_PTR): HResult; stdcall; + function IsSleeping: HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IActiveIME +// Flags: (0) +// GUID: {6FE20962-D077-11D0-8FE7-00AA006BCC59} +// *********************************************************************// + IActiveIME = interface(IUnknown) + ['{6FE20962-D077-11D0-8FE7-00AA006BCC59}'] + function Inquire(dwSystemInfoFlags: LongWord; out pIMEInfo: IMEINFO; szWndClass: PWideChar; + out pdwPrivate: LongWord): HResult; stdcall; + function ConversionList(hIMC: LongWord; szSource: PWideChar; uFlag: SYSUINT; uBufLen: SYSUINT; + out pDest: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; + function Configure(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; + var pRegisterWord: REGISTERWORDW): HResult; stdcall; + function Destroy(uReserved: SYSUINT): HResult; stdcall; + function Escape(hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; out plResult: LONG_PTR): HResult; stdcall; + function SetActiveContext(hIMC: LongWord; fFlag: Integer): HResult; stdcall; + function ProcessKey(hIMC: LongWord; uVirKey: SYSUINT; lParam: LongWord; var pbKeyState: Byte): HResult; stdcall; + function Notify(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; dwValue: LongWord): HResult; stdcall; + function Select(hIMC: LongWord; fSelect: Integer): HResult; stdcall; + function SetCompositionString(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; + dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; + function ToAsciiEx(uVirKey: SYSUINT; uScanCode: SYSUINT; var pbKeyState: Byte; + fuState: SYSUINT; hIMC: LongWord; out pdwTransBuf: LongWord; + out puSize: SYSUINT): HResult; stdcall; + function RegisterWord(szReading: PWideChar; dwStyle: LongWord; szString: PWideChar): HResult; stdcall; + function UnregisterWord(szReading: PWideChar; dwStyle: LongWord; szString: PWideChar): HResult; stdcall; + function GetRegisterWordStyle(nItem: SYSUINT; out pStyleBuf: STYLEBUFW; out puBufSize: SYSUINT): HResult; stdcall; + function EnumRegisterWord(szReading: PWideChar; dwStyle: LongWord; szRegister: PWideChar; + var pData: Pointer; out ppEnum: IEnumRegisterWordW): HResult; stdcall; + function GetCodePageA(out uCodePage: SYSUINT): HResult; stdcall; + function GetLangId(out plid: Word): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IActiveIME2 +// Flags: (0) +// GUID: {E1C4BF0E-2D53-11D2-93E1-0060B067B86E} +// *********************************************************************// + IActiveIME2 = interface(IActiveIME) + ['{E1C4BF0E-2D53-11D2-93E1-0060B067B86E}'] + function Sleep: HResult; stdcall; + function Unsleep(fDead: Integer): HResult; stdcall; + end; + +// *********************************************************************// +// The Class CoCActiveIMM provides a Create and CreateRemote method to +// create instances of the default interface IActiveIMMApp exposed by +// the CoClass CActiveIMM. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoCActiveIMM = class + class function Create: IActiveIMMApp; + class function CreateRemote(const MachineName: AnsiString): IActiveIMMApp; + end; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TCActiveIMM +// Help String : +// Default Interface: IActiveIMMApp +// Def. Intf. DISP? : No +// Event Interface: +// TypeFlags : (2) CanCreate +// *********************************************************************// +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + TCActiveIMMProperties= class; +{$ENDIF} + TCActiveIMM = class(TOleServer) + private + FIntf: IActiveIMMApp; +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps: TCActiveIMMProperties; + function GetServerProperties: TCActiveIMMProperties; +{$ENDIF} + function GetDefaultInterface: IActiveIMMApp; + protected + procedure InitServerData; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: IActiveIMMApp); + procedure Disconnect; override; + function AssociateContext(var hWnd: _RemotableHandle; hIME: LongWord; out phPrev: LongWord): HResult; + function ConfigureIMEA(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; + var pData: REGISTERWORDA): HResult; + function ConfigureIMEW(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; + var pData: REGISTERWORDW): HResult; + function CreateContext(out phIMC: LongWord): HResult; + function DestroyContext(hIME: LongWord): HResult; + function EnumRegisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; + szRegister: PAnsiChar; var pData: Pointer; out pEnum: IEnumRegisterWordA): HResult; + function EnumRegisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szRegister: PWideChar; var pData: Pointer; + out pEnum: IEnumRegisterWordW): HResult; + function EscapeA(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; + out plResult: LONG_PTR): HResult; + function EscapeW(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; + out plResult: LONG_PTR): HResult; + function GetCandidateListA(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; + out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; + function GetCandidateListW(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; + out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; + function GetCandidateListCountA(hIMC: LongWord; out pdwListSize: LongWord; + out pdwBufLen: LongWord): HResult; + function GetCandidateListCountW(hIMC: LongWord; out pdwListSize: LongWord; + out pdwBufLen: LongWord): HResult; + function GetCandidateWindow(hIMC: LongWord; dwIndex: LongWord; out pCandidate: CANDIDATEFORM): HResult; + function GetCompositionFontA(hIMC: LongWord; out plf: LOGFONTA): HResult; + function GetCompositionFontW(hIMC: LongWord; out plf: LOGFONTW): HResult; + function GetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + out plCopied: Integer; out pBuf: Pointer): HResult; + function GetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + out plCopied: Integer; out pBuf: Pointer): HResult; + function GetCompositionWindow(hIMC: LongWord; out pCompForm: COMPOSITIONFORM): HResult; + function GetContext(var hWnd: _RemotableHandle; out phIMC: LongWord): HResult; + function GetConversionListA(var hKL: Pointer; hIMC: LongWord; pSrc: PAnsiChar; uBufLen: SYSUINT; + uFlag: SYSUINT; out pDst: CANDIDATELIST; out puCopied: SYSUINT): HResult; + function GetConversionListW(var hKL: Pointer; hIMC: LongWord; pSrc: PWideChar; + uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; + out puCopied: SYSUINT): HResult; + function GetConversionStatus(hIMC: LongWord; out pfdwConversion: LongWord; + out pfdwSentence: LongWord): HResult; + function GetDefaultIMEWnd(var hWnd: _RemotableHandle; out phDefWnd: wireHWND): HResult; + function GetDescriptionA(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PAnsiChar; + out puCopied: SYSUINT): HResult; + function GetDescriptionW(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PWideChar; + out puCopied: SYSUINT): HResult; + function GetGuideLineA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PAnsiChar; + out pdwResult: LongWord): HResult; + function GetGuideLineW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PWideChar; + out pdwResult: LongWord): HResult; + function GetIMEFileNameA(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PAnsiChar; + out puCopied: SYSUINT): HResult; + function GetIMEFileNameW(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PWideChar; + out puCopied: SYSUINT): HResult; + function GetOpenStatus(hIMC: LongWord): HResult; + function GetProperty(var hKL: Pointer; fdwIndex: LongWord; out pdwProperty: LongWord): HResult; + function GetRegisterWordStyleA(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFA; + out puCopied: SYSUINT): HResult; + function GetRegisterWordStyleW(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFW; + out puCopied: SYSUINT): HResult; + function GetStatusWindowPos(hIMC: LongWord; out pptPos: tagPOINT): HResult; + function GetVirtualKey(var hWnd: _RemotableHandle; out puVirtualKey: SYSUINT): HResult; + function InstallIMEA(szIMEFileName: PAnsiChar; szLayoutText: PAnsiChar; out phKL: Pointer): HResult; + function InstallIMEW(szIMEFileName: PWideChar; szLayoutText: PWideChar; out phKL: Pointer): HResult; + function IsIME(var hKL: Pointer): HResult; + function IsUIMessageA(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR): HResult; + function IsUIMessageW(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR): HResult; + function NotifyIME(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; dwValue: LongWord): HResult; + function REGISTERWORDA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; szRegister: PAnsiChar): HResult; + function REGISTERWORDW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szRegister: PWideChar): HResult; + function ReleaseContext(var hWnd: _RemotableHandle; hIMC: LongWord): HResult; + function SetCandidateWindow(hIMC: LongWord; var pCandidate: CANDIDATEFORM): HResult; + function SetCompositionFontA(hIMC: LongWord; var plf: LOGFONTA): HResult; + function SetCompositionFontW(hIMC: LongWord; var plf: LOGFONTW): HResult; + function SetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; + dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; + function SetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; + dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; + function SetCompositionWindow(hIMC: LongWord; var pCompForm: COMPOSITIONFORM): HResult; + function SetConversionStatus(hIMC: LongWord; fdwConversion: LongWord; fdwSentence: LongWord): HResult; + function SetOpenStatus(hIMC: LongWord; fOpen: Integer): HResult; + function SetStatusWindowPos(hIMC: LongWord; var pptPos: tagPOINT): HResult; + function SimulateHotKey(var hWnd: _RemotableHandle; dwHotKeyID: LongWord): HResult; + function UnregisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; + szUnregister: PAnsiChar): HResult; + function UnregisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szUnregister: PWideChar): HResult; + function Activate(fRestoreLayout: Integer): HResult; + function Deactivate: HResult; + function OnDefWindowProc(var hWnd: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR; out plResult: LONG_PTR): HResult; + function FilterClientWindows(var aaClassList: Word; uSize: SYSUINT): HResult; + function GetCodePageA(var hKL: Pointer; out uCodePage: SYSUINT): HResult; + function GetLangId(var hKL: Pointer; out plid: Word): HResult; + function AssociateContextEx(var hWnd: _RemotableHandle; hIMC: LongWord; dwFlags: LongWord): HResult; + function DisableIME(idThread: LongWord): HResult; + function GetImeMenuItemsA(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; + var pImeParentMenu: IMEMENUITEMINFOA; + out pImeMenu: IMEMENUITEMINFOA; dwSize: LongWord; + out pdwResult: LongWord): HResult; + function GetImeMenuItemsW(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; + var pImeParentMenu: IMEMENUITEMINFOW; + out pImeMenu: IMEMENUITEMINFOW; dwSize: LongWord; + out pdwResult: LongWord): HResult; + function EnumInputContext(idThread: LongWord; out ppEnum: IEnumInputContext): HResult; + property DefaultInterface: IActiveIMMApp read GetDefaultInterface; + published +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + property Server: TCActiveIMMProperties read GetServerProperties; +{$ENDIF} + end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +// *********************************************************************// +// OLE Server Properties Proxy Class +// Server Object : TCActiveIMM +// (This object is used by the IDE's Property Inspector to allow editing +// of the properties of this server) +// *********************************************************************// + TCActiveIMMProperties = class(TPersistent) + private + FServer: TCActiveIMM; + function GetDefaultInterface: IActiveIMMApp; + constructor Create(AServer: TCActiveIMM); + protected + public + property DefaultInterface: IActiveIMMApp read GetDefaultInterface; + published + end; +{$ENDIF} + +implementation + +uses + ComObj; + +class function CoCActiveIMM.Create: IActiveIMMApp; +begin + Result := CreateComObject(CLASS_CActiveIMM) as IActiveIMMApp; +end; + +class function CoCActiveIMM.CreateRemote(const MachineName: AnsiString): IActiveIMMApp; +begin + Result := CreateRemoteComObject(MachineName, CLASS_CActiveIMM) as IActiveIMMApp; +end; + +procedure TCActiveIMM.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{4955DD33-B159-11D0-8FCF-00AA006BCC59}'; + IntfIID: '{08C0E040-62D1-11D1-9326-0060B067B86E}'; + EventIID: ''; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TCActiveIMM.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + Fintf:= punk as IActiveIMMApp; + end; +end; + +procedure TCActiveIMM.ConnectTo(svrIntf: IActiveIMMApp); +begin + Disconnect; + FIntf := svrIntf; +end; + +procedure TCActiveIMM.DisConnect; +begin + if Fintf <> nil then + begin + FIntf := nil; + end; +end; + +function TCActiveIMM.GetDefaultInterface: IActiveIMMApp; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation'); + Result := FIntf; +end; + +constructor TCActiveIMM.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps := TCActiveIMMProperties.Create(Self); +{$ENDIF} +end; + +destructor TCActiveIMM.Destroy; +begin +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} + FProps.Free; +{$ENDIF} + inherited Destroy; +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +function TCActiveIMM.GetServerProperties: TCActiveIMMProperties; +begin + Result := FProps; +end; +{$ENDIF} + +function TCActiveIMM.AssociateContext(var hWnd: _RemotableHandle; hIME: LongWord; + out phPrev: LongWord): HResult; +begin + Result := DefaultInterface.AssociateContext(hWnd, hIME, phPrev); +end; + +function TCActiveIMM.ConfigureIMEA(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; + var pData: REGISTERWORDA): HResult; +begin + Result := DefaultInterface.ConfigureIMEA(hKL, hWnd, dwMode, pData); +end; + +function TCActiveIMM.ConfigureIMEW(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; + var pData: REGISTERWORDW): HResult; +begin + Result := DefaultInterface.ConfigureIMEW(hKL, hWnd, dwMode, pData); +end; + +function TCActiveIMM.CreateContext(out phIMC: LongWord): HResult; +begin + Result := DefaultInterface.CreateContext(phIMC); +end; + +function TCActiveIMM.DestroyContext(hIME: LongWord): HResult; +begin + Result := DefaultInterface.DestroyContext(hIME); +end; + +function TCActiveIMM.EnumRegisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; + szRegister: PAnsiChar; var pData: Pointer; + out pEnum: IEnumRegisterWordA): HResult; +begin + Result := DefaultInterface.EnumRegisterWordA(hKL, szReading, dwStyle, szRegister, pData, pEnum); +end; + +function TCActiveIMM.EnumRegisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szRegister: PWideChar; var pData: Pointer; + out pEnum: IEnumRegisterWordW): HResult; +begin + Result := DefaultInterface.EnumRegisterWordW(hKL, szReading, dwStyle, szRegister, pData, pEnum); +end; + +function TCActiveIMM.EscapeA(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; + var pData: Pointer; out plResult: LONG_PTR): HResult; +begin + Result := DefaultInterface.EscapeA(hKL, hIMC, uEscape, pData, plResult); +end; + +function TCActiveIMM.EscapeW(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; + var pData: Pointer; out plResult: LONG_PTR): HResult; +begin + Result := DefaultInterface.EscapeW(hKL, hIMC, uEscape, pData, plResult); +end; + +function TCActiveIMM.GetCandidateListA(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; + out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetCandidateListA(hIMC, dwIndex, uBufLen, pCandList, puCopied); +end; + +function TCActiveIMM.GetCandidateListW(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; + out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetCandidateListW(hIMC, dwIndex, uBufLen, pCandList, puCopied); +end; + +function TCActiveIMM.GetCandidateListCountA(hIMC: LongWord; out pdwListSize: LongWord; + out pdwBufLen: LongWord): HResult; +begin + Result := DefaultInterface.GetCandidateListCountA(hIMC, pdwListSize, pdwBufLen); +end; + +function TCActiveIMM.GetCandidateListCountW(hIMC: LongWord; out pdwListSize: LongWord; + out pdwBufLen: LongWord): HResult; +begin + Result := DefaultInterface.GetCandidateListCountW(hIMC, pdwListSize, pdwBufLen); +end; + +function TCActiveIMM.GetCandidateWindow(hIMC: LongWord; dwIndex: LongWord; + out pCandidate: CANDIDATEFORM): HResult; +begin + Result := DefaultInterface.GetCandidateWindow(hIMC, dwIndex, pCandidate); +end; + +function TCActiveIMM.GetCompositionFontA(hIMC: LongWord; out plf: LOGFONTA): HResult; +begin + Result := DefaultInterface.GetCompositionFontA(hIMC, plf); +end; + +function TCActiveIMM.GetCompositionFontW(hIMC: LongWord; out plf: LOGFONTW): HResult; +begin + Result := DefaultInterface.GetCompositionFontW(hIMC, plf); +end; + +function TCActiveIMM.GetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + out plCopied: Integer; out pBuf: Pointer): HResult; +begin + Result := DefaultInterface.GetCompositionStringA(hIMC, dwIndex, dwBufLen, plCopied, pBuf); +end; + +function TCActiveIMM.GetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + out plCopied: Integer; out pBuf: Pointer): HResult; +begin + Result := DefaultInterface.GetCompositionStringW(hIMC, dwIndex, dwBufLen, plCopied, pBuf); +end; + +function TCActiveIMM.GetCompositionWindow(hIMC: LongWord; out pCompForm: COMPOSITIONFORM): HResult; +begin + Result := DefaultInterface.GetCompositionWindow(hIMC, pCompForm); +end; + +function TCActiveIMM.GetContext(var hWnd: _RemotableHandle; out phIMC: LongWord): HResult; +begin + Result := DefaultInterface.GetContext(hWnd, phIMC); +end; + +function TCActiveIMM.GetConversionListA(var hKL: Pointer; hIMC: LongWord; pSrc: PAnsiChar; + uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; + out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetConversionListA(hKL, hIMC, pSrc, uBufLen, uFlag, pDst, puCopied); +end; + +function TCActiveIMM.GetConversionListW(var hKL: Pointer; hIMC: LongWord; pSrc: PWideChar; + uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; + out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetConversionListW(hKL, hIMC, pSrc, uBufLen, uFlag, pDst, puCopied); +end; + +function TCActiveIMM.GetConversionStatus(hIMC: LongWord; out pfdwConversion: LongWord; + out pfdwSentence: LongWord): HResult; +begin + Result := DefaultInterface.GetConversionStatus(hIMC, pfdwConversion, pfdwSentence); +end; + +function TCActiveIMM.GetDefaultIMEWnd(var hWnd: _RemotableHandle; out phDefWnd: wireHWND): HResult; +begin + Result := DefaultInterface.GetDefaultIMEWnd(hWnd, phDefWnd); +end; + +function TCActiveIMM.GetDescriptionA(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PAnsiChar; + out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetDescriptionA(hKL, uBufLen, szDescription, puCopied); +end; + +function TCActiveIMM.GetDescriptionW(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PWideChar; + out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetDescriptionW(hKL, uBufLen, szDescription, puCopied); +end; + +function TCActiveIMM.GetGuideLineA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + pBuf: PAnsiChar; out pdwResult: LongWord): HResult; +begin + Result := DefaultInterface.GetGuideLineA(hIMC, dwIndex, dwBufLen, pBuf, pdwResult); +end; + +function TCActiveIMM.GetGuideLineW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; + pBuf: PWideChar; out pdwResult: LongWord): HResult; +begin + Result := DefaultInterface.GetGuideLineW(hIMC, dwIndex, dwBufLen, pBuf, pdwResult); +end; + +function TCActiveIMM.GetIMEFileNameA(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PAnsiChar; + out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetIMEFileNameA(hKL, uBufLen, szFileName, puCopied); +end; + +function TCActiveIMM.GetIMEFileNameW(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PWideChar; + out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetIMEFileNameW(hKL, uBufLen, szFileName, puCopied); +end; + +function TCActiveIMM.GetOpenStatus(hIMC: LongWord): HResult; +begin + Result := DefaultInterface.GetOpenStatus(hIMC); +end; + +function TCActiveIMM.GetProperty(var hKL: Pointer; fdwIndex: LongWord; out pdwProperty: LongWord): HResult; +begin + Result := DefaultInterface.GetProperty(hKL, fdwIndex, pdwProperty); +end; + +function TCActiveIMM.GetRegisterWordStyleA(var hKL: Pointer; nItem: SYSUINT; + out pStyleBuf: STYLEBUFA; out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetRegisterWordStyleA(hKL, nItem, pStyleBuf, puCopied); +end; + +function TCActiveIMM.GetRegisterWordStyleW(var hKL: Pointer; nItem: SYSUINT; + out pStyleBuf: STYLEBUFW; out puCopied: SYSUINT): HResult; +begin + Result := DefaultInterface.GetRegisterWordStyleW(hKL, nItem, pStyleBuf, puCopied); +end; + +function TCActiveIMM.GetStatusWindowPos(hIMC: LongWord; out pptPos: tagPOINT): HResult; +begin + Result := DefaultInterface.GetStatusWindowPos(hIMC, pptPos); +end; + +function TCActiveIMM.GetVirtualKey(var hWnd: _RemotableHandle; out puVirtualKey: SYSUINT): HResult; +begin + Result := DefaultInterface.GetVirtualKey(hWnd, puVirtualKey); +end; + +function TCActiveIMM.InstallIMEA(szIMEFileName: PAnsiChar; szLayoutText: PAnsiChar; out phKL: Pointer): HResult; +begin + Result := DefaultInterface.InstallIMEA(szIMEFileName, szLayoutText, phKL); +end; + +function TCActiveIMM.InstallIMEW(szIMEFileName: PWideChar; szLayoutText: PWideChar; + out phKL: Pointer): HResult; +begin + Result := DefaultInterface.InstallIMEW(szIMEFileName, szLayoutText, phKL); +end; + +function TCActiveIMM.IsIME(var hKL: Pointer): HResult; +begin + Result := DefaultInterface.IsIME(hKL); +end; + +function TCActiveIMM.IsUIMessageA(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR): HResult; +begin + Result := DefaultInterface.IsUIMessageA(hWndIME, msg, wParam, lParam); +end; + +function TCActiveIMM.IsUIMessageW(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR): HResult; +begin + Result := DefaultInterface.IsUIMessageW(hWndIME, msg, wParam, lParam); +end; + +function TCActiveIMM.NotifyIME(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; + dwValue: LongWord): HResult; +begin + Result := DefaultInterface.NotifyIME(hIMC, dwAction, dwIndex, dwValue); +end; + +function TCActiveIMM.REGISTERWORDA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; + szRegister: PAnsiChar): HResult; +begin + Result := DefaultInterface.REGISTERWORDA(hKL, szReading, dwStyle, szRegister); +end; + +function TCActiveIMM.REGISTERWORDW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szRegister: PWideChar): HResult; +begin + Result := DefaultInterface.REGISTERWORDW(hKL, szReading, dwStyle, szRegister); +end; + +function TCActiveIMM.ReleaseContext(var hWnd: _RemotableHandle; hIMC: LongWord): HResult; +begin + Result := DefaultInterface.ReleaseContext(hWnd, hIMC); +end; + +function TCActiveIMM.SetCandidateWindow(hIMC: LongWord; var pCandidate: CANDIDATEFORM): HResult; +begin + Result := DefaultInterface.SetCandidateWindow(hIMC, pCandidate); +end; + +function TCActiveIMM.SetCompositionFontA(hIMC: LongWord; var plf: LOGFONTA): HResult; +begin + Result := DefaultInterface.SetCompositionFontA(hIMC, plf); +end; + +function TCActiveIMM.SetCompositionFontW(hIMC: LongWord; var plf: LOGFONTW): HResult; +begin + Result := DefaultInterface.SetCompositionFontW(hIMC, plf); +end; + +function TCActiveIMM.SetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; + dwCompLen: LongWord; var pRead: Pointer; + dwReadLen: LongWord): HResult; +begin + Result := DefaultInterface.SetCompositionStringA(hIMC, dwIndex, pComp, dwCompLen, pRead, dwReadLen); +end; + +function TCActiveIMM.SetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; + dwCompLen: LongWord; var pRead: Pointer; + dwReadLen: LongWord): HResult; +begin + Result := DefaultInterface.SetCompositionStringW(hIMC, dwIndex, pComp, dwCompLen, pRead, dwReadLen); +end; + +function TCActiveIMM.SetCompositionWindow(hIMC: LongWord; var pCompForm: COMPOSITIONFORM): HResult; +begin + Result := DefaultInterface.SetCompositionWindow(hIMC, pCompForm); +end; + +function TCActiveIMM.SetConversionStatus(hIMC: LongWord; fdwConversion: LongWord; + fdwSentence: LongWord): HResult; +begin + Result := DefaultInterface.SetConversionStatus(hIMC, fdwConversion, fdwSentence); +end; + +function TCActiveIMM.SetOpenStatus(hIMC: LongWord; fOpen: Integer): HResult; +begin + Result := DefaultInterface.SetOpenStatus(hIMC, fOpen); +end; + +function TCActiveIMM.SetStatusWindowPos(hIMC: LongWord; var pptPos: tagPOINT): HResult; +begin + Result := DefaultInterface.SetStatusWindowPos(hIMC, pptPos); +end; + +function TCActiveIMM.SimulateHotKey(var hWnd: _RemotableHandle; dwHotKeyID: LongWord): HResult; +begin + Result := DefaultInterface.SimulateHotKey(hWnd, dwHotKeyID); +end; + +function TCActiveIMM.UnregisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; + szUnregister: PAnsiChar): HResult; +begin + Result := DefaultInterface.UnregisterWordA(hKL, szReading, dwStyle, szUnregister); +end; + +function TCActiveIMM.UnregisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; + szUnregister: PWideChar): HResult; +begin + Result := DefaultInterface.UnregisterWordW(hKL, szReading, dwStyle, szUnregister); +end; + +function TCActiveIMM.Activate(fRestoreLayout: Integer): HResult; +begin + Result := DefaultInterface.Activate(fRestoreLayout); +end; + +function TCActiveIMM.Deactivate: HResult; +begin + Result := DefaultInterface.Deactivate; +end; + +function TCActiveIMM.OnDefWindowProc(var hWnd: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; + lParam: LONG_PTR; out plResult: LONG_PTR): HResult; +begin + Result := DefaultInterface.OnDefWindowProc(hWnd, msg, wParam, lParam, plResult); +end; + +function TCActiveIMM.FilterClientWindows(var aaClassList: Word; uSize: SYSUINT): HResult; +begin + Result := DefaultInterface.FilterClientWindows(aaClassList, uSize); +end; + +function TCActiveIMM.GetCodePageA(var hKL: Pointer; out uCodePage: SYSUINT): HResult; +begin + Result := DefaultInterface.GetCodePageA(hKL, uCodePage); +end; + +function TCActiveIMM.GetLangId(var hKL: Pointer; out plid: Word): HResult; +begin + Result := DefaultInterface.GetLangId(hKL, plid); +end; + +function TCActiveIMM.AssociateContextEx(var hWnd: _RemotableHandle; hIMC: LongWord; + dwFlags: LongWord): HResult; +begin + Result := DefaultInterface.AssociateContextEx(hWnd, hIMC, dwFlags); +end; + +function TCActiveIMM.DisableIME(idThread: LongWord): HResult; +begin + Result := DefaultInterface.DisableIME(idThread); +end; + +function TCActiveIMM.GetImeMenuItemsA(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; + var pImeParentMenu: IMEMENUITEMINFOA; + out pImeMenu: IMEMENUITEMINFOA; dwSize: LongWord; + out pdwResult: LongWord): HResult; +begin + Result := DefaultInterface.GetImeMenuItemsA(hIMC, dwFlags, dwType, pImeParentMenu, pImeMenu, + dwSize, pdwResult); +end; + +function TCActiveIMM.GetImeMenuItemsW(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; + var pImeParentMenu: IMEMENUITEMINFOW; + out pImeMenu: IMEMENUITEMINFOW; dwSize: LongWord; + out pdwResult: LongWord): HResult; +begin + Result := DefaultInterface.GetImeMenuItemsW(hIMC, dwFlags, dwType, pImeParentMenu, pImeMenu, + dwSize, pdwResult); +end; + +function TCActiveIMM.EnumInputContext(idThread: LongWord; out ppEnum: IEnumInputContext): HResult; +begin + Result := DefaultInterface.EnumInputContext(idThread, ppEnum); +end; + +{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} +constructor TCActiveIMMProperties.Create(AServer: TCActiveIMM); +begin + inherited Create; + FServer := AServer; +end; + +function TCActiveIMMProperties.GetDefaultInterface: IActiveIMMApp; +begin + Result := FServer.DefaultInterface; +end; + +{$ENDIF} + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas new file mode 100644 index 0000000000..0f3e69893c --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas @@ -0,0 +1,835 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntActnList; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Controls, ActnList, Buttons, ExtCtrls, ComCtrls, StdCtrls, Menus; + +type +{TNT-WARN TActionList} + TTntActionList = class(TActionList{TNT-ALLOW TActionList}) + private + FCheckActionsTimer: TTimer; + procedure CheckActions(Sender: TObject); + public + constructor Create(AOwner: TComponent); override; + end; + + ITntAction = interface + ['{59D0AE37-8161-4AD6-9102-14B28E5761EB}'] + end; + +//--------------------------------------------------------------------------------------------- +// ACTIONS +//--------------------------------------------------------------------------------------------- + +{TNT-WARN TCustomAction} + TTntCustomAction = class(TCustomAction{TNT-ALLOW TCustomAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TAction} + TTntAction = class(TAction{TNT-ALLOW TAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +//--------------------------------------------------------------------------------------------- + +// MENU ACTION LINK +//--------------------------------------------------------------------------------------------- + +{TNT-WARN TMenuActionLink} + TTntMenuActionLink = class(TMenuActionLink{TNT-ALLOW TMenuActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +//--------------------------------------------------------------------------------------------- +// CONTROL ACTION LINKS +//--------------------------------------------------------------------------------------------- + +{TNT-WARN TListViewActionLink} + TTntListViewActionLink = class(TListViewActionLink{TNT-ALLOW TListViewActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TComboBoxExActionLink} + TTntComboBoxExActionLink = class(TComboBoxExActionLink{TNT-ALLOW TComboBoxExActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TSpeedButtonActionLink} + TTntSpeedButtonActionLink = class(TSpeedButtonActionLink{TNT-ALLOW TSpeedButtonActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + {$IFDEF COMPILER_10_UP} + function IsImageIndexLinked: Boolean; override; + procedure SetImageIndex(Value: Integer); override; + {$ENDIF} + end; + +{$IFDEF COMPILER_10_UP} +{TNT-WARN TBitBtnActionLink} + TTntBitBtnActionLink = class(TBitBtnActionLink{TNT-ALLOW TBitBtnActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + {$IFDEF COMPILER_10_UP} + function IsImageIndexLinked: Boolean; override; + procedure SetImageIndex(Value: Integer); override; + {$ENDIF} + end; +{$ENDIF} + +{TNT-WARN TToolButtonActionLink} + TTntToolButtonActionLink = class(TToolButtonActionLink{TNT-ALLOW TToolButtonActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TButtonActionLink} + TTntButtonActionLink = class(TButtonActionLink{TNT-ALLOW TButtonActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TWinControlActionLink} + TTntWinControlActionLink = class(TWinControlActionLink{TNT-ALLOW TWinControlActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TControlActionLink} + TTntControlActionLink = class(TControlActionLink{TNT-ALLOW TControlActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +//--------------------------------------------------------------------------------------------- +// helper procs +//--------------------------------------------------------------------------------------------- + +//-- TCustomAction helper routines +procedure TntAction_SetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); +function TntAction_GetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; +function TntAction_GetNewCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; +procedure TntAction_SetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); +function TntAction_GetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; +function TntAction_GetNewHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; +procedure TntAction_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); + +// -- TControl helper routines +function TntControl_GetActionLinkClass(Control: TControl; InheritedLinkClass: TControlActionLinkClass): TControlActionLinkClass; +procedure TntControl_BeforeInherited_ActionChange(Control: TControl; Sender: TObject; CheckDefaults: Boolean); + +// -- TControlActionLink helper routines +function TntActionLink_IsCaptionLinked(InheritedIsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; +function TntActionLink_IsHintLinked(InheritedIsHintLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; +procedure TntActionLink_SetCaption(IsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); +procedure TntActionLink_SetHint(IsHintLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); + +type + TUpgradeActionListItemsProc = procedure (ActionList: TTntActionList); + +var + UpgradeActionListItemsProc: TUpgradeActionListItemsProc; + +implementation + +uses + SysUtils, TntMenus, TntClasses, TntControls; + +{ TActionListList } + +type + TActionListList = class(TList) + private + FActionList: TTntActionList; + protected + procedure Notify(Ptr: Pointer; Action: TListNotification); override; + end; + +procedure TActionListList.Notify(Ptr: Pointer; Action: TListNotification); +begin + inherited; + if (Action = lnAdded) and (FActionList <> nil) and (Ptr <> nil) + and (not Supports(TObject(Ptr), ITntAction)) then + begin + FActionList.FCheckActionsTimer.Enabled := False; + FActionList.FCheckActionsTimer.Enabled := True; + end; +end; + +{ THackActionList } + +type +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackCustomActionList = class(TComponent) + private + FActions: TList; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackCustomActionList = class(TComponent) + private + FActions: TList; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackCustomActionList = class(TComponent) + private + FActions: TList; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackCustomActionList = class(TComponent) + private + FActions: TList; + end; +{$ENDIF} + +{ TTntActionList } + +constructor TTntActionList.Create(AOwner: TComponent); +begin + inherited; + if (csDesigning in ComponentState) then begin + FCheckActionsTimer := TTimer.Create(Self); + FCheckActionsTimer.Enabled := False; + FCheckActionsTimer.Interval := 50; + FCheckActionsTimer.OnTimer := CheckActions; + // + THackCustomActionList(Self).FActions.Free; + THackCustomActionList(Self).FActions := TActionListList.Create; + TActionListList(THackCustomActionList(Self).FActions).FActionList := Self; + end; +end; + +procedure TTntActionList.CheckActions(Sender: TObject); +begin + if FCheckActionsTimer <> nil then begin + FCheckActionsTimer.Enabled := False; + end; + Assert(csDesigning in ComponentState); + Assert(Assigned(UpgradeActionListItemsProc)); + UpgradeActionListItemsProc(Self); +end; + +{ TCustomActionHelper } + +type + TCustomActionHelper = class(TComponent) + private + FAction: TCustomAction{TNT-ALLOW TCustomAction}; + private + FCaption: WideString; + FSettingNewCaption: Boolean; + FOldWideCaption: WideString; + FNewAnsiCaption: AnsiString; + procedure SetAnsiCaption(const Value: AnsiString); + function SettingNewCaption: Boolean; + procedure SetCaption(const Value: WideString); + function GetCaption: WideString; + private + FHint: WideString; + FSettingNewHint: Boolean; + FOldWideHint: WideString; + FNewAnsiHint: AnsiString; + procedure SetAnsiHint(const Value: AnsiString); + function SettingNewHint: Boolean; + procedure SetHint(const Value: WideString); + function GetHint: WideString; + end; + +procedure TCustomActionHelper.SetAnsiCaption(const Value: AnsiString); +begin + FAction.Caption := Value; + if (Value = '') and (FNewAnsiCaption <> '') then + FOldWideCaption := ''; +end; + +function TCustomActionHelper.SettingNewCaption: Boolean; +begin + Result := FSettingNewCaption and (FAction.Caption <> FNewAnsiCaption); +end; + +function TCustomActionHelper.GetCaption: WideString; +begin + if SettingNewCaption then + Result := FOldWideCaption + else + Result := GetSyncedWideString(FCaption, FAction.Caption) +end; + +procedure TCustomActionHelper.SetCaption(const Value: WideString); +begin + FOldWideCaption := GetCaption; + FNewAnsiCaption := Value; + FSettingNewCaption := True; + try + SetSyncedWideString(Value, FCaption, FAction.Caption, SetAnsiCaption) + finally + FSettingNewCaption := False; + end; +end; + +procedure TCustomActionHelper.SetAnsiHint(const Value: AnsiString); +begin + FAction.Hint := Value; + if (Value = '') and (FNewAnsiHint <> '') then + FOldWideHint := ''; +end; + +function TCustomActionHelper.SettingNewHint: Boolean; +begin + Result := FSettingNewHint and (FAction.Hint <> FNewAnsiHint); +end; + +function TCustomActionHelper.GetHint: WideString; +begin + if SettingNewHint then + Result := FOldWideHint + else + Result := GetSyncedWideString(FHint, FAction.Hint) +end; + +procedure TCustomActionHelper.SetHint(const Value: WideString); +begin + FOldWideHint := GetHint; + FNewAnsiHint := Value; + FSettingNewHint := True; + try + SetSyncedWideString(Value, FHint, FAction.Hint, SetAnsiHint) + finally + FSettingNewHint := False; + end; +end; + +function FindActionHelper(Action: TCustomAction{TNT-ALLOW TCustomAction}): TCustomActionHelper; +var + i: integer; +begin + Assert(Action <> nil); + Result := nil; + if Supports(Action, ITntAction) then begin + for i := 0 to Action.ComponentCount - 1 do begin + if Action.Components[i] is TCustomActionHelper then begin + Result := TCustomActionHelper(Action.Components[i]); + break; + end; + end; + if Result = nil then begin + Result := TCustomActionHelper.Create(Action); + Result.FAction := Action; + end; + end; +end; + +//-- TCustomAction helper routines + +procedure TntAction_SetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); +begin + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + SetCaption(Value) + else + Action.Caption := Value; +end; + +function TntAction_GetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; +begin + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + Result := GetCaption + else + Result := Action.Caption; +end; + +function TntAction_GetNewCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; +begin + Result := Default; + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + if SettingNewCaption then + Result := FCaption; +end; + +procedure TntAction_SetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); +begin + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + SetHint(Value) + else + Action.Hint := Value; +end; + +function TntAction_GetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; +begin + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + Result := GetHint + else + Result := Action.Hint; +end; + +function TntAction_GetNewHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; +begin + Result := Default; + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + if SettingNewHint then + Result := FHint; +end; + +procedure TntAction_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + with Action do begin + if (Source is TCustomAction{TNT-ALLOW TCustomAction}) then begin + Caption := TntAction_GetCaption(Source as TCustomAction{TNT-ALLOW TCustomAction}); + Hint := TntAction_GetHint(Source as TCustomAction{TNT-ALLOW TCustomAction}); + end else if (Source is TControl) then begin + Caption := TntControl_GetText(Source as TControl); + Hint := TntControl_GetHint(Source as TControl); + end; + end; +end; + +// -- TControl helper routines + +function TntControl_GetActionLinkClass(Control: TControl; InheritedLinkClass: TControlActionLinkClass): TControlActionLinkClass; +begin + if Control is TCustomListView{TNT-ALLOW TCustomListView} then + Result := TTntListViewActionLink + else if Control is TComboBoxEx then + Result := TTntComboBoxExActionLink + else if Control is TSpeedButton{TNT-ALLOW TSpeedButton} then + Result := TTntSpeedButtonActionLink + {$IFDEF COMPILER_10_UP} + else if Control is TBitBtn{TNT-ALLOW TBitBtn} then + Result := TTntBitBtnActionLink + {$ENDIF} + else if Control is TToolButton{TNT-ALLOW TToolButton} then + Result := TTntToolButtonActionLink + else if Control is TButtonControl then + Result := TTntButtonActionLink + else if Control is TWinControl then + Result := TTntWinControlActionLink + else + Result := TTntControlActionLink; + + Assert(Result.ClassParent = InheritedLinkClass); +end; + +procedure TntControl_BeforeInherited_ActionChange(Control: TControl; Sender: TObject; CheckDefaults: Boolean); +begin + if (Sender is TCustomAction{TNT-ALLOW TCustomAction}) and Supports(Sender, ITntAction) then begin + if not CheckDefaults or (TntControl_GetText(Control) = '') or (TntControl_GetText(Control) = Control.Name) then + TntControl_SetText(Control, TntAction_GetCaption(TCustomAction{TNT-ALLOW TCustomAction}(Sender))); + if not CheckDefaults or (TntControl_GetHint(Control) = '') then + TntControl_SetHint(Control, TntAction_GetHint(TCustomAction{TNT-ALLOW TCustomAction}(Sender))); + end; +end; + +// -- TControlActionLink helper routines + +function TntActionLink_IsCaptionLinked(InheritedIsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; +begin + Result := InheritedIsCaptionLinked + and (TntAction_GetCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}) = TntControl_GetText(FClient)); +end; + +function TntActionLink_IsHintLinked(InheritedIsHintLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; +begin + Result := InheritedIsHintLinked + and (TntAction_GetHint(Action as TCustomAction{TNT-ALLOW TCustomAction}) = TntControl_GetHint(FClient)); +end; + +procedure TntActionLink_SetCaption(IsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); +begin + if IsCaptionLinked then + TntControl_SetText(FClient, TntAction_GetNewCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value)); +end; + +procedure TntActionLink_SetHint(IsHintLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); +begin + if IsHintLinked then + TntControl_SetHint(FClient, TntAction_GetNewHint(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value)); +end; + +//--------------------------------------------------------------------------------------------- +// ACTIONS +//--------------------------------------------------------------------------------------------- + +{ TTntCustomAction } + +procedure TTntCustomAction.Assign(Source: TPersistent); +begin + inherited; + TntAction_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCustomAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCustomAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCustomAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCustomAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntAction } + +procedure TTntAction.Assign(Source: TPersistent); +begin + inherited; + TntAction_AfterInherited_Assign(Self, Source); +end; + +procedure TTntAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +//--------------------------------------------------------------------------------------------- +// MENU ACTION LINK +//--------------------------------------------------------------------------------------------- + +{ TTntMenuActionLink } + +function TTntMenuActionLink.IsCaptionLinked: Boolean; +begin + Result := inherited IsCaptionLinked + and WideSameCaption(TntAction_GetCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}), (FClient as TTntMenuItem).Caption); +end; + +function TTntMenuActionLink.IsHintLinked: Boolean; +begin + Result := inherited IsHintLinked + and (TntAction_GetHint(Action as TCustomAction{TNT-ALLOW TCustomAction}) = (FClient as TTntMenuItem).Hint); +end; + +procedure TTntMenuActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + if IsCaptionLinked then + (FClient as TTntMenuItem).Caption := TntAction_GetNewCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value); +end; + +procedure TTntMenuActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + if IsHintLinked then + (FClient as TTntMenuItem).Hint := TntAction_GetNewHint(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value); +end; + +//--------------------------------------------------------------------------------------------- +// CONTROL ACTION LINKS +//--------------------------------------------------------------------------------------------- + +{ TTntListViewActionLink } + +function TTntListViewActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntListViewActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntListViewActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntListViewActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntComboBoxExActionLink } + +function TTntComboBoxExActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntComboBoxExActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntComboBoxExActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntComboBoxExActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntSpeedButtonActionLink } + +function TTntSpeedButtonActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntSpeedButtonActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntSpeedButtonActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntSpeedButtonActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{$IFDEF COMPILER_10_UP} +// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. + +function TTntSpeedButtonActionLink.IsImageIndexLinked: Boolean; +begin + Result := Action is TCustomAction{TNT-ALLOW TCustomAction}; // taken from TActionLink.IsImageIndexLinked +end; + +procedure TTntSpeedButtonActionLink.SetImageIndex(Value: Integer); +begin + ; // taken from TActionLink.IsImageIndexLinked +end; +{$ENDIF} + +{$IFDEF COMPILER_10_UP} +{ TTntBitBtnActionLink } + +function TTntBitBtnActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntBitBtnActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntBitBtnActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntBitBtnActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{$IFDEF COMPILER_10_UP} +// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. + +function TTntBitBtnActionLink.IsImageIndexLinked: Boolean; +begin + Result := Action is TCustomAction{TNT-ALLOW TCustomAction}; // taken from TActionLink.IsImageIndexLinked +end; + +procedure TTntBitBtnActionLink.SetImageIndex(Value: Integer); +begin + ; // taken from TActionLink.IsImageIndexLinked +end; +{$ENDIF} + +{$ENDIF} + +{ TTntToolButtonActionLink } + +function TTntToolButtonActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntToolButtonActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntToolButtonActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntToolButtonActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntButtonActionLink } + +function TTntButtonActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntButtonActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntButtonActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntButtonActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntWinControlActionLink } + +function TTntWinControlActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntWinControlActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntWinControlActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntWinControlActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntControlActionLink } + +function TTntControlActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntControlActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntControlActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntControlActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas new file mode 100644 index 0000000000..bc4b03c883 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas @@ -0,0 +1,191 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntAxCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + ComObj, StdVcl, + {$IFNDEF COMPILER_10_UP} + TntWideStrings, + {$ELSE} + WideStrings, + {$ENDIF} + TntClasses; + +type + TWideStringsAdapter = class(TAutoIntfObject, IStrings, IWideStringsAdapter) + private + FStrings: TWideStrings; + protected + { IWideStringsAdapter } + procedure ReferenceStrings(S: TWideStrings); + procedure ReleaseStrings; + { IStrings } + function Get_ControlDefault(Index: Integer): OleVariant; safecall; + procedure Set_ControlDefault(Index: Integer; Value: OleVariant); safecall; + function Count: Integer; safecall; + function Get_Item(Index: Integer): OleVariant; safecall; + procedure Set_Item(Index: Integer; Value: OleVariant); safecall; + procedure Remove(Index: Integer); safecall; + procedure Clear; safecall; + function Add(Item: OleVariant): Integer; safecall; + function _NewEnum: IUnknown; safecall; + public + constructor Create(Strings: TTntStrings); + end; + +implementation + +uses + Classes, ActiveX, Variants; + +{ TStringsEnumerator } + +type + TStringsEnumerator = class(TContainedObject, IEnumString) + private + FIndex: Integer; // index of next unread string + FStrings: IStrings; + public + constructor Create(const Strings: IStrings); + function Next(celt: Longint; out elt; + pceltFetched: PLongint): HResult; stdcall; + function Skip(celt: Longint): HResult; stdcall; + function Reset: HResult; stdcall; + function Clone(out enm: IEnumString): HResult; stdcall; + end; + +constructor TStringsEnumerator.Create(const Strings: IStrings); +begin + inherited Create(Strings); + FStrings := Strings; +end; + +function TStringsEnumerator.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; +var + I: Integer; +begin + I := 0; + while (I < celt) and (FIndex < FStrings.Count) do + begin + TPointerList(elt)[I] := PWideChar(WideString(FStrings.Item[FIndex])); + Inc(I); + Inc(FIndex); + end; + if pceltFetched <> nil then pceltFetched^ := I; + if I = celt then Result := S_OK else Result := S_FALSE; +end; + +function TStringsEnumerator.Skip(celt: Longint): HResult; +begin + if (FIndex + celt) <= FStrings.Count then + begin + Inc(FIndex, celt); + Result := S_OK; + end + else + begin + FIndex := FStrings.Count; + Result := S_FALSE; + end; +end; + +function TStringsEnumerator.Reset: HResult; +begin + FIndex := 0; + Result := S_OK; +end; + +function TStringsEnumerator.Clone(out enm: IEnumString): HResult; +begin + try + enm := TStringsEnumerator.Create(FStrings); + TStringsEnumerator(enm).FIndex := FIndex; + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +{ TWideStringsAdapter } + +constructor TWideStringsAdapter.Create(Strings: TTntStrings); +var + StdVcl: ITypeLib; +begin + OleCheck(LoadRegTypeLib(LIBID_STDVCL, 4, 0, 0, StdVcl)); + inherited Create(StdVcl, IStrings); + FStrings := Strings; +end; + +procedure TWideStringsAdapter.ReferenceStrings(S: TWideStrings); +begin + FStrings := S; +end; + +procedure TWideStringsAdapter.ReleaseStrings; +begin + FStrings := nil; +end; + +function TWideStringsAdapter.Get_ControlDefault(Index: Integer): OleVariant; +begin + Result := Get_Item(Index); +end; + +procedure TWideStringsAdapter.Set_ControlDefault(Index: Integer; Value: OleVariant); +begin + Set_Item(Index, Value); +end; + +function TWideStringsAdapter.Count: Integer; +begin + Result := 0; + if FStrings <> nil then Result := FStrings.Count; +end; + +function TWideStringsAdapter.Get_Item(Index: Integer): OleVariant; +begin + Result := NULL; + if (FStrings <> nil) then Result := WideString(FStrings[Index]); +end; + +procedure TWideStringsAdapter.Set_Item(Index: Integer; Value: OleVariant); +begin + if (FStrings <> nil) then FStrings[Index] := Value; +end; + +procedure TWideStringsAdapter.Remove(Index: Integer); +begin + if FStrings <> nil then FStrings.Delete(Index); +end; + +procedure TWideStringsAdapter.Clear; +begin + if FStrings <> nil then FStrings.Clear; +end; + +function TWideStringsAdapter.Add(Item: OleVariant): Integer; +begin + Result := -1; + if FStrings <> nil then Result := FStrings.Add(Item); +end; + +function TWideStringsAdapter._NewEnum: IUnknown; +begin + Result := TStringsEnumerator.Create(Self); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas new file mode 100644 index 0000000000..2528c42ffb --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas @@ -0,0 +1,92 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntBandActn; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, BandActn, TntActnList; + +type +{TNT-WARN TCustomizeActionBars} + TTntCustomizeActionBars = class(TCustomizeActionBars{TNT-ALLOW TCustomizeActionBars}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +implementation + +uses + ActnList, TntClasses; + +{TNT-IGNORE-UNIT} + +procedure TntBandActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntAction_AfterInherited_Assign(Action, Source); + // TCustomizeActionBars + if (Action is TCustomizeActionBars) and (Source is TCustomizeActionBars) then begin + TCustomizeActionBars(Action).ActionManager := TCustomizeActionBars(Source).ActionManager; + end; +end; + +//------------------------- +// TNT BAND ACTN +//------------------------- + +{ TTntCustomizeActionBars } + +procedure TTntCustomizeActionBars.Assign(Source: TPersistent); +begin + inherited; + TntBandActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCustomizeActionBars.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomizeActionBars.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCustomizeActionBars.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCustomizeActionBars.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCustomizeActionBars.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas new file mode 100644 index 0000000000..dd2ab6028c --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas @@ -0,0 +1,982 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntButtons; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Windows, Messages, Classes, Controls, Graphics, StdCtrls, + ExtCtrls, CommCtrl, Buttons, + TntControls; + +type + ITntGlyphButton = interface + ['{15D7E501-1E33-4293-8B45-716FB3B14504}'] + function GetButtonGlyph: Pointer; + procedure UpdateInternalGlyphList; + end; + +{TNT-WARN TSpeedButton} + TTntSpeedButton = class(TSpeedButton {TNT-ALLOW TSpeedButton}, ITntGlyphButton) + private + FPaintInherited: Boolean; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + function GetButtonGlyph: Pointer; + procedure UpdateInternalGlyphList; dynamic; + procedure PaintButton; dynamic; + procedure Paint; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TBitBtn} + TTntBitBtn = class(TBitBtn {TNT-ALLOW TBitBtn}, ITntGlyphButton) + private + FPaintInherited: Boolean; + FMouseInControl: Boolean; + function IsCaptionStored: Boolean; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; + procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + protected + function GetButtonGlyph: Pointer; + procedure UpdateInternalGlyphList; dynamic; + procedure DrawItem(const DrawItemStruct: TDrawItemStruct); dynamic; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +procedure TButtonGlyph_CalcButtonLayout(Control: TControl; DC: HDC; const Client: TRect; + const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; + Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect; + BiDiFlags: Integer {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}); + +function TButtonGlyph_Draw(Control: TControl; Canvas: TCanvas; const Client: TRect; + const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; Margin: Integer; + Spacing: Integer; State: TButtonState; Transparent: Boolean; + BiDiFlags: Longint {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}): TRect; + +implementation + +uses + SysUtils, ActnList, TntForms, TntStdCtrls, TypInfo, RTLConsts, TntWindows, + {$IFDEF THEME_7_UP} Themes, {$ENDIF} TntClasses, TntActnList, TntSysUtils; + +type + EAbortPaint = class(EAbort); + +// Many routines in this unit are nearly the same as those found in Buttons.pas. They are +// included here because the VCL implementation of TButtonGlyph is completetly inaccessible. + +type + THackButtonGlyph_D6_D7_D9 = class + protected + FOriginal: TBitmap; + FGlyphList: TImageList; + FIndexs: array[TButtonState] of Integer; + FxxxxTransparentColor: TColor; + FNumGlyphs: TNumGlyphs; + end; + + THackBitBtn_D6_D7_D9 = class(TButton{TNT-ALLOW TButton}) + protected + FCanvas: TCanvas; + FGlyph: Pointer; + FxxxxStyle: TButtonStyle; + FxxxxKind: TBitBtnKind; + FxxxxLayout: TButtonLayout; + FxxxxSpacing: Integer; + FxxxxMargin: Integer; + IsFocused: Boolean; + end; + + THackSpeedButton_D6_D7_D9 = class(TGraphicControl) + protected + FxxxxGroupIndex: Integer; + FGlyph: Pointer; + FxxxxDown: Boolean; + FDragging: Boolean; + end; + + {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackButtonGlyph = THackButtonGlyph_D6_D7_D9; + THackBitBtn = THackBitBtn_D6_D7_D9; + THackSpeedButton = THackSpeedButton_D6_D7_D9; + {$ENDIF} + {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackButtonGlyph = THackButtonGlyph_D6_D7_D9; + THackBitBtn = THackBitBtn_D6_D7_D9; + THackSpeedButton = THackSpeedButton_D6_D7_D9; + {$ENDIF} + {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackButtonGlyph = THackButtonGlyph_D6_D7_D9; + THackBitBtn = THackBitBtn_D6_D7_D9; + THackSpeedButton = THackSpeedButton_D6_D7_D9; + {$ENDIF} + {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackButtonGlyph = THackButtonGlyph_D6_D7_D9; + THackBitBtn = THackBitBtn_D6_D7_D9; + THackSpeedButton = THackSpeedButton_D6_D7_D9; + {$ENDIF} + +function GetButtonGlyph(Control: TControl): THackButtonGlyph; +var + GlyphButton: ITntGlyphButton; +begin + if Control.GetInterface(ITntGlyphButton, GlyphButton) then + Result := GlyphButton.GetButtonGlyph + else + raise ETntInternalError.Create('Internal Error: Control does not support ITntGlyphButton.'); +end; + +procedure UpdateInternalGlyphList(Control: TControl); +var + GlyphButton: ITntGlyphButton; +begin + if Control.GetInterface(ITntGlyphButton, GlyphButton) then + GlyphButton.UpdateInternalGlyphList + else + raise ETntInternalError.Create('Internal Error: Control does not support ITntGlyphButton.'); +end; + +function TButtonGlyph_CreateButtonGlyph(Control: TControl; State: TButtonState): Integer; +var + ButtonGlyph: THackButtonGlyph; + NumGlyphs: Integer; +begin + ButtonGlyph := GetButtonGlyph(Control); + NumGlyphs := ButtonGlyph.FNumGlyphs; + + if (State = bsDown) and (NumGlyphs < 3) then State := bsUp; + Result := ButtonGlyph.FIndexs[State]; + if (Result = -1) then begin + UpdateInternalGlyphList(Control); + Result := ButtonGlyph.FIndexs[State]; + end; +end; + +procedure TButtonGlyph_DrawButtonGlyph(Control: TControl; Canvas: TCanvas; const GlyphPos: TPoint; + State: TButtonState; Transparent: Boolean); +var + ButtonGlyph: THackButtonGlyph; + Glyph: TBitmap; + GlyphList: TImageList; + Index: Integer; + {$IFDEF THEME_7_UP} + Details: TThemedElementDetails; + R: TRect; + Button: TThemedButton; + {$ENDIF} +begin + ButtonGlyph := GetButtonGlyph(Control); + Glyph := ButtonGlyph.FOriginal; + GlyphList := ButtonGlyph.FGlyphList; + if Glyph = nil then Exit; + if (Glyph.Width = 0) or (Glyph.Height = 0) then Exit; + Index := TButtonGlyph_CreateButtonGlyph(Control, State); + with GlyphPos do + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled then begin + R.TopLeft := GlyphPos; + R.Right := R.Left + Glyph.Width div ButtonGlyph.FNumGlyphs; + R.Bottom := R.Top + Glyph.Height; + case State of + bsDisabled: + Button := tbPushButtonDisabled; + bsDown, + bsExclusive: + Button := tbPushButtonPressed; + else + // bsUp + Button := tbPushButtonNormal; + end; + Details := ThemeServices.GetElementDetails(Button); + ThemeServices.DrawIcon(Canvas.Handle, Details, R, GlyphList.Handle, Index); + end else + {$ENDIF} + if Transparent or (State = bsExclusive) then + ImageList_DrawEx(GlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0, + clNone, clNone, ILD_Transparent) + else + ImageList_DrawEx(GlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0, + ColorToRGB(clBtnFace), clNone, ILD_Normal); +end; + +procedure TButtonGlyph_DrawButtonText(Canvas: TCanvas; const Caption: WideString; + TextBounds: TRect; State: TButtonState; + BiDiFlags: LongInt {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}); +begin + with Canvas do + begin + Brush.Style := bsClear; + if State = bsDisabled then + begin + OffsetRect(TextBounds, 1, 1); + Font.Color := clBtnHighlight; + + {$IFDEF COMPILER_7_UP} + if WordWrap then + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_VCENTER or BiDiFlags or DT_WORDBREAK) + else + {$ENDIF} + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_VCENTER or BiDiFlags); + + OffsetRect(TextBounds, -1, -1); + Font.Color := clBtnShadow; + + {$IFDEF COMPILER_7_UP} + if WordWrap then + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_WORDBREAK or BiDiFlags) { TODO: Figure out why DT_VCENTER is not used } + else + {$ENDIF} + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_VCENTER or BiDiFlags); + + end else + begin + {$IFDEF COMPILER_7_UP} + if WordWrap then + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_WORDBREAK or BiDiFlags) { TODO: Figure out why DT_VCENTER is not used } + else + {$ENDIF} + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_VCENTER or BiDiFlags); + end; + end; +end; + +procedure TButtonGlyph_CalcButtonLayout(Control: TControl; DC: HDC; const Client: TRect; + const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; + Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect; + BiDiFlags: Integer {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}); +var + TextPos: TPoint; + ClientSize, + GlyphSize, + TextSize: TPoint; + TotalSize: TPoint; + Glyph: TBitmap; + NumGlyphs: Integer; + ButtonGlyph: THackButtonGlyph; +begin + ButtonGlyph := GetButtonGlyph(Control); + Glyph := ButtonGlyph.FOriginal; + NumGlyphs := ButtonGlyph.FNumGlyphs; + + if (BiDiFlags and DT_RIGHT) = DT_RIGHT then + if Layout = blGlyphLeft then + Layout := blGlyphRight + else + if Layout = blGlyphRight then + Layout := blGlyphLeft; + + // Calculate the item sizes. + ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top); + + if Assigned(Glyph) then + GlyphSize := Point(Glyph.Width div NumGlyphs, Glyph.Height) + else + GlyphSize := Point(0, 0); + + if Length(Caption) > 0 then + begin + {$IFDEF COMPILER_7_UP} + TextBounds := Rect(0, 0, Client.Right - Client.Left - GlyphSize.X - 3, 0); { TODO: Figure out why GlyphSize.X is in here. } + {$ELSE} + TextBounds := Rect(0, 0, Client.Right - Client.Left, 0); + {$ENDIF} + + {$IFDEF COMPILER_7_UP} + if WordWrap then + Tnt_DrawTextW(DC, PWideChar(Caption), Length(Caption), TextBounds, DT_WORDBREAK + or DT_CALCRECT or BiDiFlags) + else + {$ENDIF} + Tnt_DrawTextW(DC, PWideChar(Caption), Length(Caption), TextBounds, DT_CALCRECT or BiDiFlags); + + TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom - TextBounds.Top); + end + else + begin + TextBounds := Rect(0, 0, 0, 0); + TextSize := Point(0, 0); + end; + + // If the layout has the glyph on the right or the left, then both the text and the glyph are centered vertically. + // If the glyph is on the top or the bottom, then both the text and the glyph are centered horizontally. + if Layout in [blGlyphLeft, blGlyphRight] then + begin + GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2; + TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2; + end + else + begin + GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2; + TextPos.X := (ClientSize.X - TextSize.X + 1) div 2; + end; + + // If there is no text or no bitmap, then Spacing is irrelevant. + if (TextSize.X = 0) or (GlyphSize.X = 0) then + Spacing := 0; + + // Adjust Margin and Spacing. + if Margin = -1 then + begin + if Spacing = -1 then + begin + TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y); + if Layout in [blGlyphLeft, blGlyphRight] then + Margin := (ClientSize.X - TotalSize.X) div 3 + else + Margin := (ClientSize.Y - TotalSize.Y) div 3; + Spacing := Margin; + end + else + begin + TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y + Spacing + TextSize.Y); + if Layout in [blGlyphLeft, blGlyphRight] then + Margin := (ClientSize.X - TotalSize.X + 1) div 2 + else + Margin := (ClientSize.Y - TotalSize.Y + 1) div 2; + end; + end + else + begin + if Spacing = -1 then + begin + TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y - (Margin + GlyphSize.Y)); + if Layout in [blGlyphLeft, blGlyphRight] then + Spacing := (TotalSize.X - TextSize.X) div 2 + else + Spacing := (TotalSize.Y - TextSize.Y) div 2; + end; + end; + + case Layout of + blGlyphLeft: + begin + GlyphPos.X := Margin; + TextPos.X := GlyphPos.X + GlyphSize.X + Spacing; + end; + blGlyphRight: + begin + GlyphPos.X := ClientSize.X - Margin - GlyphSize.X; + TextPos.X := GlyphPos.X - Spacing - TextSize.X; + end; + blGlyphTop: + begin + GlyphPos.Y := Margin; + TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing; + end; + blGlyphBottom: + begin + GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y; + TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y; + end; + end; + + // Fixup the Result variables. + with GlyphPos do + begin + Inc(X, Client.Left + Offset.X); + Inc(Y, Client.Top + Offset.Y); + end; + + {$IFDEF THEME_7_UP} + { Themed text is not shifted, but gets a different color. } + if ThemeServices.ThemesEnabled then + OffsetRect(TextBounds, TextPos.X + Client.Left, TextPos.Y + Client.Top) + else + {$ENDIF} + OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X, TextPos.Y + Client.Top + Offset.Y); +end; + +function TButtonGlyph_Draw(Control: TControl; Canvas: TCanvas; const Client: TRect; + const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; Margin: Integer; + Spacing: Integer; State: TButtonState; Transparent: Boolean; + BiDiFlags: Longint {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}): TRect; +var + GlyphPos: TPoint; +begin + TButtonGlyph_CalcButtonLayout(Control, Canvas.Handle, Client, Offset, Caption, Layout, Margin, + Spacing, GlyphPos, Result, BiDiFlags {$IFDEF COMPILER_7_UP}, WordWrap {$ENDIF}); + TButtonGlyph_DrawButtonGlyph(Control, Canvas, GlyphPos, State, Transparent); + TButtonGlyph_DrawButtonText(Canvas, Caption, Result, State, + BiDiFlags {$IFDEF COMPILER_7_UP}, WordWrap {$ENDIF}); +end; + +{ TTntSpeedButton } + +procedure TTntSpeedButton.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSpeedButton.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntSpeedButton.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntSpeedButton.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntSpeedButton.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntSpeedButton.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntSpeedButton.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntSpeedButton.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntSpeedButton.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(CharCode, Caption) and Enabled and Visible and + (Parent <> nil) and Parent.Showing then + begin + Click; + Result := 1; + end else + inherited; +end; + +function TTntSpeedButton.GetButtonGlyph: Pointer; +begin + Result := THackSpeedButton(Self).FGlyph; +end; + +procedure TTntSpeedButton.UpdateInternalGlyphList; +begin + FPaintInherited := True; + try + Repaint; + finally + FPaintInherited := False; + end; + Invalidate; + raise EAbortPaint.Create(''); +end; + +procedure TTntSpeedButton.Paint; +begin + if FPaintInherited then + inherited + else + PaintButton; +end; + +procedure TTntSpeedButton.PaintButton; +const + DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER); + FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0); +var + PaintRect: TRect; + DrawFlags: Integer; + Offset: TPoint; + {$IFDEF THEME_7_UP} + Button: TThemedButton; + ToolButton: TThemedToolBar; + Details: TThemedElementDetails; + {$ENDIF} +begin + try + if not Enabled then + begin + FState := bsDisabled; + THackSpeedButton(Self).FDragging := False; + end + else if FState = bsDisabled then + if Down and (GroupIndex <> 0) then + FState := bsExclusive + else + FState := bsUp; + Canvas.Font := Self.Font; + + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled then + begin + {$IFDEF COMPILER_7_UP} + PerformEraseBackground(Self, Canvas.Handle); + {$ENDIF} + SelectObject(Canvas.Handle, Canvas.Font.Handle); { For some reason, PerformEraseBackground sometimes messes the font up. } + + if not Enabled then + Button := tbPushButtonDisabled + else + if FState in [bsDown, bsExclusive] then + Button := tbPushButtonPressed + else + if MouseInControl then + Button := tbPushButtonHot + else + Button := tbPushButtonNormal; + + ToolButton := ttbToolbarDontCare; + if Flat then + begin + case Button of + tbPushButtonDisabled: + Toolbutton := ttbButtonDisabled; + tbPushButtonPressed: + Toolbutton := ttbButtonPressed; + tbPushButtonHot: + Toolbutton := ttbButtonHot; + tbPushButtonNormal: + Toolbutton := ttbButtonNormal; + end; + end; + + PaintRect := ClientRect; + if ToolButton = ttbToolbarDontCare then + begin + Details := ThemeServices.GetElementDetails(Button); + ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect); + PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect); + end + else + begin + Details := ThemeServices.GetElementDetails(ToolButton); + ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect); + PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect); + end; + + if Button = tbPushButtonPressed then + begin + // A pressed speed button has a white text. This applies however only to flat buttons. + if ToolButton <> ttbToolbarDontCare then + Canvas.Font.Color := clHighlightText; + Offset := Point(1, 0); + end + else + Offset := Point(0, 0); + TButtonGlyph_Draw(Self, Canvas, PaintRect, Offset, Caption, Layout, Margin, Spacing, FState, + Transparent, DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, False {$ENDIF}); + end + else + {$ENDIF} + begin + PaintRect := Rect(0, 0, Width, Height); + if not Flat then + begin + DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT; + if FState in [bsDown, bsExclusive] then + DrawFlags := DrawFlags or DFCS_PUSHED; + DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags); + end + else + begin + if (FState in [bsDown, bsExclusive]) or + (MouseInControl and (FState <> bsDisabled)) or + (csDesigning in ComponentState) then + DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]], + FillStyles[Transparent] or BF_RECT) + else if not Transparent then + begin + Canvas.Brush.Color := Color; + Canvas.FillRect(PaintRect); + end; + InflateRect(PaintRect, -1, -1); + end; + if FState in [bsDown, bsExclusive] then + begin + if (FState = bsExclusive) and (not Flat or not MouseInControl) then + begin + Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight); + Canvas.FillRect(PaintRect); + end; + Offset.X := 1; + Offset.Y := 1; + end + else + begin + Offset.X := 0; + Offset.Y := 0; + end; + TButtonGlyph_Draw(Self, Canvas, PaintRect, Offset, Caption, + Layout, Margin, Spacing, FState, Transparent, + DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, False {$ENDIF}); + end; + except + on E: EAbortPaint do + ; + else + raise; + end; +end; + +function TTntSpeedButton.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{$IFDEF COMPILER_10_UP} +type + TAccessGraphicControl = class(TGraphicControl); +{$ENDIF} + +procedure TTntSpeedButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +{$IFDEF COMPILER_10_UP} +// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. +type + CallActionChange = procedure(Sender: TObject; CheckDefaults: Boolean) of object; +var + M: TMethod; +{$ENDIF} +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + {$IFNDEF COMPILER_10_UP} + inherited; + {$ELSE} + // call TGraphicControl.ActionChange (bypass TSpeedButton.ActionChange) + M.Code := @TAccessGraphicControl.ActionChange; + M.Data := Self; + CallActionChange(M)(Sender, CheckDefaults); + // call Delphi2005's TSpeedButton.ActionChange + if Sender is TCustomAction{TNT-ALLOW TCustomAction} then + with TCustomAction{TNT-ALLOW TCustomAction}(Sender) do + begin + if CheckDefaults or (Self.GroupIndex = 0) then + Self.GroupIndex := GroupIndex; + { Copy image from action's imagelist } + if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and + (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then + CopyImage(ActionList.Images, ImageIndex); + end; + {$ENDIF} +end; + +{ TTntBitBtn } + +procedure TTntBitBtn.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntBitBtn.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntBitBtn.IsCaptionStored: Boolean; +var + BaseClass: TClass; + PropInfo: PPropInfo; +begin + Assert(Self is TButton{TNT-ALLOW TButton}); + Assert(Self is TBitBtn{TNT-ALLOW TBitBtn}); + if Kind = bkCustom then + // don't use TBitBtn, it's broken for Kind <> bkCustom + BaseClass := TButton{TNT-ALLOW TButton} + else begin + //TBitBtn has it's own storage specifier, based upon the button kind + BaseClass := TBitBtn{TNT-ALLOW TBitBtn}; + end; + PropInfo := GetPropInfo(BaseClass, 'Caption'); + if PropInfo = nil then + raise EPropertyError.CreateResFmt(PResStringRec(@SUnknownProperty), ['Caption']); + Result := IsStoredProp(Self, PropInfo); +end; + +function TTntBitBtn.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntBitBtn.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntBitBtn.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntBitBtn.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntBitBtn.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntBitBtn.CMDialogChar(var Message: TCMDialogChar); +begin + TntButton_CMDialogChar(Self, Message); +end; + +function TTntBitBtn.GetButtonGlyph: Pointer; +begin + Result := THackBitBtn(Self).FGlyph; +end; + +procedure TTntBitBtn.UpdateInternalGlyphList; +begin + FPaintInherited := True; + try + Repaint; + finally + FPaintInherited := False; + end; + Invalidate; + raise EAbortPaint.Create(''); +end; + +procedure TTntBitBtn.CNDrawItem(var Message: TWMDrawItem); +begin + if FPaintInherited then + inherited + else + DrawItem(Message.DrawItemStruct^); +end; + +procedure TTntBitBtn.DrawItem(const DrawItemStruct: TDrawItemStruct); +var + IsDown, IsDefault: Boolean; + State: TButtonState; + R: TRect; + Flags: Longint; + FCanvas: TCanvas; + IsFocused: Boolean; + {$IFDEF THEME_7_UP} + Details: TThemedElementDetails; + Button: TThemedButton; + Offset: TPoint; + {$ENDIF} +begin + try + FCanvas := THackBitBtn(Self).FCanvas; + IsFocused := THackBitBtn(Self).IsFocused; + FCanvas.Handle := DrawItemStruct.hDC; + R := ClientRect; + + with DrawItemStruct do + begin + FCanvas.Handle := hDC; + FCanvas.Font := Self.Font; + IsDown := itemState and ODS_SELECTED <> 0; + IsDefault := itemState and ODS_FOCUS <> 0; + + if not Enabled then State := bsDisabled + else if IsDown then State := bsDown + else State := bsUp; + end; + + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled then + begin + if not Enabled then + Button := tbPushButtonDisabled + else + if IsDown then + Button := tbPushButtonPressed + else + if FMouseInControl then + Button := tbPushButtonHot + else + if IsFocused or IsDefault then + Button := tbPushButtonDefaulted + else + Button := tbPushButtonNormal; + + Details := ThemeServices.GetElementDetails(Button); + // Parent background. + ThemeServices.DrawParentBackground(Handle, DrawItemStruct.hDC, @Details, True); + // Button shape. + ThemeServices.DrawElement(DrawItemStruct.hDC, Details, DrawItemStruct.rcItem); + R := ThemeServices.ContentRect(FCanvas.Handle, Details, DrawItemStruct.rcItem); + + if Button = tbPushButtonPressed then + Offset := Point(1, 0) + else + Offset := Point(0, 0); + TButtonGlyph_Draw(Self, FCanvas, R, Offset, Caption, Layout, Margin, Spacing, State, False, + DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, Self.WordWrap {$ENDIF}); + + if IsFocused and IsDefault then + begin + FCanvas.Pen.Color := clWindowFrame; + FCanvas.Brush.Color := clBtnFace; + DrawFocusRect(FCanvas.Handle, R); + end; + end + else + {$ENDIF} + begin + R := ClientRect; + + Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT; + if IsDown then Flags := Flags or DFCS_PUSHED; + if DrawItemStruct.itemState and ODS_DISABLED <> 0 then + Flags := Flags or DFCS_INACTIVE; + + { DrawFrameControl doesn't allow for drawing a button as the + default button, so it must be done here. } + if IsFocused or IsDefault then + begin + FCanvas.Pen.Color := clWindowFrame; + FCanvas.Pen.Width := 1; + FCanvas.Brush.Style := bsClear; + FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom); + + { DrawFrameControl must draw within this border } + InflateRect(R, -1, -1); + end; + + { DrawFrameControl does not draw a pressed button correctly } + if IsDown then + begin + FCanvas.Pen.Color := clBtnShadow; + FCanvas.Pen.Width := 1; + FCanvas.Brush.Color := clBtnFace; + FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom); + InflateRect(R, -1, -1); + end + else + DrawFrameControl(DrawItemStruct.hDC, R, DFC_BUTTON, Flags); + + if IsFocused then + begin + R := ClientRect; + InflateRect(R, -1, -1); + end; + + FCanvas.Font := Self.Font; + if IsDown then + OffsetRect(R, 1, 1); + + TButtonGlyph_Draw(Self, FCanvas, R, Point(0, 0), Caption, Layout, Margin, Spacing, State, + False, DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, Self.WordWrap {$ENDIF}); + + if IsFocused and IsDefault then + begin + R := ClientRect; + InflateRect(R, -4, -4); + FCanvas.Pen.Color := clWindowFrame; + FCanvas.Brush.Color := clBtnFace; + DrawFocusRect(FCanvas.Handle, R); + end; + end; + FCanvas.Handle := 0; + except + on E: EAbortPaint do + ; + else + raise; + end; +end; + +procedure TTntBitBtn.CMMouseEnter(var Message: TMessage); +begin + FMouseInControl := True; + inherited; +end; + +procedure TTntBitBtn.CMMouseLeave(var Message: TMessage); +begin + FMouseInControl := False; + inherited; +end; + +{$IFDEF COMPILER_10_UP} +type + TAccessButton = class(TButton{TNT-ALLOW TButton}); +{$ENDIF} + +procedure TTntBitBtn.ActionChange(Sender: TObject; CheckDefaults: Boolean); +{$IFDEF COMPILER_10_UP} +// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. +type + CallActionChange = procedure(Sender: TObject; CheckDefaults: Boolean) of object; +var + M: TMethod; +{$ENDIF} +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + {$IFNDEF COMPILER_10_UP} + inherited; + {$ELSE} + // call TButton.ActionChange (bypass TBitBtn.ActionChange) + M.Code := @TAccessButton.ActionChange; + M.Data := Self; + CallActionChange(M)(Sender, CheckDefaults); + // call Delphi2005's TBitBtn.ActionChange + if Sender is TCustomAction{TNT-ALLOW TCustomAction} then + with TCustomAction{TNT-ALLOW TCustomAction}(Sender) do + begin + { Copy image from action's imagelist } + if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and + (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then + CopyImage(ActionList.Images, ImageIndex); + end; + {$ENDIF} +end; + +function TTntBitBtn.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas new file mode 100644 index 0000000000..9d1ae95aa3 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas @@ -0,0 +1,184 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntCheckLst; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Messages, Windows, Controls, StdCtrls, CheckLst, + TntClasses, TntControls, TntStdCtrls; + +type +{TNT-WARN TCheckListBox} + TTntCheckListBox = class(TCheckListBox{TNT-ALLOW TCheckListBox}, IWideCustomListControl) + private + FItems: TTntStrings; + FSaveItems: TTntStrings; + FSaveTopIndex: Integer; + FSaveItemIndex: Integer; + FSaved_ItemEnabled: array of Boolean; + FSaved_State: array of TCheckBoxState; + FSaved_Header: array of Boolean; + FOnData: TLBGetWideDataEvent; + procedure SetItems(const Value: TTntStrings); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure LBGetText(var Message: TMessage); message LB_GETTEXT; + procedure LBGetTextLen(var Message: TMessage); message LB_GETTEXTLEN; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property Items: TTntStrings read FItems write SetItems; + property OnData: TLBGetWideDataEvent read FOnData write FOnData; + end; + +implementation + +uses + SysUtils, Math, TntActnList; + +{ TTntCheckListBox } + +constructor TTntCheckListBox.Create(AOwner: TComponent); +begin + inherited; + FItems := TTntListBoxStrings.Create; + TTntListBoxStrings(FItems).ListBox := Self; +end; + +destructor TTntCheckListBox.Destroy; +begin + FreeAndNil(FItems); + inherited; +end; + +procedure TTntCheckListBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'LISTBOX'); +end; + +procedure TTntCheckListBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCheckListBox.CreateWnd; +var + i: integer; +begin + inherited; + TntListBox_AfterInherited_CreateWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); + if Length(FSaved_ItemEnabled) > 0 then begin + for i := 0 to Min(Items.Count - 1, High(FSaved_ItemEnabled)) do begin + ItemEnabled[i] := FSaved_ItemEnabled[i]; + State[i] := FSaved_State[i]; + Header[i] := FSaved_Header[i]; + end; + SetLength(FSaved_ItemEnabled, 0); + SetLength(FSaved_State, 0); + SetLength(FSaved_Header, 0); + end; +end; + +procedure TTntCheckListBox.DestroyWnd; +var + i: integer; +begin + SetLength(FSaved_ItemEnabled, Items.Count); + SetLength(FSaved_State, Items.Count); + SetLength(FSaved_Header, Items.Count); + for i := 0 to Items.Count - 1 do begin + FSaved_ItemEnabled[i] := ItemEnabled[i]; + FSaved_State[i] := State[i]; + FSaved_Header[i] := Header[i]; + end; + TntListBox_BeforeInherited_DestroyWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); + inherited; +end; + +procedure TTntCheckListBox.SetItems(const Value: TTntStrings); +begin + FItems.Assign(Value); +end; + +procedure TTntCheckListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); +begin + inherited; + if not Assigned(OnDrawItem) then + TntListBox_DrawItem_Text(Self, Items, Index, Rect); +end; + +function TTntCheckListBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCheckListBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCheckListBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCheckListBox.AddItem(const Item: WideString; AObject: TObject); +begin + TntListBox_AddItem(Items, Item, AObject); +end; + +procedure TTntCheckListBox.CopySelection(Destination: TCustomListControl); +begin + TntListBox_CopySelection(Self, Items, Destination); +end; + +procedure TTntCheckListBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCheckListBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntCheckListBox.LBGetText(var Message: TMessage); +begin + if not TntCustomListBox_LBGetText(Self, OnData, Message) then + inherited; +end; + +procedure TTntCheckListBox.LBGetTextLen(var Message: TMessage); +begin + if not TntCustomListBox_LBGetTextLen(Self, OnData, Message) then + inherited; +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas new file mode 100644 index 0000000000..e99c0fa3a5 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas @@ -0,0 +1,1780 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntClasses; + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: Consider: TTntRegIniFile, TTntMemIniFile (consider if UTF8 fits into this solution). } + +{***********************************************} +{ WideChar-streaming implemented by Maël Hörz } +{***********************************************} + +uses + Classes, SysUtils, Windows, + {$IFNDEF COMPILER_10_UP} + TntWideStrings, + {$ELSE} + WideStrings, + {$ENDIF} + ActiveX, Contnrs; + +// ......... introduced ......... +type + TTntStreamCharSet = (csAnsi, csUnicode, csUnicodeSwapped, csUtf8); + +function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; + +//--------------------------------------------------------------------------------------------- +// Tnt - Classes +//--------------------------------------------------------------------------------------------- + +{TNT-WARN ExtractStrings} +{TNT-WARN LineStart} +{TNT-WARN TStringStream} // TODO: Implement a TWideStringStream + +// A potential implementation of TWideStringStream can be found at: +// http://kdsxml.cvs.sourceforge.net/kdsxml/Global/KDSClasses.pas?revision=1.10&view=markup + +procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); + +type +{TNT-WARN TFileStream} + TTntFileStream = class(THandleStream) + public + constructor Create(const FileName: WideString; Mode: Word); + destructor Destroy; override; + end; + +{TNT-WARN TMemoryStream} + TTntMemoryStream = class(TMemoryStream{TNT-ALLOW TMemoryStream}) + public + procedure LoadFromFile(const FileName: WideString); + procedure SaveToFile(const FileName: WideString); + end; + +{TNT-WARN TResourceStream} + TTntResourceStream = class(TCustomMemoryStream) + private + HResInfo: HRSRC; + HGlobal: THandle; + procedure Initialize(Instance: THandle; Name, ResType: PWideChar); + public + constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar); + constructor CreateFromID(Instance: THandle; ResID: Word; ResType: PWideChar); + destructor Destroy; override; + function Write(const Buffer; Count: Longint): Longint; override; + procedure SaveToFile(const FileName: WideString); + end; + + TTntStrings = class; + +{TNT-WARN TAnsiStrings} + TAnsiStrings{TNT-ALLOW TAnsiStrings} = class(TStrings{TNT-ALLOW TStrings}) + public + procedure LoadFromFile(const FileName: WideString); reintroduce; + procedure SaveToFile(const FileName: WideString); reintroduce; + procedure LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); + procedure SaveToFileEx(const FileName: WideString; CodePage: Cardinal); + procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; + procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; + end; + + TAnsiStringsForWideStringsAdapter = class(TAnsiStrings{TNT-ALLOW TAnsiStrings}) + private + FWideStrings: TTntStrings; + FAdapterCodePage: Cardinal; + protected + function Get(Index: Integer): AnsiString; override; + procedure Put(Index: Integer; const S: AnsiString); override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + function AdapterCodePage: Cardinal; dynamic; + public + constructor Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal = 0); + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: AnsiString); override; + procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); override; + procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); override; + end; + +{TNT-WARN TStrings} + TTntStrings = class(TWideStrings) + private + FLastFileCharSet: TTntStreamCharSet; + FAnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings}; + procedure SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); + procedure ReadData(Reader: TReader); + procedure ReadDataUTF7(Reader: TReader); + procedure ReadDataUTF8(Reader: TReader); + procedure WriteDataUTF7(Writer: TWriter); + protected + procedure DefineProperties(Filer: TFiler); override; + public + constructor Create; + destructor Destroy; override; + + procedure LoadFromFile(const FileName: WideString); override; + procedure LoadFromStream(Stream: TStream); override; + procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; + + procedure SaveToFile(const FileName: WideString); override; + procedure SaveToStream(Stream: TStream); override; + procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; + + property LastFileCharSet: TTntStreamCharSet read FLastFileCharSet; + published + property AnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings} read FAnsiStrings write SetAnsiStrings stored False; + end; + +{ TTntStringList class } + + TTntStringList = class; + TWideStringListSortCompare = function(List: TTntStringList; Index1, Index2: Integer): Integer; + +{TNT-WARN TStringList} + TTntStringList = class(TTntStrings) + private + FUpdating: Boolean; + FList: PWideStringItemList; + FCount: Integer; + FCapacity: Integer; + FSorted: Boolean; + FDuplicates: TDuplicates; + FCaseSensitive: Boolean; + FOnChange: TNotifyEvent; + FOnChanging: TNotifyEvent; + procedure ExchangeItems(Index1, Index2: Integer); + procedure Grow; + procedure QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); + procedure SetSorted(Value: Boolean); + procedure SetCaseSensitive(const Value: Boolean); + protected + procedure Changed; virtual; + procedure Changing; virtual; + function Get(Index: Integer): WideString; override; + function GetCapacity: Integer; override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure Put(Index: Integer; const S: WideString); override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetCapacity(NewCapacity: Integer); override; + procedure SetUpdateState(Updating: Boolean); override; + function CompareStrings(const S1, S2: WideString): Integer; override; + procedure InsertItem(Index: Integer; const S: WideString; AObject: TObject); virtual; + public + destructor Destroy; override; + function Add(const S: WideString): Integer; override; + function AddObject(const S: WideString; AObject: TObject): Integer; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Exchange(Index1, Index2: Integer); override; + function Find(const S: WideString; var Index: Integer): Boolean; virtual; + function IndexOf(const S: WideString): Integer; override; + function IndexOfName(const Name: WideString): Integer; override; + procedure Insert(Index: Integer; const S: WideString); override; + procedure InsertObject(Index: Integer; const S: WideString; + AObject: TObject); override; + procedure Sort; virtual; + procedure CustomSort(Compare: TWideStringListSortCompare); virtual; + property Duplicates: TDuplicates read FDuplicates write FDuplicates; + property Sorted: Boolean read FSorted write SetSorted; + property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; + end; + +// ......... introduced ......... +type + TListTargetCompare = function (Item, Target: Pointer): Integer; + +function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; + Target: Pointer; var Index: Integer): Boolean; + +function ClassIsRegistered(const clsid: TCLSID): Boolean; + +var + RuntimeUTFStreaming: Boolean; + +type + TBufferedAnsiString = class(TObject) + private + FStringBuffer: AnsiString; + LastWriteIndex: Integer; + public + procedure Clear; + procedure AddChar(const wc: AnsiChar); + procedure AddString(const s: AnsiString); + procedure AddBuffer(Buff: PAnsiChar; Chars: Integer); + function Value: AnsiString; + function BuffPtr: PAnsiChar; + end; + + TBufferedWideString = class(TObject) + private + FStringBuffer: WideString; + LastWriteIndex: Integer; + public + procedure Clear; + procedure AddChar(const wc: WideChar); + procedure AddString(const s: WideString); + procedure AddBuffer(Buff: PWideChar; Chars: Integer); + function Value: WideString; + function BuffPtr: PWideChar; + end; + + TBufferedStreamReader = class(TStream) + private + FStream: TStream; + FStreamSize: Integer; + FBuffer: array of Byte; + FBufferSize: Integer; + FBufferStartPosition: Integer; + FVirtualPosition: Integer; + procedure UpdateBufferFromPosition(StartPos: Integer); + public + constructor Create(Stream: TStream; BufferSize: Integer = 1024); + function Read(var Buffer; Count: Longint): Longint; override; + function Write(const Buffer; Count: Longint): Longint; override; + function Seek(Offset: Longint; Origin: Word): Longint; override; + end; + +// "synced" wide string +type TSetAnsiStrEvent = procedure(const Value: AnsiString) of object; +function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; +procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; + const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); + +type + TWideComponentHelper = class(TComponent) + private + FComponent: TComponent; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + constructor CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); + end; + +function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; + +implementation + +uses + RTLConsts, ComObj, Math, + Registry, TypInfo, TntSystem, TntSysUtils; + +{ TntPersistent } + +//=========================================================================== +// The Delphi 5 Classes.pas never supported the streaming of WideStrings. +// The Delphi 6 Classes.pas supports WideString streaming. But it's too bad that +// the Delphi 6 IDE doesn't use the updated Classes.pas. Switching between Form/Text +// mode corrupts extended characters in WideStrings even under Delphi 6. +// Delphi 7 seems to finally get right. But let's keep the UTF7 support at design time +// to enable sharing source code with previous versions of Delphi. +// +// The purpose of this solution is to store WideString properties which contain +// non-ASCII chars in the form of UTF7 under the old property name + '_UTF7'. +// +// Special thanks go to Francisco Leong for helping to develop this solution. +// + +{ TTntWideStringPropertyFiler } +type + TTntWideStringPropertyFiler = class + private + FInstance: TPersistent; + FPropInfo: PPropInfo; + procedure ReadDataUTF8(Reader: TReader); + procedure ReadDataUTF7(Reader: TReader); + procedure WriteDataUTF7(Writer: TWriter); + public + procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); + end; + +function ReaderNeedsUtfHelp(Reader: TReader): Boolean; +begin + if Reader.Owner = nil then + Result := False { designtime - visual form inheritance ancestor } + else if csDesigning in Reader.Owner.ComponentState then + {$IFDEF COMPILER_7_UP} + Result := False { Delphi 7+: designtime - doesn't need UTF help. } + {$ELSE} + Result := True { Delphi 6: designtime - always needs UTF help. } + {$ENDIF} + else + Result := RuntimeUTFStreaming; { runtime } +end; + +procedure TTntWideStringPropertyFiler.ReadDataUTF8(Reader: TReader); +begin + if ReaderNeedsUtfHelp(Reader) then + SetWideStrProp(FInstance, FPropInfo, UTF8ToWideString(Reader.ReadString)) + else + Reader.ReadString; { do nothing with Result } +end; + +procedure TTntWideStringPropertyFiler.ReadDataUTF7(Reader: TReader); +begin + if ReaderNeedsUtfHelp(Reader) then + SetWideStrProp(FInstance, FPropInfo, UTF7ToWideString(Reader.ReadString)) + else + Reader.ReadString; { do nothing with Result } +end; + +procedure TTntWideStringPropertyFiler.WriteDataUTF7(Writer: TWriter); +begin + Writer.WriteString(WideStringToUTF7(GetWideStrProp(FInstance, FPropInfo))); +end; + +procedure TTntWideStringPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent; + PropName: AnsiString); + + {$IFNDEF COMPILER_7_UP} + function HasData: Boolean; + var + CurrPropValue: WideString; + begin + // must be stored + Result := IsStoredProp(Instance, FPropInfo); + if Result + and (Filer.Ancestor <> nil) + and (GetPropInfo(Filer.Ancestor, PropName, [tkWString]) <> nil) then + begin + // must be different than ancestor + CurrPropValue := GetWideStrProp(Instance, FPropInfo); + Result := CurrPropValue <> GetWideStrProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); + end; + if Result then begin + // must be non-blank and different than UTF8 (implies all ASCII <= 127) + CurrPropValue := GetWideStrProp(Instance, FPropInfo); + Result := (CurrPropValue <> '') and (WideStringToUTF8(CurrPropValue) <> CurrPropValue); + end; + end; + {$ENDIF} + +begin + FInstance := Instance; + FPropInfo := GetPropInfo(Instance, PropName, [tkWString]); + if FPropInfo <> nil then begin + // must be published (and of type WideString) + Filer.DefineProperty(PropName + 'W', ReadDataUTF8, nil, False); + {$IFDEF COMPILER_7_UP} + Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, False); + {$ELSE} + Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, HasData); + {$ENDIF} + end; + FInstance := nil; + FPropInfo := nil; +end; + +{ TTntWideCharPropertyFiler } +type + TTntWideCharPropertyFiler = class + private + FInstance: TPersistent; + FPropInfo: PPropInfo; + {$IFNDEF COMPILER_9_UP} + FWriter: TWriter; + procedure GetLookupInfo(var Ancestor: TPersistent; + var Root, LookupRoot, RootAncestor: TComponent); + {$ENDIF} + procedure ReadData_W(Reader: TReader); + procedure ReadDataUTF7(Reader: TReader); + procedure WriteData_W(Writer: TWriter); + function ReadChar(Reader: TReader): WideChar; + public + procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); + end; + +{$IFNDEF COMPILER_9_UP} +type + TGetLookupInfoEvent = procedure(var Ancestor: TPersistent; + var Root, LookupRoot, RootAncestor: TComponent) of object; + +function AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean; +begin + Result := (Ancestor <> nil) and (RootAncestor <> nil) and + Root.InheritsFrom(RootAncestor.ClassType); +end; + +function IsDefaultOrdPropertyValue(Instance: TObject; PropInfo: PPropInfo; + OnGetLookupInfo: TGetLookupInfoEvent): Boolean; +var + Ancestor: TPersistent; + LookupRoot: TComponent; + RootAncestor: TComponent; + Root: TComponent; + AncestorValid: Boolean; + Value: Longint; + Default: LongInt; +begin + Ancestor := nil; + Root := nil; + LookupRoot := nil; + RootAncestor := nil; + + if Assigned(OnGetLookupInfo) then + OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor); + + AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor); + + Result := True; + if (PropInfo^.GetProc <> nil) and (PropInfo^.SetProc <> nil) then + begin + Value := GetOrdProp(Instance, PropInfo); + if AncestorValid then + Result := Value = GetOrdProp(Ancestor, PropInfo) + else + begin + Default := PPropInfo(PropInfo)^.Default; + Result := (Default <> LongInt($80000000)) and (Value = Default); + end; + end; +end; + +procedure TTntWideCharPropertyFiler.GetLookupInfo(var Ancestor: TPersistent; + var Root, LookupRoot, RootAncestor: TComponent); +begin + Ancestor := FWriter.Ancestor; + Root := FWriter.Root; + LookupRoot := FWriter.LookupRoot; + RootAncestor := FWriter.RootAncestor; +end; +{$ENDIF} + +function TTntWideCharPropertyFiler.ReadChar(Reader: TReader): WideChar; +var + Temp: WideString; +begin + case Reader.NextValue of + vaWString: + Temp := Reader.ReadWideString; + vaString: + Temp := Reader.ReadString; + else + raise EReadError.Create(SInvalidPropertyValue); + end; + + if Length(Temp) > 1 then + raise EReadError.Create(SInvalidPropertyValue); + Result := Temp[1]; +end; + +procedure TTntWideCharPropertyFiler.ReadData_W(Reader: TReader); +begin + SetOrdProp(FInstance, FPropInfo, Ord(ReadChar(Reader))); +end; + +procedure TTntWideCharPropertyFiler.ReadDataUTF7(Reader: TReader); +var + S: WideString; +begin + S := UTF7ToWideString(Reader.ReadString); + if S = '' then + SetOrdProp(FInstance, FPropInfo, 0) + else + SetOrdProp(FInstance, FPropInfo, Ord(S[1])) +end; + +type TAccessWriter = class(TWriter); + +procedure TTntWideCharPropertyFiler.WriteData_W(Writer: TWriter); +var + L: Integer; + Temp: WideString; +begin + Temp := WideChar(GetOrdProp(FInstance, FPropInfo)); + + TAccessWriter(Writer).WriteValue(vaWString); + L := Length(Temp); + Writer.Write(L, SizeOf(Integer)); + Writer.Write(Pointer(@Temp[1])^, L * 2); +end; + +procedure TTntWideCharPropertyFiler.DefineProperties(Filer: TFiler; + Instance: TPersistent; PropName: AnsiString); + + {$IFNDEF COMPILER_9_UP} + function HasData: Boolean; + var + CurrPropValue: Integer; + begin + // must be stored + Result := IsStoredProp(Instance, FPropInfo); + if Result and (Filer.Ancestor <> nil) and + (GetPropInfo(Filer.Ancestor, PropName, [tkWChar]) <> nil) then + begin + // must be different than ancestor + CurrPropValue := GetOrdProp(Instance, FPropInfo); + Result := CurrPropValue <> GetOrdProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); + end; + if Result and (Filer is TWriter) then + begin + FWriter := TWriter(Filer); + Result := not IsDefaultOrdPropertyValue(Instance, FPropInfo, GetLookupInfo); + end; + end; + {$ENDIF} + +begin + FInstance := Instance; + FPropInfo := GetPropInfo(Instance, PropName, [tkWChar]); + if FPropInfo <> nil then + begin + // must be published (and of type WideChar) + {$IFDEF COMPILER_9_UP} + Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, False); + {$ELSE} + Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, HasData); + {$ENDIF} + Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, nil, False); + end; + FInstance := nil; + FPropInfo := nil; +end; + +procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); +var + I, Count: Integer; + PropInfo: PPropInfo; + PropList: PPropList; + WideStringFiler: TTntWideStringPropertyFiler; + WideCharFiler: TTntWideCharPropertyFiler; +begin + Count := GetTypeData(Instance.ClassInfo)^.PropCount; + if Count > 0 then + begin + WideStringFiler := TTntWideStringPropertyFiler.Create; + try + WideCharFiler := TTntWideCharPropertyFiler.Create; + try + GetMem(PropList, Count * SizeOf(Pointer)); + try + GetPropInfos(Instance.ClassInfo, PropList); + for I := 0 to Count - 1 do + begin + PropInfo := PropList^[I]; + if (PropInfo = nil) then + break; + if (PropInfo.PropType^.Kind = tkWString) then + WideStringFiler.DefineProperties(Filer, Instance, PropInfo.Name) + else if (PropInfo.PropType^.Kind = tkWChar) then + WideCharFiler.DefineProperties(Filer, Instance, PropInfo.Name) + end; + finally + FreeMem(PropList, Count * SizeOf(Pointer)); + end; + finally + WideCharFiler.Free; + end; + finally + WideStringFiler.Free; + end; + end; +end; + +{ TTntFileStream } + +constructor TTntFileStream.Create(const FileName: WideString; Mode: Word); +var + CreateHandle: Integer; + {$IFDEF DELPHI_7_UP} + ErrorMessage: WideString; + {$ENDIF} +begin + if Mode = fmCreate then + begin + CreateHandle := WideFileCreate(FileName); + if CreateHandle < 0 then begin + {$IFDEF DELPHI_7_UP} + ErrorMessage := WideSysErrorMessage(GetLastError); + raise EFCreateError.CreateFmt(SFCreateErrorEx, [WideExpandFileName(FileName), ErrorMessage]); + {$ELSE} + raise EFCreateError.CreateFmt(SFCreateError, [WideExpandFileName(FileName)]); + {$ENDIF} + end; + end else + begin + CreateHandle := WideFileOpen(FileName, Mode); + if CreateHandle < 0 then begin + {$IFDEF DELPHI_7_UP} + ErrorMessage := WideSysErrorMessage(GetLastError); + raise EFOpenError.CreateFmt(SFOpenErrorEx, [WideExpandFileName(FileName), ErrorMessage]); + {$ELSE} + raise EFOpenError.CreateFmt(SFOpenError, [WideExpandFileName(FileName)]); + {$ENDIF} + end; + end; + inherited Create(CreateHandle); +end; + +destructor TTntFileStream.Destroy; +begin + if Handle >= 0 then FileClose(Handle); +end; + +{ TTntMemoryStream } + +procedure TTntMemoryStream.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TTntMemoryStream.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +{ TTntResourceStream } + +constructor TTntResourceStream.Create(Instance: THandle; const ResName: WideString; + ResType: PWideChar); +begin + inherited Create; + Initialize(Instance, PWideChar(ResName), ResType); +end; + +constructor TTntResourceStream.CreateFromID(Instance: THandle; ResID: Word; + ResType: PWideChar); +begin + inherited Create; + Initialize(Instance, PWideChar(ResID), ResType); +end; + +procedure TTntResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar); + + procedure Error; + begin + raise EResNotFound.CreateFmt(SResNotFound, [Name]); + end; + +begin + HResInfo := FindResourceW(Instance, Name, ResType); + if HResInfo = 0 then Error; + HGlobal := LoadResource(Instance, HResInfo); + if HGlobal = 0 then Error; + SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo)); +end; + +destructor TTntResourceStream.Destroy; +begin + UnlockResource(HGlobal); + FreeResource(HGlobal); { Technically this is not necessary (MS KB #193678) } + inherited Destroy; +end; + +function TTntResourceStream.Write(const Buffer; Count: Longint): Longint; +begin + raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); +end; + +procedure TTntResourceStream.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +{ TAnsiStrings } + +procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStreamEx(Stream, CodePage); + finally + Stream.Free; + end; +end; + +procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFileEx(const FileName: WideString; CodePage: Cardinal); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + if (CodePage = CP_UTF8) then + Stream.WriteBuffer(PAnsiChar(UTF8_BOM)^, Length(UTF8_BOM)); + SaveToStreamEx(Stream, CodePage); + finally + Stream.Free; + end; +end; + +{ TAnsiStringsForWideStringsAdapter } + +constructor TAnsiStringsForWideStringsAdapter.Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal); +begin + inherited Create; + FWideStrings := AWideStrings; + FAdapterCodePage := _AdapterCodePage; +end; + +function TAnsiStringsForWideStringsAdapter.AdapterCodePage: Cardinal; +begin + if FAdapterCodePage = 0 then + Result := TntSystem.DefaultSystemCodePage + else + Result := FAdapterCodePage; +end; + +procedure TAnsiStringsForWideStringsAdapter.Clear; +begin + FWideStrings.Clear; +end; + +procedure TAnsiStringsForWideStringsAdapter.Delete(Index: Integer); +begin + FWideStrings.Delete(Index); +end; + +function TAnsiStringsForWideStringsAdapter.Get(Index: Integer): AnsiString; +begin + Result := WideStringToStringEx(FWideStrings.Get(Index), AdapterCodePage); +end; + +procedure TAnsiStringsForWideStringsAdapter.Put(Index: Integer; const S: AnsiString); +begin + FWideStrings.Put(Index, StringToWideStringEx(S, AdapterCodePage)); +end; + +function TAnsiStringsForWideStringsAdapter.GetCount: Integer; +begin + Result := FWideStrings.GetCount; +end; + +procedure TAnsiStringsForWideStringsAdapter.Insert(Index: Integer; const S: AnsiString); +begin + FWideStrings.Insert(Index, StringToWideStringEx(S, AdapterCodePage)); +end; + +function TAnsiStringsForWideStringsAdapter.GetObject(Index: Integer): TObject; +begin + Result := FWideStrings.GetObject(Index); +end; + +procedure TAnsiStringsForWideStringsAdapter.PutObject(Index: Integer; AObject: TObject); +begin + FWideStrings.PutObject(Index, AObject); +end; + +procedure TAnsiStringsForWideStringsAdapter.SetUpdateState(Updating: Boolean); +begin + FWideStrings.SetUpdateState(Updating); +end; + +procedure TAnsiStringsForWideStringsAdapter.LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); +var + Size: Integer; + S: AnsiString; +begin + BeginUpdate; + try + Size := Stream.Size - Stream.Position; + SetString(S, nil, Size); + Stream.Read(Pointer(S)^, Size); + FWideStrings.SetTextStr(StringToWideStringEx(S, CodePage)); + finally + EndUpdate; + end; +end; + +procedure TAnsiStringsForWideStringsAdapter.SaveToStreamEx(Stream: TStream; CodePage: Cardinal); +var + S: AnsiString; +begin + S := WideStringToStringEx(FWideStrings.GetTextStr, CodePage); + Stream.WriteBuffer(Pointer(S)^, Length(S)); +end; + +{ TTntStrings } + +constructor TTntStrings.Create; +begin + inherited; + FAnsiStrings := TAnsiStringsForWideStringsAdapter.Create(Self); + FLastFileCharSet := csUnicode; +end; + +destructor TTntStrings.Destroy; +begin + FreeAndNil(FAnsiStrings); + inherited; +end; + +procedure TTntStrings.SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); +begin + FAnsiStrings.Assign(Value); +end; + +procedure TTntStrings.DefineProperties(Filer: TFiler); + + {$IFNDEF COMPILER_7_UP} + function DoWrite: Boolean; + begin + if Filer.Ancestor <> nil then + begin + Result := True; + if Filer.Ancestor is TWideStrings then + Result := not Equals(TWideStrings(Filer.Ancestor)) + end + else Result := Count > 0; + end; + + function DoWriteAsUTF7: Boolean; + var + i: integer; + begin + Result := False; + for i := 0 to Count - 1 do begin + if (Strings[i] <> '') and (WideStringToUTF8(Strings[i]) <> Strings[i]) then begin + Result := True; + break; { found a string with non-ASCII chars (> 127) } + end; + end; + end; + {$ENDIF} + +begin + inherited DefineProperties(Filer); { Handles main 'Strings' property.' } + Filer.DefineProperty('WideStrings', ReadData, nil, False); + Filer.DefineProperty('WideStringsW', ReadDataUTF8, nil, False); + {$IFDEF COMPILER_7_UP} + Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, False); + {$ELSE} + Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, DoWrite and DoWriteAsUTF7); + {$ENDIF} +end; + +procedure TTntStrings.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + FLastFileCharSet := AutoDetectCharacterSet(Stream); + Stream.Position := 0; + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TTntStrings.LoadFromStream(Stream: TStream); +begin + LoadFromStream_BOM(Stream, True); +end; + +procedure TTntStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); +var + DataLeft: Integer; + StreamCharSet: TTntStreamCharSet; + SW: WideString; + SA: AnsiString; +begin + BeginUpdate; + try + if WithBOM then + StreamCharSet := AutoDetectCharacterSet(Stream) + else + StreamCharSet := csUnicode; + DataLeft := Stream.Size - Stream.Position; + if (StreamCharSet in [csUnicode, csUnicodeSwapped]) then + begin + // BOM indicates Unicode text stream + if DataLeft < SizeOf(WideChar) then + SW := '' + else begin + SetLength(SW, DataLeft div SizeOf(WideChar)); + Stream.Read(PWideChar(SW)^, DataLeft); + if StreamCharSet = csUnicodeSwapped then + StrSwapByteOrder(PWideChar(SW)); + end; + SetTextStr(SW); + end + else if StreamCharSet = csUtf8 then + begin + // BOM indicates UTF-8 text stream + SetLength(SA, DataLeft div SizeOf(AnsiChar)); + Stream.Read(PAnsiChar(SA)^, DataLeft); + SetTextStr(UTF8ToWideString(SA)); + end + else + begin + // without byte order mark it is assumed that we are loading ANSI text + SetLength(SA, DataLeft div SizeOf(AnsiChar)); + Stream.Read(PAnsiChar(SA)^, DataLeft); + SetTextStr(SA); + end; + finally + EndUpdate; + end; +end; + +procedure TTntStrings.ReadData(Reader: TReader); +begin + if Reader.NextValue in [vaString, vaLString] then + SetTextStr(Reader.ReadString) {JCL compatiblity} + else if Reader.NextValue = vaWString then + SetTextStr(Reader.ReadWideString) {JCL compatiblity} + else begin + BeginUpdate; + try + Clear; + Reader.ReadListBegin; + while not Reader.EndOfList do + if Reader.NextValue in [vaString, vaLString] then + Add(Reader.ReadString) {TStrings compatiblity} + else + Add(Reader.ReadWideString); + Reader.ReadListEnd; + finally + EndUpdate; + end; + end; +end; + +procedure TTntStrings.ReadDataUTF7(Reader: TReader); +begin + Reader.ReadListBegin; + if ReaderNeedsUtfHelp(Reader) then + begin + BeginUpdate; + try + Clear; + while not Reader.EndOfList do + Add(UTF7ToWideString(Reader.ReadString)) + finally + EndUpdate; + end; + end else begin + while not Reader.EndOfList do + Reader.ReadString; { do nothing with Result } + end; + Reader.ReadListEnd; +end; + +procedure TTntStrings.ReadDataUTF8(Reader: TReader); +begin + Reader.ReadListBegin; + if ReaderNeedsUtfHelp(Reader) + or (Count = 0){ Legacy support where 'WideStrings' was never written in lieu of WideStringsW } + then begin + BeginUpdate; + try + Clear; + while not Reader.EndOfList do + Add(UTF8ToWideString(Reader.ReadString)) + finally + EndUpdate; + end; + end else begin + while not Reader.EndOfList do + Reader.ReadString; { do nothing with Result } + end; + Reader.ReadListEnd; +end; + +procedure TTntStrings.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TTntStrings.SaveToStream(Stream: TStream); +begin + SaveToStream_BOM(Stream, True); +end; + +procedure TTntStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); +// Saves the currently loaded text into the given stream. +// WithBOM determines whether to write a byte order mark or not. +var + SW: WideString; + BOM: WideChar; +begin + if WithBOM then begin + BOM := UNICODE_BOM; + Stream.WriteBuffer(BOM, SizeOf(WideChar)); + end; + SW := GetTextStr; + Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); +end; + +procedure TTntStrings.WriteDataUTF7(Writer: TWriter); +var + I: Integer; +begin + Writer.WriteListBegin; + for I := 0 to Count-1 do + Writer.WriteString(WideStringToUTF7(Get(I))); + Writer.WriteListEnd; +end; + +{ TTntStringList } + +destructor TTntStringList.Destroy; +begin + FOnChange := nil; + FOnChanging := nil; + inherited Destroy; + if FCount <> 0 then Finalize(FList^[0], FCount); + FCount := 0; + SetCapacity(0); +end; + +function TTntStringList.Add(const S: WideString): Integer; +begin + Result := AddObject(S, nil); +end; + +function TTntStringList.AddObject(const S: WideString; AObject: TObject): Integer; +begin + if not Sorted then + Result := FCount + else + if Find(S, Result) then + case Duplicates of + dupIgnore: Exit; + dupError: Error(PResStringRec(@SDuplicateString), 0); + end; + InsertItem(Result, S, AObject); +end; + +procedure TTntStringList.Changed; +begin + if (not FUpdating) and Assigned(FOnChange) then + FOnChange(Self); +end; + +procedure TTntStringList.Changing; +begin + if (not FUpdating) and Assigned(FOnChanging) then + FOnChanging(Self); +end; + +procedure TTntStringList.Clear; +begin + if FCount <> 0 then + begin + Changing; + Finalize(FList^[0], FCount); + FCount := 0; + SetCapacity(0); + Changed; + end; +end; + +procedure TTntStringList.Delete(Index: Integer); +begin + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Changing; + Finalize(FList^[Index]); + Dec(FCount); + if Index < FCount then + System.Move(FList^[Index + 1], FList^[Index], + (FCount - Index) * SizeOf(TWideStringItem)); + Changed; +end; + +procedure TTntStringList.Exchange(Index1, Index2: Integer); +begin + if (Index1 < 0) or (Index1 >= FCount) then Error(PResStringRec(@SListIndexError), Index1); + if (Index2 < 0) or (Index2 >= FCount) then Error(PResStringRec(@SListIndexError), Index2); + Changing; + ExchangeItems(Index1, Index2); + Changed; +end; + +procedure TTntStringList.ExchangeItems(Index1, Index2: Integer); +var + Temp: Integer; + Item1, Item2: PWideStringItem; +begin + Item1 := @FList^[Index1]; + Item2 := @FList^[Index2]; + Temp := Integer(Item1^.FString); + Integer(Item1^.FString) := Integer(Item2^.FString); + Integer(Item2^.FString) := Temp; + Temp := Integer(Item1^.FObject); + Integer(Item1^.FObject) := Integer(Item2^.FObject); + Integer(Item2^.FObject) := Temp; +end; + +function TTntStringList.Find(const S: WideString; var Index: Integer): Boolean; +var + L, H, I, C: Integer; +begin + Result := False; + L := 0; + H := FCount - 1; + while L <= H do + begin + I := (L + H) shr 1; + C := CompareStrings(FList^[I].FString, S); + if C < 0 then L := I + 1 else + begin + H := I - 1; + if C = 0 then + begin + Result := True; + if Duplicates <> dupAccept then L := I; + end; + end; + end; + Index := L; +end; + +function TTntStringList.Get(Index: Integer): WideString; +begin + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Result := FList^[Index].FString; +end; + +function TTntStringList.GetCapacity: Integer; +begin + Result := FCapacity; +end; + +function TTntStringList.GetCount: Integer; +begin + Result := FCount; +end; + +function TTntStringList.GetObject(Index: Integer): TObject; +begin + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Result := FList^[Index].FObject; +end; + +procedure TTntStringList.Grow; +var + Delta: Integer; +begin + if FCapacity > 64 then Delta := FCapacity div 4 else + if FCapacity > 8 then Delta := 16 else + Delta := 4; + SetCapacity(FCapacity + Delta); +end; + +function TTntStringList.IndexOf(const S: WideString): Integer; +begin + if not Sorted then Result := inherited IndexOf(S) else + if not Find(S, Result) then Result := -1; +end; + +function TTntStringList.IndexOfName(const Name: WideString): Integer; +var + NameKey: WideString; +begin + if not Sorted then + Result := inherited IndexOfName(Name) + else begin + // use sort to find index more quickly + NameKey := Name + NameValueSeparator; + Find(NameKey, Result); + if (Result < 0) or (Result > Count - 1) then + Result := -1 + else if CompareStrings(NameKey, Copy(Strings[Result], 1, Length(NameKey))) <> 0 then + Result := -1 + end; +end; + +procedure TTntStringList.Insert(Index: Integer; const S: WideString); +begin + InsertObject(Index, S, nil); +end; + +procedure TTntStringList.InsertObject(Index: Integer; const S: WideString; + AObject: TObject); +begin + if Sorted then Error(PResStringRec(@SSortedListError), 0); + if (Index < 0) or (Index > FCount) then Error(PResStringRec(@SListIndexError), Index); + InsertItem(Index, S, AObject); +end; + +procedure TTntStringList.InsertItem(Index: Integer; const S: WideString; AObject: TObject); +begin + Changing; + if FCount = FCapacity then Grow; + if Index < FCount then + System.Move(FList^[Index], FList^[Index + 1], + (FCount - Index) * SizeOf(TWideStringItem)); + with FList^[Index] do + begin + Pointer(FString) := nil; + FObject := AObject; + FString := S; + end; + Inc(FCount); + Changed; +end; + +procedure TTntStringList.Put(Index: Integer; const S: WideString); +begin + if Sorted then Error(PResStringRec(@SSortedListError), 0); + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Changing; + FList^[Index].FString := S; + Changed; +end; + +procedure TTntStringList.PutObject(Index: Integer; AObject: TObject); +begin + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Changing; + FList^[Index].FObject := AObject; + Changed; +end; + +procedure TTntStringList.QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); +var + I, J, P: Integer; +begin + repeat + I := L; + J := R; + P := (L + R) shr 1; + repeat + while SCompare(Self, I, P) < 0 do Inc(I); + while SCompare(Self, J, P) > 0 do Dec(J); + if I <= J then + begin + ExchangeItems(I, J); + if P = I then + P := J + else if P = J then + P := I; + Inc(I); + Dec(J); + end; + until I > J; + if L < J then QuickSort(L, J, SCompare); + L := I; + until I >= R; +end; + +procedure TTntStringList.SetCapacity(NewCapacity: Integer); +begin + ReallocMem(FList, NewCapacity * SizeOf(TWideStringItem)); + FCapacity := NewCapacity; +end; + +procedure TTntStringList.SetSorted(Value: Boolean); +begin + if FSorted <> Value then + begin + if Value then Sort; + FSorted := Value; + end; +end; + +procedure TTntStringList.SetUpdateState(Updating: Boolean); +begin + FUpdating := Updating; + if Updating then Changing else Changed; +end; + +function WideStringListCompareStrings(List: TTntStringList; Index1, Index2: Integer): Integer; +begin + Result := List.CompareStrings(List.FList^[Index1].FString, + List.FList^[Index2].FString); +end; + +procedure TTntStringList.Sort; +begin + CustomSort(WideStringListCompareStrings); +end; + +procedure TTntStringList.CustomSort(Compare: TWideStringListSortCompare); +begin + if not Sorted and (FCount > 1) then + begin + Changing; + QuickSort(0, FCount - 1, Compare); + Changed; + end; +end; + +function TTntStringList.CompareStrings(const S1, S2: WideString): Integer; +begin + if CaseSensitive then + Result := WideCompareStr(S1, S2) + else + Result := WideCompareText(S1, S2); +end; + +procedure TTntStringList.SetCaseSensitive(const Value: Boolean); +begin + if Value <> FCaseSensitive then + begin + FCaseSensitive := Value; + if Sorted then Sort; + end; +end; + +//------------------------- TntClasses introduced procs ---------------------------------- + +function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; +var + ByteOrderMark: WideChar; + BytesRead: Integer; + Utf8Test: array[0..2] of AnsiChar; +begin + // Byte Order Mark + ByteOrderMark := #0; + if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin + BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark)); + if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin + ByteOrderMark := #0; + Stream.Seek(-BytesRead, soFromCurrent); + if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin + BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar)); + if Utf8Test <> UTF8_BOM then + Stream.Seek(-BytesRead, soFromCurrent); + end; + end; + end; + // Test Byte Order Mark + if ByteOrderMark = UNICODE_BOM then + Result := csUnicode + else if ByteOrderMark = UNICODE_BOM_SWAPPED then + Result := csUnicodeSwapped + else if Utf8Test = UTF8_BOM then + Result := csUtf8 + else + Result := csAnsi; +end; + +function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; + Target: Pointer; var Index: Integer): Boolean; +var + L, H, I, C: Integer; +begin + Result := False; + L := 0; + H := List.Count - 1; + while L <= H do + begin + I := (L + H) shr 1; + C := TargetCompare(List[i], Target); + if C < 0 then L := I + 1 else + begin + H := I - 1; + if C = 0 then + begin + Result := True; + L := I; + end; + end; + end; + Index := L; +end; + +function ClassIsRegistered(const clsid: TCLSID): Boolean; +var + OleStr: POleStr; + Reg: TRegIniFile; + Key, Filename: WideString; +begin + // First, check to see if there is a ProgID. This will tell if the + // control is registered on the machine. No ProgID, control won't run + Result := ProgIDFromCLSID(clsid, OleStr) = S_OK; + if not Result then Exit; //Bail as soon as anything goes wrong. + + // Next, make sure that the file is actually there by rooting it out + // of the registry + Key := WideFormat('\SOFTWARE\Classes\CLSID\%s', [GUIDToString(clsid)]); + Reg := TRegIniFile.Create; + try + Reg.RootKey := HKEY_LOCAL_MACHINE; + Result := Reg.OpenKeyReadOnly(Key); + if not Result then Exit; // Bail as soon as anything goes wrong. + + FileName := Reg.ReadString('InProcServer32', '', EmptyStr); + if (Filename = EmptyStr) then // try another key for the file name + begin + FileName := Reg.ReadString('InProcServer', '', EmptyStr); + end; + Result := Filename <> EmptyStr; + if not Result then Exit; + Result := WideFileExists(Filename); + finally + Reg.Free; + end; +end; + +{ TBufferedAnsiString } + +procedure TBufferedAnsiString.Clear; +begin + LastWriteIndex := 0; + if Length(FStringBuffer) > 0 then + FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(AnsiChar), 0); +end; + +procedure TBufferedAnsiString.AddChar(const wc: AnsiChar); +const + MIN_GROW_SIZE = 32; + MAX_GROW_SIZE = 256; +var + GrowSize: Integer; +begin + Inc(LastWriteIndex); + if LastWriteIndex > Length(FStringBuffer) then begin + GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); + GrowSize := Min(GrowSize, MAX_GROW_SIZE); + SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); + FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(AnsiChar), 0); + end; + FStringBuffer[LastWriteIndex] := wc; +end; + +procedure TBufferedAnsiString.AddString(const s: AnsiString); +var + LenS: Integer; + BlockSize: Integer; + AllocSize: Integer; +begin + LenS := Length(s); + if LenS > 0 then begin + Inc(LastWriteIndex); + if LastWriteIndex + LenS - 1 > Length(FStringBuffer) then begin + // determine optimum new allocation size + BlockSize := Length(FStringBuffer) div 2; + if BlockSize < 8 then + BlockSize := 8; + AllocSize := ((LenS div BlockSize) + 1) * BlockSize; + // realloc buffer + SetLength(FStringBuffer, Length(FStringBuffer) + AllocSize); + FillChar(FStringBuffer[Length(FStringBuffer) - AllocSize + 1], AllocSize * SizeOf(AnsiChar), 0); + end; + CopyMemory(@FStringBuffer[LastWriteIndex], @s[1], LenS * SizeOf(AnsiChar)); + Inc(LastWriteIndex, LenS - 1); + end; +end; + +procedure TBufferedAnsiString.AddBuffer(Buff: PAnsiChar; Chars: Integer); +var + i: integer; +begin + for i := 1 to Chars do begin + if Buff^ = #0 then + break; + AddChar(Buff^); + Inc(Buff); + end; +end; + +function TBufferedAnsiString.Value: AnsiString; +begin + Result := PAnsiChar(FStringBuffer); +end; + +function TBufferedAnsiString.BuffPtr: PAnsiChar; +begin + Result := PAnsiChar(FStringBuffer); +end; + +{ TBufferedWideString } + +procedure TBufferedWideString.Clear; +begin + LastWriteIndex := 0; + if Length(FStringBuffer) > 0 then + FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(WideChar), 0); +end; + +procedure TBufferedWideString.AddChar(const wc: WideChar); +const + MIN_GROW_SIZE = 32; + MAX_GROW_SIZE = 256; +var + GrowSize: Integer; +begin + Inc(LastWriteIndex); + if LastWriteIndex > Length(FStringBuffer) then begin + GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); + GrowSize := Min(GrowSize, MAX_GROW_SIZE); + SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); + FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(WideChar), 0); + end; + FStringBuffer[LastWriteIndex] := wc; +end; + +procedure TBufferedWideString.AddString(const s: WideString); +var + i: integer; +begin + for i := 1 to Length(s) do + AddChar(s[i]); +end; + +procedure TBufferedWideString.AddBuffer(Buff: PWideChar; Chars: Integer); +var + i: integer; +begin + for i := 1 to Chars do begin + if Buff^ = #0 then + break; + AddChar(Buff^); + Inc(Buff); + end; +end; + +function TBufferedWideString.Value: WideString; +begin + Result := PWideChar(FStringBuffer); +end; + +function TBufferedWideString.BuffPtr: PWideChar; +begin + Result := PWideChar(FStringBuffer); +end; + +{ TBufferedStreamReader } + +constructor TBufferedStreamReader.Create(Stream: TStream; BufferSize: Integer = 1024); +begin + // init stream + FStream := Stream; + FStreamSize := Stream.Size; + // init buffer + FBufferSize := BufferSize; + SetLength(FBuffer, BufferSize); + FBufferStartPosition := -FBufferSize; { out of any useful range } + // init virtual position + FVirtualPosition := 0; +end; + +function TBufferedStreamReader.Seek(Offset: Integer; Origin: Word): Longint; +begin + case Origin of + soFromBeginning: FVirtualPosition := Offset; + soFromCurrent: Inc(FVirtualPosition, Offset); + soFromEnd: FVirtualPosition := FStreamSize + Offset; + end; + Result := FVirtualPosition; +end; + +procedure TBufferedStreamReader.UpdateBufferFromPosition(StartPos: Integer); +begin + try + FStream.Position := StartPos; + FStream.Read(FBuffer[0], FBufferSize); + FBufferStartPosition := StartPos; + except + FBufferStartPosition := -FBufferSize; { out of any useful range } + raise; + end; +end; + +function TBufferedStreamReader.Read(var Buffer; Count: Integer): Longint; +var + BytesLeft: Integer; + FirstBufferRead: Integer; + StreamDirectRead: Integer; + Buf: PAnsiChar; +begin + if (FVirtualPosition >= 0) and (Count >= 0) then + begin + Result := FStreamSize - FVirtualPosition; + if Result > 0 then + begin + if Result > Count then + Result := Count; + + Buf := @Buffer; + BytesLeft := Result; + + // try to read what is left in buffer + FirstBufferRead := FBufferStartPosition + FBufferSize - FVirtualPosition; + if (FirstBufferRead < 0) or (FirstBufferRead > FBufferSize) then + FirstBufferRead := 0; + FirstBufferRead := Min(FirstBufferRead, Result); + if FirstBufferRead > 0 then begin + Move(FBuffer[FVirtualPosition - FBufferStartPosition], Buf[0], FirstBufferRead); + Dec(BytesLeft, FirstBufferRead); + end; + + if BytesLeft > 0 then begin + // The first read in buffer was not enough + StreamDirectRead := (BytesLeft div FBufferSize) * FBufferSize; + FStream.Position := FVirtualPosition + FirstBufferRead; + FStream.Read(Buf[FirstBufferRead], StreamDirectRead); + Dec(BytesLeft, StreamDirectRead); + + if BytesLeft > 0 then begin + // update buffer, and read what is left + UpdateBufferFromPosition(FStream.Position); + Move(FBuffer[0], Buf[FirstBufferRead + StreamDirectRead], BytesLeft); + end; + end; + + Inc(FVirtualPosition, Result); + Exit; + end; + end; + Result := 0; +end; + +function TBufferedStreamReader.Write(const Buffer; Count: Integer): Longint; +begin + raise ETntInternalError.Create('Internal Error: class can not write.'); + Result := 0; +end; + +//-------- synced wide string ----------------- + +function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; +begin + if AnsiString(WideStr) <> (AnsiStr) then begin + WideStr := AnsiStr; {AnsiStr changed. Keep WideStr in sync.} + end; + Result := WideStr; +end; + +procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; + const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); +begin + if Value <> GetSyncedWideString(WideStr, AnsiStr) then + begin + if (not WideSameStr(Value, AnsiString(Value))) {unicode chars lost in conversion} + and (AnsiStr = AnsiString(Value)) {AnsiStr is not going to change} + then begin + SetAnsiStr(''); {force the change} + end; + WideStr := Value; + SetAnsiStr(Value); + end; +end; + +{ TWideComponentHelper } + +function CompareComponentHelperToTarget(Item, Target: Pointer): Integer; +begin + if Integer(TWideComponentHelper(Item).FComponent) < Integer(Target) then + Result := -1 + else if Integer(TWideComponentHelper(Item).FComponent) > Integer(Target) then + Result := 1 + else + Result := 0; +end; + +function FindWideComponentHelperIndex(ComponentHelperList: TComponentList; Component: TComponent; var Index: Integer): Boolean; +begin + // find Component in sorted wide caption list (list is sorted by TWideComponentHelper.FComponent) + Result := FindSortedListByTarget(ComponentHelperList, CompareComponentHelperToTarget, Component, Index); +end; + +constructor TWideComponentHelper.Create(AOwner: TComponent); +begin + raise ETntInternalError.Create('TNT Internal Error: TWideComponentHelper.Create should never be encountered.'); +end; + +constructor TWideComponentHelper.CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); +var + Index: Integer; +begin + // don't use direct ownership for memory management + inherited Create(nil); + FComponent := AOwner; + FComponent.FreeNotification(Self); + + // insert into list according to sort + FindWideComponentHelperIndex(ComponentHelperList, FComponent, Index); + ComponentHelperList.Insert(Index, Self); +end; + +procedure TWideComponentHelper.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (AComponent = FComponent) and (Operation = opRemove) then begin + FComponent := nil; + Free; + end; +end; + +function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; +var + Index: integer; +begin + if FindWideComponentHelperIndex(ComponentHelperList, Component, Index) then begin + Result := TWideComponentHelper(ComponentHelperList[Index]); + Assert(Result.FComponent = Component, 'TNT Internal Error: FindWideComponentHelperIndex failed.'); + end else + Result := nil; +end; + +initialization + RuntimeUTFStreaming := False; { Delphi 6 and higher don't need UTF help at runtime. } + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas new file mode 100644 index 0000000000..cf2c16e9f6 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas @@ -0,0 +1,86 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntClipBrd; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Windows, Clipbrd; + +type +{TNT-WARN TClipboard} + TTntClipboard = class(TClipboard{TNT-ALLOW TClipboard}) + private + function GetAsWideText: WideString; + procedure SetAsWideText(const Value: WideString); + public + property AsWideText: WideString read GetAsWideText write SetAsWideText; + property AsText: WideString read GetAsWideText write SetAsWideText; + end; + +{TNT-WARN Clipboard} +function TntClipboard: TTntClipboard; + +implementation + +{ TTntClipboard } + +function TTntClipboard.GetAsWideText: WideString; +var + Data: THandle; +begin + Open; + Data := GetClipboardData(CF_UNICODETEXT); + try + if Data <> 0 then + Result := PWideChar(GlobalLock(Data)) + else + Result := ''; + finally + if Data <> 0 then GlobalUnlock(Data); + Close; + end; + if (Data = 0) or (Result = '') then + Result := inherited AsText +end; + +procedure TTntClipboard.SetAsWideText(const Value: WideString); +begin + Open; + try + inherited AsText := Value; {Ensures ANSI compatiblity across platforms.} + SetBuffer(CF_UNICODETEXT, PWideChar(Value)^, (Length(Value) + 1) * SizeOf(WideChar)); + finally + Close; + end; +end; + +//------------------------------------------ + +var + GTntClipboard: TTntClipboard; + +function TntClipboard: TTntClipboard; +begin + if GTntClipboard = nil then + GTntClipboard := TTntClipboard.Create; + Result := GTntClipboard; +end; + +initialization + +finalization + GTntClipboard.Free; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas new file mode 100644 index 0000000000..42bec4cd46 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas @@ -0,0 +1,5058 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntComCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: TTntCustomListView events - reintroduce ones that refer to ansi classes (ie. TListItem) } +{ TODO: Handle RichEdit CRLF emulation at the WndProc level. } +{ TODO: TTntCustomTreeView events - reintroduce ones that refer to ansi classes (ie. TTreeNode) } +{ TODO: THotKey, Tanimate, TCoolBar (TCoolBand) } +{ TODO: TToolBar: Unicode-enable TBN_GETBUTTONINFO/DoGetButton } +{ TODO: TToolBar: Unicode-enable handling of CN_DIALOGCHAR, WM_SYSCOMMAND, FindButtonFromAccel } + +uses + Classes, Controls, ListActns, Menus, ComCtrls, Messages, + Windows, CommCtrl, Contnrs, TntControls, TntClasses, Graphics, TntSysUtils; + +type + TTntCustomListView = class; + TTntListItems = class; + +{TNT-WARN TListColumn} + TTntListColumn = class(TListColumn{TNT-ALLOW TListColumn}) + private + FCaption: WideString; + procedure SetInheritedCaption(const Value: AnsiString); + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + end; + +{TNT-WARN TListColumns} + TTntListColumns = class(TListColumns{TNT-ALLOW TListColumns}) + private + function GetItem(Index: Integer): TTntListColumn; + procedure SetItem(Index: Integer; Value: TTntListColumn); + public + constructor Create(AOwner: TTntCustomListView); + function Add: TTntListColumn; + function Owner: TTntCustomListView; + property Items[Index: Integer]: TTntListColumn read GetItem write SetItem; default; + end; + +{TNT-WARN TListItem} + TTntListItem = class(TListItem{TNT-ALLOW TListItem}) + private + FCaption: WideString; + FSubItems: TTntStrings; + procedure SetInheritedCaption(const Value: AnsiString); + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + procedure SetSubItems(const Value: TTntStrings); + function GetListView: TTntCustomListView; + function GetTntOwner: TTntListItems; + public + constructor Create(AOwner: TListItems{TNT-ALLOW TListItems}); virtual; + destructor Destroy; override; + property Owner: TTntListItems read GetTntOwner; + property ListView: TTntCustomListView read GetListView; + procedure Assign(Source: TPersistent); override; + property Caption: WideString read GetCaption write SetCaption; + property SubItems: TTntStrings read FSubItems write SetSubItems; + end; + + TTntListItemsEnumerator = class + private + FIndex: Integer; + FListItems: TTntListItems; + public + constructor Create(AListItems: TTntListItems); + function GetCurrent: TTntListItem; + function MoveNext: Boolean; + property Current: TTntListItem read GetCurrent; + end; + +{TNT-WARN TListItems} + TTntListItems = class(TListItems{TNT-ALLOW TListItems}) + private + function GetItem(Index: Integer): TTntListItem; + procedure SetItem(Index: Integer; const Value: TTntListItem); + public + function Owner: TTntCustomListView; + property Item[Index: Integer]: TTntListItem read GetItem write SetItem; default; + function Add: TTntListItem; + function AddItem(Item: TTntListItem; Index: Integer = -1): TTntListItem; + function GetEnumerator: TTntListItemsEnumerator; + function Insert(Index: Integer): TTntListItem; + end; + + TTntLVEditedEvent = procedure(Sender: TObject; Item: TTntListItem; var S: WideString) of object; + TTntLVOwnerDataFindEvent = procedure(Sender: TObject; Find: TItemFind; + const FindString: WideString; const FindPosition: TPoint; FindData: Pointer; + StartIndex: Integer; Direction: TSearchDirection; Wrap: Boolean; + var Index: Integer) of object; + +{TNT-WARN TCustomListView} + _TntInternalCustomListView = class(TCustomListView{TNT-ALLOW TCustomListView}) + private + PWideFindString: PWideChar; + CurrentDispInfo: PLVDispInfoW; + OriginalDispInfoMask: Cardinal; + function OwnerDataFindW(Find: TItemFind; const FindString: WideString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; virtual; abstract; + function OwnerDataFetchW(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; virtual; abstract; + protected + function OwnerDataFind(Find: TItemFind; const FindString: AnsiString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; override; + function OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; override; + end; + + TTntCustomListView = class(_TntInternalCustomListView, IWideCustomListControl) + private + FEditHandle: THandle; + FEditInstance: Pointer; + FDefEditProc: Pointer; + FOnEdited: TTntLVEditedEvent; + FOnDataFind: TTntLVOwnerDataFindEvent; + procedure EditWndProcW(var Message: TMessage); + procedure BeginChangingWideItem; + procedure EndChangingWideItem; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + function GetListColumns: TTntListColumns; + procedure SetListColumns(const Value: TTntListColumns); + function ColumnFromIndex(Index: Integer): TTntListColumn; + function GetColumnFromTag(Tag: Integer): TTntListColumn; + function OwnerDataFindW(Find: TItemFind; const FindString: WideString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; override; + function OwnerDataFetchW(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; override; + function GetDropTarget: TTntListItem; + procedure SetDropTarget(const Value: TTntListItem); + function GetItemFocused: TTntListItem; + procedure SetItemFocused(const Value: TTntListItem); + function GetSelected: TTntListItem; + procedure SetSelected(const Value: TTntListItem); + function GetTopItem: TTntListItem; + private + FSavedItems: TObjectList; + FTestingForSortProc: Boolean; + FChangingWideItemCount: Integer; + FTempItem: TTntListItem; + function AreItemsStored: Boolean; + function GetItems: TTntListItems; + procedure SetItems(Value: TTntListItems); + procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; + function GetItemW(Value: TLVItemW): TTntListItem; + procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure WndProc(var Message: TMessage); override; + function OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; reintroduce; virtual; + function CreateListItem: TListItem{TNT-ALLOW TListItem}; override; + function CreateListItems: TListItems{TNT-ALLOW TListItems}; override; + property Items: TTntListItems read GetItems write SetItems stored AreItemsStored; + procedure Edit(const Item: TLVItem); override; + function OwnerDataFind(Find: TItemFind; const FindString: WideString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; reintroduce; virtual; + property Columns: TTntListColumns read GetListColumns write SetListColumns; + procedure DrawItem(Item: TListItem{TNT-ALLOW TListItem}; Rect: TRect; State: TOwnerDrawState); override; + property OnEdited: TTntLVEditedEvent read FOnEdited write FOnEdited; + property OnDataFind: TTntLVOwnerDataFindEvent read FOnDataFind write FOnDataFind; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Column[Index: Integer]: TTntListColumn read ColumnFromIndex; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + function FindCaption(StartIndex: Integer; Value: WideString; Partial, + Inclusive, Wrap: Boolean): TTntListItem; + function GetSearchString: WideString; + function StringWidth(S: WideString): Integer; + public + property DropTarget: TTntListItem read GetDropTarget write SetDropTarget; + property ItemFocused: TTntListItem read GetItemFocused write SetItemFocused; + property Selected: TTntListItem read GetSelected write SetSelected; + property TopItem: TTntListItem read GetTopItem; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TListView} + TTntListView = class(TTntCustomListView) + published + property Action; + property Align; + property AllocBy; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind default bkNone; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property BorderWidth; + property Checkboxes; + property Color; + property Columns; + property ColumnClick; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property FlatScrollBars; + property FullDrag; + property GridLines; + property HideSelection; + property HotTrack; + property HotTrackStyles; + property HoverTime; + property IconOptions; + property Items; + property LargeImages; + property MultiSelect; + property OwnerData; + property OwnerDraw; + property ReadOnly default False; + property RowSelect; + property ParentBiDiMode; + property ParentColor default False; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowColumnHeaders; + property ShowWorkAreas; + property ShowHint; + property SmallImages; + property SortType; + property StateImages; + property TabOrder; + property TabStop default True; + property ViewStyle; + property Visible; + property OnAdvancedCustomDraw; + property OnAdvancedCustomDrawItem; + property OnAdvancedCustomDrawSubItem; + property OnChange; + property OnChanging; + property OnClick; + property OnColumnClick; + property OnColumnDragged; + property OnColumnRightClick; + property OnCompare; + property OnContextPopup; + property OnCustomDraw; + property OnCustomDrawItem; + property OnCustomDrawSubItem; + property OnData; + property OnDataFind; + property OnDataHint; + property OnDataStateChange; + property OnDblClick; + property OnDeletion; + property OnDrawItem; + property OnEdited; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetImageIndex; + property OnGetSubItemImage; + property OnDragDrop; + property OnDragOver; + property OnInfoTip; + property OnInsert; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnResize; + property OnSelectItem; + property OnStartDock; + property OnStartDrag; + end; + +type +{TNT-WARN TToolButton} + TTntToolButton = class(TToolButton{TNT-ALLOW TToolButton}) + private + procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function IsCaptionStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + function GetMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; + procedure SetMenuItem(const Value: TMenuItem{TNT-ALLOW TMenuItem}); + protected + procedure DefineProperties(Filer: TFiler); override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetActionLinkClass: TControlActionLinkClass; override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property MenuItem: TMenuItem{TNT-ALLOW TMenuItem} read GetMenuItem write SetMenuItem; + end; + +type +{TNT-WARN TToolBar} + TTntToolBar = class(TToolBar{TNT-ALLOW TToolBar}) + private + FCaption: WideString; + procedure TBInsertButtonA(var Message: TMessage); message TB_INSERTBUTTONA; + procedure WMGetText(var Message: TWMGetText); message WM_GETTEXT; + procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH; + procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; + function GetMenu: TMainMenu{TNT-ALLOW TMainMenu}; + procedure SetMenu(const Value: TMainMenu{TNT-ALLOW TMainMenu}); + private + function GetCaption: WideString; + function GetHint: WideString; + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure SetCaption(const Value: WideString); + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetActionLinkClass: TControlActionLinkClass; override; + published + property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property Menu: TMainMenu{TNT-ALLOW TMainMenu} read GetMenu write SetMenu; + end; + +type +{TNT-WARN TCustomRichEdit} + TTntCustomRichEdit = class(TCustomRichEdit{TNT-ALLOW TCustomRichEdit}) + private + FRichEditStrings: TTntStrings; + FPrintingTextLength: Integer; + procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH; + procedure SetRichEditStrings(const Value: TTntStrings); + function GetWideSelText: WideString; + function GetText: WideString; + procedure SetWideSelText(const Value: WideString); + procedure SetText(const Value: WideString); + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + procedure SetRTFText(Flags: DWORD; const Value: AnsiString); + protected + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + function GetSelText: string{TNT-ALLOW string}; override; + function CharPosToGet(RawWin32CharPos: Integer): Integer; deprecated; // use EmulatedCharPos() + function CharPosToSet(EmulatedCharPos: Integer): Integer; deprecated; // use RawWin32CharPos() + function GetSelStart: Integer; reintroduce; virtual; + procedure SetSelStart(const Value: Integer); reintroduce; virtual; + function GetSelLength: Integer; reintroduce; virtual; + procedure SetSelLength(const Value: Integer); reintroduce; virtual; + function LineBreakStyle: TTntTextLineBreakStyle; + property Lines: TTntStrings read FRichEditStrings write SetRichEditStrings; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + // + function EmulatedCharPos(RawWin32CharPos: Integer): Integer; + function RawWin32CharPos(EmulatedCharPos: Integer): Integer; + // + procedure Print(const Caption: string{TNT-ALLOW string}); override; + property SelText: WideString read GetWideSelText write SetWideSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + function FindText(const SearchStr: WideString; StartPos, + Length: Integer; Options: TSearchTypes): Integer; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TRichEdit} + TTntRichEdit = class(TTntCustomRichEdit) + published + property Align; + property Alignment; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind default bkNone; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property BorderWidth; + property Color; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property HideScrollBars; + property ImeMode; + property ImeName; + property Constraints; + property Lines; + property MaxLength; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PlainText; + property PopupMenu; + property ReadOnly; + property ScrollBars; + property ShowHint; + property TabOrder; + property TabStop default True; + property Visible; + property WantTabs; + property WantReturns; + property WordWrap; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnProtectChange; + property OnResizeRequest; + property OnSaveClipboard; + property OnSelectionChange; + property OnStartDock; + property OnStartDrag; + end; + +type +{TNT-WARN TCustomTabControl} + TTntCustomTabControl = class(TCustomTabControl{TNT-ALLOW TCustomTabControl}) + private + FTabs: TTntStrings; + FSaveTabIndex: Integer; + FSaveTabs: TTntStrings; + function GetTabs: TTntStrings; + procedure SetTabs(const Value: TTntStrings); + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + property Tabs: TTntStrings read GetTabs write SetTabs; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TTabControl} + TTntTabControl = class(TTntCustomTabControl) + public + property DisplayRect; + published + property Align; + property Anchors; + property BiDiMode; + property Constraints; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HotTrack; + property Images; + property MultiLine; + property MultiSelect; + property OwnerDraw; + property ParentBiDiMode; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property RaggedRight; + property ScrollOpposite; + property ShowHint; + property Style; + property TabHeight; + property TabOrder; + property TabPosition; + property Tabs; + property TabIndex; // must be after Tabs + property TabStop; + property TabWidth; + property Visible; + property OnChange; + property OnChanging; + property OnContextPopup; + property OnDockDrop; + property OnDockOver; + property OnDragDrop; + property OnDragOver; + property OnDrawTab; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetImageIndex; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnResize; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +type +{TNT-WARN TTabSheet} + TTntTabSheet = class(TTabSheet{TNT-ALLOW TTabSheet}) + private + Force_Inherited_WMSETTEXT: Boolean; + function IsCaptionStored: Boolean; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TPageControl} + TTntPageControl = class(TPageControl{TNT-ALLOW TPageControl}) + private + FNewDockSheet: TTntTabSheet; + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure CMDockNotification(var Message: TCMDockNotification); message CM_DOCKNOTIFICATION; + procedure CMDockClient(var Message: TCMDockClient); message CM_DOCKCLIENT; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure WndProc(var Message: TMessage); override; + procedure DoAddDockClient(Client: TControl; const ARect: TRect); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TTrackBar} + TTntTrackBar = class(TTrackBar{TNT-ALLOW TTrackBar}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TProgressBar} + TTntProgressBar = class(TProgressBar{TNT-ALLOW TProgressBar}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomUpDown} + TTntCustomUpDown = class(TCustomUpDown{TNT-ALLOW TCustomUpDown}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TUpDown} + TTntUpDown = class(TTntCustomUpDown) + published + property AlignButton; + property Anchors; + property Associate; + property ArrowKeys; + property Enabled; + property Hint; + property Min; + property Max; + property Increment; + property Constraints; + property Orientation; + property ParentShowHint; + property PopupMenu; + property Position; + property ShowHint; + property TabOrder; + property TabStop; + property Thousands; + property Visible; + property Wrap; + property OnChanging; + property OnChangingEx; + property OnContextPopup; + property OnClick; + property OnEnter; + property OnExit; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + end; + +{TNT-WARN TDateTimePicker} + TTntDateTimePicker = class(TDateTimePicker{TNT-ALLOW TDateTimePicker}) + private + FHadFirstMouseClick: Boolean; + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TMonthCalendar} + TTntMonthCalendar = class(TMonthCalendar{TNT-ALLOW TMonthCalendar}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function GetDate: TDate; + procedure SetDate(const Value: TDate); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + procedure ForceGetMonthInfo; + published + property Date: TDate read GetDate write SetDate; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TPageScroller} + TTntPageScroller = class(TPageScroller{TNT-ALLOW TPageScroller}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +type +{TNT-WARN TStatusPanel} + TTntStatusPanel = class(TStatusPanel{TNT-ALLOW TStatusPanel}) + private + FText: WideString; + function GetText: Widestring; + procedure SetText(const Value: Widestring); + procedure SetInheritedText(const Value: AnsiString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Text: Widestring read GetText write SetText; + end; + +{TNT-WARN TStatusPanels} + TTntStatusPanels = class(TStatusPanels{TNT-ALLOW TStatusPanels}) + private + function GetItem(Index: Integer): TTntStatusPanel; + procedure SetItem(Index: Integer; Value: TTntStatusPanel); + public + function Add: TTntStatusPanel; + function AddItem(Item: TTntStatusPanel; Index: Integer): TTntStatusPanel; + function Insert(Index: Integer): TTntStatusPanel; + property Items[Index: Integer]: TTntStatusPanel read GetItem write SetItem; default; + end; + +{TNT-WARN TCustomStatusBar} + TTntCustomStatusBar = class(TCustomStatusBar{TNT-ALLOW TCustomStatusBar}) + private + FSimpleText: WideString; + function GetSimpleText: WideString; + procedure SetSimpleText(const Value: WideString); + procedure SetInheritedSimpleText(const Value: AnsiString); + function SyncLeadingTabs(const WideVal: WideString; const AnsiVal: AnsiString): WideString; + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH; + function GetPanels: TTntStatusPanels; + procedure SetPanels(const Value: TTntStatusPanels); + protected + procedure DefineProperties(Filer: TFiler); override; + function CreatePanels: TStatusPanels{TNT-ALLOW TStatusPanels}; override; + function GetPanelClass: TStatusPanelClass; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure WndProc(var Msg: TMessage); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + function ExecuteAction(Action: TBasicAction): Boolean; override; + property Panels: TTntStatusPanels read GetPanels write SetPanels; + property SimpleText: WideString read GetSimpleText write SetSimpleText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TStatusBar} + TTntStatusBar = class(TTntCustomStatusBar) + private + function GetOnDrawPanel: TDrawPanelEvent; + procedure SetOnDrawPanel(const Value: TDrawPanelEvent); + published + property Action; + property AutoHint default False; + property Align default alBottom; + property Anchors; + property BiDiMode; + property BorderWidth; + property Color default clBtnFace; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font stored IsFontStored; + property Constraints; + property Panels; + property ParentBiDiMode; + property ParentColor default False; + property ParentFont default False; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property SimplePanel {$IFDEF COMPILER_7_UP} default False {$ENDIF}; + property SimpleText; + property SizeGrip default True; + property UseSystemFont default True; + property Visible; + property OnClick; + property OnContextPopup; + property OnCreatePanelClass; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnHint; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + // Required for backwards compatibility with the old event signature + property OnDrawPanel: TDrawPanelEvent read GetOnDrawPanel write SetOnDrawPanel; + property OnResize; + property OnStartDock; + property OnStartDrag; + end; + +type + TTntTreeNodes = class; + TTntCustomTreeView = class; + +{TNT-WARN TTreeNode} + TTntTreeNode = class(TTreeNode{TNT-ALLOW TTreeNode}) + private + FText: WideString; + procedure SetText(const Value: WideString); + procedure SetInheritedText(const Value: AnsiString); + function GetText: WideString; + function GetItem(Index: Integer): TTntTreeNode; + function GetNodeOwner: TTntTreeNodes; + function GetParent: TTntTreeNode; + function GetTreeView: TTntCustomTreeView; + procedure SetItem(Index: Integer; const Value: TTntTreeNode); + function IsEqual(Node: TTntTreeNode): Boolean; + procedure ReadData(Stream: TStream; Info: PNodeInfo); + procedure WriteData(Stream: TStream; Info: PNodeInfo); + public + procedure Assign(Source: TPersistent); override; + function getFirstChild: TTntTreeNode; {GetFirstChild conflicts with C++ macro} + function GetLastChild: TTntTreeNode; + function GetNext: TTntTreeNode; + function GetNextChild(Value: TTntTreeNode): TTntTreeNode; + function getNextSibling: TTntTreeNode; {GetNextSibling conflicts with C++ macro} + function GetNextVisible: TTntTreeNode; + function GetPrev: TTntTreeNode; + function GetPrevChild(Value: TTntTreeNode): TTntTreeNode; + function getPrevSibling: TTntTreeNode; {GetPrevSibling conflicts with a C++ macro} + function GetPrevVisible: TTntTreeNode; + property Item[Index: Integer]: TTntTreeNode read GetItem write SetItem; default; + property Owner: TTntTreeNodes read GetNodeOwner; + property Parent: TTntTreeNode read GetParent; + property Text: WideString read GetText write SetText; + property TreeView: TTntCustomTreeView read GetTreeView; + end; + + TTntTreeNodeClass = class of TTntTreeNode; + + TTntTreeNodesEnumerator = class + private + FIndex: Integer; + FTreeNodes: TTntTreeNodes; + public + constructor Create(ATreeNodes: TTntTreeNodes); + function GetCurrent: TTntTreeNode; + function MoveNext: Boolean; + property Current: TTntTreeNode read GetCurrent; + end; + +{TNT-WARN TTreeNodes} + TTntTreeNodes = class(TTreeNodes{TNT-ALLOW TTreeNodes}) + private + function GetNodeFromIndex(Index: Integer): TTntTreeNode; + function GetNodesOwner: TTntCustomTreeView; + procedure ClearCache; + procedure ReadData(Stream: TStream); + procedure WriteData(Stream: TStream); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + function Add(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; + function AddChild(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; + function AddChildFirst(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; + function AddChildObject(Parent: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function AddChildObjectFirst(Parent: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function AddFirst(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; + function AddObject(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function AddObjectFirst(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function Insert(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; + function InsertObject(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function InsertNode(Node, Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function AddNode(Node, Relative: TTntTreeNode; const S: WideString; + Ptr: Pointer; Method: TNodeAttachMode): TTntTreeNode; + public + function GetFirstNode: TTntTreeNode; + function GetEnumerator: TTntTreeNodesEnumerator; + function GetNode(ItemId: HTreeItem): TTntTreeNode; + property Item[Index: Integer]: TTntTreeNode read GetNodeFromIndex; default; + property Owner: TTntCustomTreeView read GetNodesOwner; + end; + + TTntTVEditedEvent = procedure(Sender: TObject; Node: TTntTreeNode; var S: WideString) of object; + +{TNT-WARN TCustomTreeView} + _TntInternalCustomTreeView = class(TCustomTreeView{TNT-ALLOW TCustomTreeView}) + private + function Wide_FindNextToSelect: TTntTreeNode; virtual; abstract; + function Inherited_FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; + public + function FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; override; + end; + + TTntCustomTreeView = class(_TntInternalCustomTreeView) + private + FSavedNodeText: TTntStrings; + FSavedSortType: TSortType; + FOnEdited: TTntTVEditedEvent; + FTestingForSortProc: Boolean; + FEditHandle: THandle; + FEditInstance: Pointer; + FDefEditProc: Pointer; + function GetTreeNodes: TTntTreeNodes; + procedure SetTreeNodes(const Value: TTntTreeNodes); + procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; + procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY; + function GetNodeFromItem(const Item: TTVItem): TTntTreeNode; + procedure EditWndProcW(var Message: TMessage); + function Wide_FindNextToSelect: TTntTreeNode; override; + function GetDropTarget: TTntTreeNode; + function GetSelected: TTntTreeNode; + function GetSelection(Index: Integer): TTntTreeNode; + function GetTopItem: TTntTreeNode; + procedure SetDropTarget(const Value: TTntTreeNode); + procedure SetSelected(const Value: TTntTreeNode); + procedure SetTopItem(const Value: TTntTreeNode); + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + protected + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure DefineProperties(Filer: TFiler); override; + procedure WndProc(var Message: TMessage); override; + procedure Edit(const Item: TTVItem); override; + function CreateNode: TTreeNode{TNT-ALLOW TTreeNode}; override; + function CreateNodes: TTreeNodes{TNT-ALLOW TTreeNodes}; override; + property Items: TTntTreeNodes read GetTreeNodes write SetTreeNodes; + property OnEdited: TTntTVEditedEvent read FOnEdited write FOnEdited; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure LoadFromFile(const FileName: WideString); + procedure LoadFromStream(Stream: TStream); + procedure SaveToFile(const FileName: WideString); + procedure SaveToStream(Stream: TStream); + function GetNodeAt(X, Y: Integer): TTntTreeNode; + property DropTarget: TTntTreeNode read GetDropTarget write SetDropTarget; + property Selected: TTntTreeNode read GetSelected write SetSelected; + property TopItem: TTntTreeNode read GetTopItem write SetTopItem; + property Selections[Index: Integer]: TTntTreeNode read GetSelection; + function GetSelections(AList: TList): TTntTreeNode; + function FindNextToSelect: TTntTreeNode; reintroduce; virtual; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TTreeView} + TTntTreeView = class(TTntCustomTreeView) + published + property Align; + property Anchors; + property AutoExpand; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind default bkNone; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property BorderWidth; + property ChangeDelay; + property Color; + property Ctl3D; + property Constraints; + property DragKind; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property HotTrack; + property Images; + property Indent; + property MultiSelect; + property MultiSelectStyle; + property ParentBiDiMode; + property ParentColor default False; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly; + property RightClickSelect; + property RowSelect; + property ShowButtons; + property ShowHint; + property ShowLines; + property ShowRoot; + property SortType; + property StateImages; + property TabOrder; + property TabStop default True; + property ToolTips; + property Visible; + property OnAddition; + property OnAdvancedCustomDraw; + property OnAdvancedCustomDrawItem; + property OnChange; + property OnChanging; + property OnClick; + property OnCollapsed; + property OnCollapsing; + property OnCompare; + property OnContextPopup; + property OnCreateNodeClass; + property OnCustomDraw; + property OnCustomDrawItem; + property OnDblClick; + property OnDeletion; + property OnDragDrop; + property OnDragOver; + property OnEdited; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnExpanding; + property OnExpanded; + property OnGetImageIndex; + property OnGetSelectedIndex; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + { Items must be published after OnGetImageIndex and OnGetSelectedIndex } + property Items; + end; + +implementation + +uses + Forms, SysUtils, TntGraphics, ImgList, TntSystem, TntStdCtrls, StdCtrls, + RichEdit, ActiveIMM_TLB, TntForms, ComStrs, TntMenus, + TntActnList, TntStdActns, TntWindows, + {$IFNDEF COMPILER_10_UP} + TntWideStrings, + {$ELSE} + WideStrings, + {$ENDIF} + {$IFDEF COMPILER_9_UP} WideStrUtils {$ELSE} TntWideStrUtils {$ENDIF}; + +procedure CreateUnicodeHandle_ComCtl(Control: TWinControl; const Params: TCreateParams; + const SubClass: WideString); +begin + Assert(SubClass <> '', 'TNT Internal Error: Only call CreateUnicodeHandle_ComCtl for Common Controls.'); + CreateUnicodeHandle(Control, Params, SubClass); + if Win32PlatformIsUnicode then + SendMessageW(Control.Handle, CCM_SETUNICODEFORMAT, Integer(True), 0); +end; + +{ TTntListColumn } + +procedure TTntListColumn.Assign(Source: TPersistent); +begin + inherited; + if Source is TTntListColumn then + Caption := TTntListColumn(Source).Caption + else if Source is TListColumn{TNT-ALLOW TListColumn} then + FCaption := TListColumn{TNT-ALLOW TListColumn}(Source).Caption; +end; + +procedure TTntListColumn.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntListColumn.SetInheritedCaption(const Value: AnsiString); +begin + inherited Caption := Value; +end; + +function TTntListColumn.GetCaption: WideString; +begin + Result := GetSyncedWideString(FCaption, inherited Caption); +end; + +procedure TTntListColumn.SetCaption(const Value: WideString); +begin + SetSyncedWideString(Value, FCaption, inherited Caption, SetInheritedCaption); +end; + +{ TTntListColumns } + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackCollection = class(TPersistent) + protected + FItemClass: TCollectionItemClass; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackCollection = class(TPersistent) + protected + FItemClass: TCollectionItemClass; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackCollection = class(TPersistent) + protected + FItemClass: TCollectionItemClass; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackCollection = class(TPersistent) + protected + FItemClass: TCollectionItemClass; + end; +{$ENDIF} + +constructor TTntListColumns.Create(AOwner: TTntCustomListView); +begin + inherited Create(AOwner); + Assert(THackCollection(Self).FItemClass = Self.ItemClass, 'Internal Error in TTntListColumns.Create().'); + THackCollection(Self).FItemClass := TTntListColumn +end; + +function TTntListColumns.Owner: TTntCustomListView; +begin + Result := inherited Owner as TTntCustomListView; +end; + +function TTntListColumns.Add: TTntListColumn; +begin + Result := (inherited Add) as TTntListColumn; +end; + +function TTntListColumns.GetItem(Index: Integer): TTntListColumn; +begin + Result := inherited Items[Index] as TTntListColumn; +end; + +procedure TTntListColumns.SetItem(Index: Integer; Value: TTntListColumn); +begin + inherited SetItem(Index, Value); +end; + +{ TWideSubItems } +type + TWideSubItems = class(TTntStringList) + private + FIgnoreInherited: Boolean; + FInheritedOwner: TListItem{TNT-ALLOW TListItem}; + FOwner: TTntListItem; + protected + procedure Put(Index: Integer; const S: WideString); override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + procedure Insert(Index: Integer; const S: WideString); override; + function AddObject(const S: WideString; AObject: TObject): Integer; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + public + constructor Create(AOwner: TTntListItem); + end; + +constructor TWideSubItems.Create(AOwner: TTntListItem); +begin + inherited Create; + FInheritedOwner := AOwner; + FOwner := AOwner; +end; + +function TWideSubItems.AddObject(const S: WideString; AObject: TObject): Integer; +begin + FOwner.ListView.BeginChangingWideItem; + try + Result := inherited AddObject(S, AObject); + if (not FIgnoreInherited) then + FInheritedOwner.SubItems.AddObject(S, AObject); + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +procedure TWideSubItems.Clear; +begin + FOwner.ListView.BeginChangingWideItem; + try + inherited; + if (not FIgnoreInherited) then + FInheritedOwner.SubItems.Clear; + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +procedure TWideSubItems.Delete(Index: Integer); +begin + FOwner.ListView.BeginChangingWideItem; + try + inherited; + if (not FIgnoreInherited) then + FInheritedOwner.SubItems.Delete(Index); + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +procedure TWideSubItems.Insert(Index: Integer; const S: WideString); +begin + FOwner.ListView.BeginChangingWideItem; + try + inherited; + if (not FIgnoreInherited) then + FInheritedOwner.SubItems.Insert(Index, S); + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +procedure TWideSubItems.Put(Index: Integer; const S: WideString); +begin + FOwner.ListView.BeginChangingWideItem; + try + inherited; + if (not FIgnoreInherited) then + FInheritedOwner.SubItems[Index] := S; + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +function TWideSubItems.GetObject(Index: Integer): TObject; +begin + Result := FInheritedOwner.SubItems.Objects[Index]; +end; + +procedure TWideSubItems.PutObject(Index: Integer; AObject: TObject); +begin + FInheritedOwner.SubItems.Objects[Index] := AObject; +end; + +type TAccessStrings = class(TStrings{TNT-ALLOW TStrings}); + +procedure TWideSubItems.SetUpdateState(Updating: Boolean); +begin + inherited; + TAccessStrings(FInheritedOwner.SubItems).SetUpdateState(Updating); +end; + +{ TTntListItem } + +constructor TTntListItem.Create(AOwner: TListItems{TNT-ALLOW TListItems}); +begin + inherited Create(AOwner); + FSubItems := TWideSubItems.Create(Self); +end; + +destructor TTntListItem.Destroy; +begin + inherited; + FreeAndNil(FSubItems); +end; + +function TTntListItem.GetCaption: WideString; +begin + Result := GetSyncedWideString(FCaption, inherited Caption); +end; + +procedure TTntListItem.SetInheritedCaption(const Value: AnsiString); +begin + inherited Caption := Value; +end; + +procedure TTntListItem.SetCaption(const Value: WideString); +begin + ListView.BeginChangingWideItem; + try + SetSyncedWideString(Value, FCaption, inherited Caption, SetInheritedCaption); + finally + ListView.EndChangingWideItem; + end; +end; + +procedure TTntListItem.Assign(Source: TPersistent); +begin + if Source is TTntListItem then + with Source as TTntListItem do + begin + Self.Caption := Caption; + Self.Data := Data; + Self.ImageIndex := ImageIndex; + Self.Indent := Indent; + Self.OverlayIndex := OverlayIndex; + Self.StateIndex := StateIndex; + Self.SubItems := SubItems; + Self.Checked := Checked; + end + else inherited Assign(Source); +end; + +procedure TTntListItem.SetSubItems(const Value: TTntStrings); +begin + if Value <> nil then + FSubItems.Assign(Value); +end; + +function TTntListItem.GetTntOwner: TTntListItems; +begin + Result := ListView.Items; +end; + +function TTntListItem.GetListView: TTntCustomListView; +begin + Result := ((inherited Owner).Owner as TTntCustomListView); +end; + +{ TTntListItemsEnumerator } + +constructor TTntListItemsEnumerator.Create(AListItems: TTntListItems); +begin + inherited Create; + FIndex := -1; + FListItems := AListItems; +end; + +function TTntListItemsEnumerator.GetCurrent: TTntListItem; +begin + Result := FListItems[FIndex]; +end; + +function TTntListItemsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FListItems.Count - 1; + if Result then + Inc(FIndex); +end; + +{ TTntListItems } + +function TTntListItems.Add: TTntListItem; +begin + Result := (inherited Add) as TTntListItem; +end; + +function TTntListItems.AddItem(Item: TTntListItem; Index: Integer): TTntListItem; +begin + Result := (inherited AddItem(Item, Index)) as TTntListItem; +end; + +function TTntListItems.Insert(Index: Integer): TTntListItem; +begin + Result := (inherited Insert(Index)) as TTntListItem; +end; + +function TTntListItems.GetItem(Index: Integer): TTntListItem; +begin + Result := (inherited Item[Index]) as TTntListItem; +end; + +function TTntListItems.Owner: TTntCustomListView; +begin + Result := (inherited Owner) as TTntCustomListView; +end; + +procedure TTntListItems.SetItem(Index: Integer; const Value: TTntListItem); +begin + inherited Item[Index] := Value; +end; + +function TTntListItems.GetEnumerator: TTntListItemsEnumerator; +begin + Result := TTntListItemsEnumerator.Create(Self); +end; + +{ TSavedListItem } +type + TSavedListItem = class + FCaption: WideString; + FSubItems: TTntStrings; + constructor Create; + destructor Destroy; override; + end; + +constructor TSavedListItem.Create; +begin + inherited; + FSubItems := TTntStringList.Create; +end; + +destructor TSavedListItem.Destroy; +begin + FSubItems.Free; + inherited; +end; + +{ _TntInternalCustomListView } + +function _TntInternalCustomListView.OwnerDataFind(Find: TItemFind; + const FindString: AnsiString; const FindPosition: TPoint; + FindData: Pointer; StartIndex: Integer; Direction: TSearchDirection; + Wrap: Boolean): Integer; +var + WideFindString: WideString; +begin + if Assigned(PWideFindString) then + WideFindString := PWideFindString + else + WideFindString := FindString; + Result := OwnerDataFindW(Find, WideFindString, FindPosition, FindData, StartIndex, Direction, Wrap); +end; + +function _TntInternalCustomListView.OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; + Request: TItemRequest): Boolean; +begin + if (CurrentDispInfo <> nil) + and (OriginalDispInfoMask and LVIF_TEXT <> 0) then begin + (Item as TTntListItem).FCaption := CurrentDispInfo.item.pszText + end; + (Item as TTntListItem).FSubItems.Clear; + Result := OwnerDataFetchW(Item, Request); +end; + +{ TTntCustomListView } + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackCustomListView = class(TCustomMultiSelectListControl) + protected + FxxxCanvas: TCanvas; + FxxxBorderStyle: TBorderStyle; + FxxxViewStyle: TViewStyle; + FxxxReadOnly: Boolean; + FxxxLargeImages: TCustomImageList; + FxxxSmallImages: TCustomImageList; + FxxxStateImages: TCustomImageList; + FxxxDragImage: TDragImageList; + FxxxMultiSelect: Boolean; + FxxxSortType: TSortType; + FxxxColumnClick: Boolean; + FxxxShowColumnHeaders: Boolean; + FxxxListItems: TListItems{TNT-ALLOW TListItems}; + FxxxClicked: Boolean; + FxxxRClicked: Boolean; + FxxxIconOptions: TIconOptions; + FxxxHideSelection: Boolean; + FListColumns: TListColumns{TNT-ALLOW TListColumns}; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackCustomListView = class(TCustomMultiSelectListControl) + protected + FxxxCanvas: TCanvas; + FxxxBorderStyle: TBorderStyle; + FxxxViewStyle: TViewStyle; + FxxxReadOnly: Boolean; + FxxxLargeImages: TCustomImageList; + FxxxSmallImages: TCustomImageList; + FxxxStateImages: TCustomImageList; + FxxxDragImage: TDragImageList; + FxxxMultiSelect: Boolean; + FxxxSortType: TSortType; + FxxxColumnClick: Boolean; + FxxxShowColumnHeaders: Boolean; + FxxxListItems: TListItems{TNT-ALLOW TListItems}; + FxxxClicked: Boolean; + FxxxRClicked: Boolean; + FxxxIconOptions: TIconOptions; + FxxxHideSelection: Boolean; + FListColumns: TListColumns{TNT-ALLOW TListColumns}; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackCustomListView = class(TCustomMultiSelectListControl) + protected + FxxxCanvas: TCanvas; + FxxxBorderStyle: TBorderStyle; + FxxxViewStyle: TViewStyle; + FxxxReadOnly: Boolean; + FxxxLargeImages: TCustomImageList; + FxxxSmallImages: TCustomImageList; + FxxxStateImages: TCustomImageList; + FxxxDragImage: TDragImageList; + FxxxMultiSelect: Boolean; + FxxxSortType: TSortType; + FxxxColumnClick: Boolean; + FxxxShowColumnHeaders: Boolean; + FxxxListItems: TListItems{TNT-ALLOW TListItems}; + FxxxClicked: Boolean; + FxxxRClicked: Boolean; + FxxxIconOptions: TIconOptions; + FxxxHideSelection: Boolean; + FListColumns: TListColumns{TNT-ALLOW TListColumns}; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackCustomListView = class(TCustomMultiSelectListControl) + protected + FxxxCanvas: TCanvas; + FxxxBorderStyle: TBorderStyle; + FxxxViewStyle: TViewStyle; + FxxxReadOnly: Boolean; + FxxxLargeImages: TCustomImageList; + FxxxSaveSelectedIndex: Integer; + FxxxSmallImages: TCustomImageList; + FxxxStateImages: TCustomImageList; + FxxxDragImage: TDragImageList; + FxxxMultiSelect: Boolean; + FxxxSortType: TSortType; + FxxxColumnClick: Boolean; + FxxxShowColumnHeaders: Boolean; + FxxxListItems: TListItems{TNT-ALLOW TListItems}; + FxxxClicked: Boolean; + FxxxRClicked: Boolean; + FxxxIconOptions: TIconOptions; + FxxxHideSelection: Boolean; + FListColumns: TListColumns{TNT-ALLOW TListColumns}; + end; +{$ENDIF} + +var + ComCtrls_DefaultListViewSort: TLVCompare = nil; + +constructor TTntCustomListView.Create(AOwner: TComponent); +begin + inherited; + FEditInstance := Classes.MakeObjectInstance(EditWndProcW); + // create list columns + Assert(THackCustomListView(Self).FListColumns = inherited Columns, 'Internal Error in TTntCustomListView.Create().'); + FreeAndNil(THackCustomListView(Self).FListColumns); + THackCustomListView(Self).FListColumns := TTntListColumns.Create(Self); +end; + +destructor TTntCustomListView.Destroy; +begin + inherited; + Classes.FreeObjectInstance(FEditInstance); + FreeAndNil(FSavedItems); +end; + +procedure TTntCustomListView.CreateWindowHandle(const Params: TCreateParams); + + procedure Capture_ComCtrls_DefaultListViewSort; + begin + FTestingForSortProc := True; + try + AlphaSort; + finally + FTestingForSortProc := False; + end; + end; + +var + Column: TLVColumn; +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_LISTVIEW); + if (Win32PlatformIsUnicode) then begin + if not Assigned(ComCtrls_DefaultListViewSort) then + Capture_ComCtrls_DefaultListViewSort; + // the only way I could get editing to work is after a column had been inserted + Column.mask := 0; + ListView_InsertColumn(Handle, 0, Column); + ListView_DeleteColumn(Handle, 0); + end; +end; + +procedure TTntCustomListView.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomListView.CreateWnd; +begin + inherited; + FreeAndNil(FSavedItems); +end; + +procedure TTntCustomListView.DestroyWnd; +var + i: integer; + FSavedItem: TSavedListItem; + Item: TTntListItem; +begin + if (not (csDestroying in ComponentState)) and (not OwnerData) then begin + FreeAndNil(FSavedItems); // fixes a bug on Windows 95. + FSavedItems := TObjectList.Create(True); + for i := 0 to Items.Count - 1 do begin + FSavedItem := TSavedListItem.Create; + Item := Items[i]; + FSavedItem.FCaption := Item.FCaption; + FSavedItem.FSubItems.Assign(Item.FSubItems); + FSavedItems.Add(FSavedItem) + end; + end; + inherited; +end; + +function TTntCustomListView.GetDropTarget: TTntListItem; +begin + Result := inherited DropTarget as TTntListItem; +end; + +procedure TTntCustomListView.SetDropTarget(const Value: TTntListItem); +begin + inherited DropTarget := Value; +end; + +function TTntCustomListView.GetItemFocused: TTntListItem; +begin + Result := inherited ItemFocused as TTntListItem; +end; + +procedure TTntCustomListView.SetItemFocused(const Value: TTntListItem); +begin + inherited ItemFocused := Value; +end; + +function TTntCustomListView.GetSelected: TTntListItem; +begin + Result := inherited Selected as TTntListItem; +end; + +procedure TTntCustomListView.SetSelected(const Value: TTntListItem); +begin + inherited Selected := Value; +end; + +function TTntCustomListView.GetTopItem: TTntListItem; +begin + Result := inherited TopItem as TTntListItem; +end; + +function TTntCustomListView.GetListColumns: TTntListColumns; +begin + Result := inherited Columns as TTntListColumns; +end; + +procedure TTntCustomListView.SetListColumns(const Value: TTntListColumns); +begin + inherited Columns := Value; +end; + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackListColumn = class(TCollectionItem) + protected + FxxxAlignment: TAlignment; + FxxxAutoSize: Boolean; + FxxxCaption: AnsiString; + FxxxMaxWidth: TWidth; + FxxxMinWidth: TWidth; + FxxxImageIndex: TImageIndex; + FxxxPrivateWidth: TWidth; + FxxxWidth: TWidth; + FOrderTag: Integer; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackListColumn = class(TCollectionItem) + protected + FxxxAlignment: TAlignment; + FxxxAutoSize: Boolean; + FxxxCaption: AnsiString; + FxxxMaxWidth: TWidth; + FxxxMinWidth: TWidth; + FxxxImageIndex: TImageIndex; + FxxxPrivateWidth: TWidth; + FxxxWidth: TWidth; + FOrderTag: Integer; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackListColumn = class(TCollectionItem) + protected + FxxxxxxxxAlignment: TAlignment; + FxxxxAutoSize: Boolean; + FxxxxCaption: AnsiString; + FxxxxMaxWidth: TWidth; + FxxxxMinWidth: TWidth; + FxxxxImageIndex: TImageIndex; + FxxxxPrivateWidth: TWidth; + FxxxxWidth: TWidth; + FOrderTag: Integer; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackListColumn = class(TCollectionItem) + protected + FxxxxxxxxAlignment: TAlignment; + FxxxxAutoSize: Boolean; + FxxxxCaption: AnsiString; + FxxxxMaxWidth: TWidth; + FxxxxMinWidth: TWidth; + FxxxxImageIndex: TImageIndex; + FxxxxPrivateWidth: TWidth; + FxxxxWidth: TWidth; + FOrderTag: Integer; + end; +{$ENDIF} + +function TTntCustomListView.GetColumnFromTag(Tag: Integer): TTntListColumn; +var + I: Integer; +begin + for I := 0 to Columns.Count - 1 do + begin + Result := Columns[I]; + if THackListColumn(Result).FOrderTag = Tag then Exit; + end; + Result := nil; +end; + +function TTntCustomListView.ColumnFromIndex(Index: Integer): TTntListColumn; +begin + Result := inherited Column[Index] as TTntListColumn; +end; + +function TTntCustomListView.AreItemsStored: Boolean; +begin + if Assigned(Action) then + begin + if Action is TCustomListAction{TNT-ALLOW TCustomListAction} then + Result := False + else + Result := True; + end + else + Result := not OwnerData; +end; + +function TTntCustomListView.GetItems: TTntListItems; +begin + Result := inherited Items as TTntListItems; +end; + +procedure TTntCustomListView.SetItems(Value: TTntListItems); +begin + inherited Items := Value; +end; + +type TTntListItemClass = class of TTntListItem; + +function TTntCustomListView.CreateListItem: TListItem{TNT-ALLOW TListItem}; +var + LClass: TClass; + TntLClass: TTntListItemClass; +begin + LClass := TTntListItem; + if Assigned(OnCreateItemClass) then + OnCreateItemClass(Self, TListItemClass(LClass)); + if not LClass.InheritsFrom(TTntListItem) then + raise ETntInternalError.Create('Internal Error: OnCreateItemClass.ItemClass must inherit from TTntListItem.'); + TntLClass := TTntListItemClass(LClass); + Result := TntLClass.Create(inherited Items); + if FTempItem = nil then + FTempItem := Result as TTntListItem; { In Delphi 5/6/7/9/10, the first item created is the temp item } + { TODO: Verify that D11 creates a temp item in its constructor. } +end; + +function TTntCustomListView.CreateListItems: TListItems{TNT-ALLOW TListItems}; +begin + Result := TTntListItems.Create(Self); +end; + +function TTntCustomListView.GetItemW(Value: TLVItemW): TTntListItem; +begin + with Value do begin + if (mask and LVIF_PARAM) <> 0 then + Result := TListItem{TNT-ALLOW TListItem}(lParam) as TTntListItem + else if iItem >= 0 then + Result := Items[IItem] + else if OwnerData then + Result := FTempItem + else + Result := nil + end; +end; + +function TTntCustomListView.OwnerDataFetchW(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; +begin + Result := OwnerDataFetch(Item, Request); +end; + +function TTntCustomListView.OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; +begin + if Assigned(OnData) then + begin + OnData(Self, Item); + Result := True; + end + else Result := False; +end; + +function TntDefaultListViewSort(Item1, Item2: TTntListItem; lParam: Integer): Integer; stdcall; +begin + Assert(Win32PlatformIsUnicode); + with Item1 do + if Assigned(ListView.OnCompare) then + ListView.OnCompare(ListView, Item1, Item2, lParam, Result) + else Result := lstrcmpw(PWideChar(Item1.Caption), PWideChar(Item2.Caption)); +end; + +procedure TTntCustomListView.WndProc(var Message: TMessage); +var + Item: TTntListItem; + InheritedItem: TListItem{TNT-ALLOW TListItem}; + SubItem: Integer; + SavedItem: TSavedListItem; + PCol: PLVColumn; + Col: TTntListColumn; +begin + with Message do begin + // restore previous values (during CreateWnd) + if (FSavedItems <> nil) and (FChangingWideItemCount = 0) and (Msg = LVM_SETITEMTEXTA) then begin + Item := Items[wParam]; + SavedItem := TSavedListItem(FSavedItems[wParam]); + if (Msg = LVM_SETITEMTEXTA) and (PLVItem(lParam).iSubItem = 0) then + Item.FCaption := SavedItem.FCaption + else begin + SubItem := PLVItem(lParam).iSubItem - 1; + TWideSubItems(Item.SubItems).FIgnoreInherited := True; + try + if SubItem < Item.SubItems.Count then begin + Item.SubItems[SubItem] := SavedItem.FSubItems[SubItem]; + Item.SubItems.Objects[SubItem] := SavedItem.FSubItems.Objects[SubItem] + end else if SubItem = Item.SubItems.Count then + Item.SubItems.AddObject(SavedItem.FSubItems[SubItem], SavedItem.FSubItems.Objects[SubItem]) + else + Item.SubItems.Assign(SavedItem.FSubItems) + finally + TWideSubItems(Item.SubItems).FIgnoreInherited := False; + end; + end; + end; + + // sync wide with ansi + if (FSavedItems = nil) and (FChangingWideItemCount = 0) and (Msg = LVM_UPDATE) then begin + Item := Items[wParam]; + InheritedItem := Item; + TWideSubItems(Item.SubItems).FIgnoreInherited := True; + try + Item.SubItems.Assign(InheritedItem.SubItems) + finally + TWideSubItems(Item.SubItems).FIgnoreInherited := False; + end; + end; + + if (FSavedItems = nil) and (FChangingWideItemCount = 0) and (Msg = LVM_SETITEMTEXTA) then begin + if OwnerData then + Item := FTempItem + else + Item := Items[wParam]; + InheritedItem := Item; + if (Msg = LVM_SETITEMTEXTA) and (PLVItem(lParam).iSubItem = 0) then + Item.FCaption := InheritedItem.Caption + else begin + SubItem := PLVItem(lParam).iSubItem - 1; + TWideSubItems(Item.SubItems).FIgnoreInherited := True; + try + if SubItem < Item.SubItems.Count then begin + Item.SubItems[SubItem] := InheritedItem.SubItems[SubItem]; + Item.SubItems.Objects[SubItem] := InheritedItem.SubItems.Objects[SubItem] + end else if SubItem = Item.SubItems.Count then + Item.SubItems.AddObject(InheritedItem.SubItems[SubItem], InheritedItem.SubItems.Objects[SubItem]) + else + Item.SubItems.Assign(InheritedItem.SubItems) + finally + TWideSubItems(Item.SubItems).FIgnoreInherited := False; + end; + end; + end; + + // capture ANSI version of DefaultListViewSort from ComCtrls + if (FTestingForSortProc) + and (Msg = LVM_SORTITEMS) then begin + ComCtrls_DefaultListViewSort := Pointer(lParam); + exit; + end; + + if (Msg = LVM_SETCOLUMNA) then begin + // make sure that wide column caption stays in sync with ANSI + PCol := PLVColumn(lParam); + if (PCol.mask and LVCF_TEXT) <> 0 then begin + Col := GetColumnFromTag(wParam); + if (Col <> nil) and (AnsiString(Col.Caption) <> PCol.pszText) then begin + Col.FCaption := PCol.pszText; + end; + end; + end; + + if (Win32PlatformIsUnicode) + and (Msg = LVM_SETITEMTEXTA) and (PLVItem(lParam).pszText = LPSTR_TEXTCALLBACK) then + // Unicode:: call wide version of text call back instead + Result := SendMessageW(Handle, LVM_SETITEMTEXTW, WParam, LParam) + else if (Win32PlatformIsUnicode) + and (Msg = LVM_SORTITEMS) and (Pointer(lParam) = @ComCtrls_DefaultListViewSort) then + // Unicode:: call wide version of sort proc instead + Result := SendMessageW(Handle, LVM_SORTITEMS, wParam, Integer(@TntDefaultListViewSort)) + else if (Win32PlatformIsUnicode) + and (Msg = LVM_SETCOLUMNA) and ((PLVColumn(lParam).mask and LVCF_TEXT) <> 0) + and (GetColumnFromTag(wParam) <> nil) then begin + PLVColumn(lParam).pszText := PAnsiChar(PWideChar(GetColumnFromTag(wParam).FCaption)); + Result := SendMessageW(Handle, LVM_SETCOLUMNW, wParam, lParam); + end else begin + if (Msg = LVM_SETEXTENDEDLISTVIEWSTYLE) and CheckBoxes then begin + { fix a bug in TCustomListView.ResetExStyles } + lParam := lParam or LVS_EX_SUBITEMIMAGES or LVS_EX_INFOTIP; + end; + inherited; + end; + end; +end; + +procedure TTntCustomListView.WMNotify(var Message: TWMNotify); +begin + inherited; + // capture updated info after inherited + with Message.NMHdr^ do + case code of + HDN_ENDTRACKW: + begin + Message.NMHdr^.code := HDN_ENDTRACKA; + try + inherited + finally + Message.NMHdr^.code := HDN_ENDTRACKW; + end; + end; + HDN_DIVIDERDBLCLICKW: + begin + Message.NMHdr^.code := HDN_DIVIDERDBLCLICKA; + try + inherited + finally + Message.NMHdr^.code := HDN_DIVIDERDBLCLICKW; + end; + end; + end; +end; + +procedure TTntCustomListView.CNNotify(var Message: TWMNotify); +var + Item: TTntListItem; +begin + if (not Win32PlatformIsUnicode) then + inherited + else begin + with Message do + begin + case NMHdr^.code of + HDN_TRACKW: + begin + NMHdr^.code := HDN_TRACKA; + try + inherited; + finally + NMHdr^.code := HDN_TRACKW; + end; + end; + LVN_GETDISPINFOW: + begin + // call inherited without the LVIF_TEXT flag + CurrentDispInfo := PLVDispInfoW(NMHdr); + try + OriginalDispInfoMask := PLVDispInfoW(NMHdr)^.item.mask; + + PLVDispInfoW(NMHdr)^.item.mask := PLVDispInfoW(NMHdr)^.item.mask and (not LVIF_TEXT); + try + NMHdr^.code := LVN_GETDISPINFOA; + try + inherited; + finally + NMHdr^.code := LVN_GETDISPINFOW; + end; + finally + if (OriginalDispInfoMask and LVIF_TEXT <> 0) then + PLVDispInfoW(NMHdr)^.item.mask := PLVDispInfoW(NMHdr)^.item.mask or LVIF_TEXT; + end; + finally + CurrentDispInfo := nil; + end; + + // handle any text info + with PLVDispInfoW(NMHdr)^.item do + begin + if (mask and LVIF_TEXT) <> 0 then + begin + Item := GetItemW(PLVDispInfoW(NMHdr)^.item); + if iSubItem = 0 then + WStrLCopy(pszText, PWideChar(Item.Caption), cchTextMax - 1) + else begin + with Item.SubItems do begin + if iSubItem <= Count then + WStrLCopy(pszText, PWideChar(Strings[iSubItem - 1]), cchTextMax - 1) + else pszText[0] := #0; + end; + end; + end; + end; + end; + LVN_ODFINDITEMW: + with PNMLVFindItem(NMHdr)^ do + begin + if ((lvfi.flags and LVFI_PARTIAL) <> 0) or ((lvfi.flags and LVFI_STRING) <> 0) then + PWideFindString := TLVFindInfoW(lvfi).psz + else + PWideFindString := nil; + lvfi.psz := nil; + NMHdr^.code := LVN_ODFINDITEMA; + try + inherited; {will Result in call to OwnerDataFind} + finally + TLVFindInfoW(lvfi).psz := PWideFindString; + NMHdr^.code := LVN_ODFINDITEMW; + PWideFindString := nil; + end; + end; + LVN_BEGINLABELEDITW: + begin + Item := GetItemW(PLVDispInfoW(NMHdr)^.item); + if not CanEdit(Item) then Result := 1; + if Result = 0 then + begin + FEditHandle := ListView_GetEditControl(Handle); + FDefEditProc := Pointer(GetWindowLongW(FEditHandle, GWL_WNDPROC)); + SetWindowLongW(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance)); + end; + end; + LVN_ENDLABELEDITW: + with PLVDispInfoW(NMHdr)^ do + if (item.pszText <> nil) and (item.IItem <> -1) then + Edit(TLVItemA(item)); + LVN_GETINFOTIPW: + begin + NMHdr^.code := LVN_GETINFOTIPA; + try + inherited; + finally + NMHdr^.code := LVN_GETINFOTIPW; + end; + end; + else + inherited; + end; + end; + end; +end; + +function TTntCustomListView.OwnerDataFindW(Find: TItemFind; + const FindString: WideString; const FindPosition: TPoint; + FindData: Pointer; StartIndex: Integer; Direction: TSearchDirection; + Wrap: Boolean): Integer; +begin + Result := OwnerDataFind(Find, FindString, FindPosition, FindData, StartIndex, Direction, Wrap); +end; + +function TTntCustomListView.OwnerDataFind(Find: TItemFind; const FindString: WideString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; +var + AnsiEvent: TLVOwnerDataFindEvent; +begin + Result := -1; + if Assigned(OnDataFind) then + OnDataFind(Self, Find, FindString, FindPosition, FindData, StartIndex, Direction, Wrap, Result) + else if Assigned(inherited OnDataFind) then begin + AnsiEvent := inherited OnDataFind; + AnsiEvent(Self, Find, FindString, FindPosition, FindData, StartIndex, Direction, + Wrap, Result); + end; +end; + +procedure TTntCustomListView.Edit(const Item: TLVItem); +var + S: WideString; + AnsiS: AnsiString; + EditItem: TTntListItem; + AnsiEvent: TLVEditedEvent; +begin + if (not Win32PlatformIsUnicode) then + S := Item.pszText + else + S := TLVItemW(Item).pszText; + EditItem := GetItemW(TLVItemW(Item)); + if Assigned(OnEdited) then + OnEdited(Self, EditItem, S) + else if Assigned(inherited OnEdited) then + begin + AnsiEvent := inherited OnEdited; + AnsiS := S; + AnsiEvent(Self, EditItem, AnsiS); + S := AnsiS; + end; + if EditItem <> nil then + EditItem.Caption := S; +end; + +procedure TTntCustomListView.EditWndProcW(var Message: TMessage); +begin + Assert(Win32PlatformIsUnicode); + try + with Message do + begin + case Msg of + WM_KEYDOWN, + WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit; + WM_CHAR: + begin + MakeWMCharMsgSafeForAnsi(Message); + try + if DoKeyPress(TWMKey(Message)) then Exit; + finally + RestoreWMCharMsg(Message); + end; + end; + WM_KEYUP, + WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit; + CN_KEYDOWN, + CN_CHAR, CN_SYSKEYDOWN, + CN_SYSCHAR: + begin + WndProc(Message); + Exit; + end; + end; + Result := CallWindowProcW(FDefEditProc, FEditHandle, Msg, WParam, LParam); + end; + except + Application.HandleException(Self); + end; +end; + +procedure TTntCustomListView.BeginChangingWideItem; +begin + Inc(FChangingWideItemCount); +end; + +procedure TTntCustomListView.EndChangingWideItem; +begin + if FChangingWideItemCount > 0 then + Dec(FChangingWideItemCount); +end; + +procedure TTntCustomListView.DrawItem(Item: TListItem{TNT-ALLOW TListItem}; Rect: TRect; + State: TOwnerDrawState); +begin + TControlCanvas(Canvas).UpdateTextFlags; + if Assigned(OnDrawItem) then OnDrawItem(Self, Item, Rect, State) + else + begin + Canvas.FillRect(Rect); + WideCanvasTextOut(Canvas, Rect.Left + 2, Rect.Top, Item.Caption); + end; +end; + +procedure TTntCustomListView.CopySelection(Destination: TCustomListControl); +var + I: Integer; +begin + for I := 0 to Items.Count - 1 do + if Items[I].Selected then + WideListControl_AddItem(Destination, Items[I].Caption, Items[I].Data); +end; + +procedure TTntCustomListView.AddItem(const Item: WideString; AObject: TObject); +begin + with Items.Add do + begin + Caption := Item; + Data := AObject; + end; +end; + +//------------- + +function TTntCustomListView.FindCaption(StartIndex: Integer; Value: WideString; + Partial, Inclusive, Wrap: Boolean): TTntListItem; +const + FullString: array[Boolean] of Integer = (0, LVFI_PARTIAL); + Wraps: array[Boolean] of Integer = (0, LVFI_WRAP); +var + Info: TLVFindInfoW; + Index: Integer; +begin + if (not Win32PlatformIsUnicode) then + Result := inherited FindCaption(StartIndex, Value, Partial, Inclusive, Wrap) as TTntListItem + else begin + with Info do + begin + flags := LVFI_STRING or FullString[Partial] or Wraps[Wrap]; + psz := PWideChar(Value); + end; + if Inclusive then Dec(StartIndex); + Index := SendMessageW(Handle, LVM_FINDITEMW, StartIndex, Longint(@Info)); + if Index <> -1 then Result := Items[Index] + else Result := nil; + end; +end; + +function TTntCustomListView.StringWidth(S: WideString): Integer; +begin + if (not Win32PlatformIsUnicode) then + Result := inherited StringWidth(S) + else + Result := SendMessageW(Handle, LVM_GETSTRINGWIDTHW, 0, Longint(PWideChar(S))) +end; + +function TTntCustomListView.GetSearchString: WideString; +var + Buffer: array[0..1023] of WideChar; +begin + if (not Win32PlatformIsUnicode) then + Result := inherited GetSearchString + else begin + Result := ''; + if HandleAllocated + and Bool(SendMessageW(Handle, LVM_GETISEARCHSTRINGW, 0, Longint(PWideChar(@Buffer[0])))) then + Result := Buffer; + end; +end; + +function TTntCustomListView.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomListView.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomListView.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomListView.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomListView.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntToolButton } + +procedure TTntToolButton.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntToolButton.CMVisibleChanged(var Message: TMessage); +begin + inherited; + RefreshControl; +end; + +function TTntToolButton.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntToolButton.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); + RefreshControl; { causes button to be removed and reinserted with TB_INSERTBUTTON } +end; + +function TTntToolButton.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntToolButton.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntToolButton.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntToolButton.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +procedure TTntToolButton.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntToolButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntToolButton.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntToolButton.GetMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; +begin + Result := inherited MenuItem; +end; + +procedure TTntToolButton.SetMenuItem(const Value: TMenuItem{TNT-ALLOW TMenuItem}); +begin + inherited MenuItem := Value; + if Value is TTntMenuItem then begin + Caption := TTntMenuItem(Value).Caption; + Hint := TTntMenuItem(Value).Hint; + end; +end; + +{ TTntToolBar } + +procedure TTntToolBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, TOOLBARCLASSNAME); +end; + +procedure TTntToolBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntToolBar.TBInsertButtonA(var Message: TMessage); +var + Button: TTntToolButton; + Buffer: WideString; +begin + if Win32PlatformIsUnicode + and (PTBButton(Message.LParam).iString <> -1) + and (Buttons[Message.WParam] is TTntToolButton) then + begin + Button := TTntToolButton(Buttons[Message.WParam]); + Buffer := Button.Caption + WideChar(#0); + PTBButton(Message.LParam).iString := + SendMessage(Handle, TB_ADDSTRINGW, 0, Integer(PWideChar(Buffer))); + end; + inherited; +end; + +{ Need to read/write caption ourselves - default wndproc seems to discard it. } + +procedure TTntToolBar.WMGetText(var Message: TWMGetText); +begin + if (not Win32PlatformIsUnicode) or (WindowHandle = 0) then + inherited + else + with Message do + Result := WStrLen(WStrLCopy(PWideChar(Text), PWideChar(FCaption), TextMax - 1)); +end; + +procedure TTntToolBar.WMGetTextLength(var Message: TWMGetTextLength); +begin + if (not Win32PlatformIsUnicode) or (WindowHandle = 0) then + inherited + else + Message.Result := Length(FCaption); +end; + +procedure TTntToolBar.WMSetText(var Message: TWMSetText); +begin + if (not Win32PlatformIsUnicode) or (WindowHandle = 0) then + inherited + else + with Message do + SetString(FCaption, PWideChar(Text), WStrLen(PWideChar(Text))); +end; + +function TTntToolBar.GetCaption: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntToolBar.SetCaption(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +function TTntToolBar.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntToolBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntToolBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntToolBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +procedure TTntToolBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntToolBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntToolBar.GetMenu: TMainMenu{TNT-ALLOW TMainMenu}; +begin + Result := inherited Menu; +end; + +procedure TTntToolBar.SetMenu(const Value: TMainMenu{TNT-ALLOW TMainMenu}); +var + I: Integer; +begin + if (Menu <> Value) then begin + inherited Menu := Value; + if Assigned(Menu) then begin + // get rid of TToolButton(s) + for I := ButtonCount - 1 downto 0 do + Buttons[I].Free; + // add TTntToolButton(s) + for I := Menu.Items.Count - 1 downto 0 do + begin + with TTntToolButton.Create(Self) do + try + AutoSize := True; + Grouped := True; + Parent := Self; + MenuItem := Menu.Items[I]; + except + Free; + raise; + end; + end; + end; + end; +end; + +{ TTntRichEditStrings } +type + TTntRichEditStrings = class(TTntMemoStrings) + private + RichEdit: TCustomRichEdit{TNT-ALLOW TCustomRichEdit}; + procedure EnableChange(const Value: Boolean); + protected + procedure SetTextStr(const Value: WideString); override; + public + constructor Create; + procedure AddStrings(Strings: TWideStrings); overload; override; + //-- + procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); override; + procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); override; + procedure LoadFromFile(const FileName: WideString); override; + procedure SaveToFile(const FileName: WideString); override; + end; + +constructor TTntRichEditStrings.Create; +begin + inherited Create; + FRichEditMode := True; +end; + +procedure TTntRichEditStrings.AddStrings(Strings: TWideStrings); +var + SelChange: TNotifyEvent; +begin + SelChange := TTntCustomRichEdit(RichEdit).OnSelectionChange; + TTntCustomRichEdit(RichEdit).OnSelectionChange := nil; + try + inherited; + finally + TTntCustomRichEdit(RichEdit).OnSelectionChange := SelChange; + end; +end; + +procedure TTntRichEditStrings.EnableChange(const Value: Boolean); +var + EventMask: Longint; +begin + with RichEdit do + begin + if Value then + EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE + else + EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE; + SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask); + end; +end; + +procedure TTntRichEditStrings.SetTextStr(const Value: WideString); +begin + EnableChange(False); + try + inherited; + finally + EnableChange(True); + end; +end; + +type TAccessCustomRichEdit = class(TCustomRichEdit{TNT-ALLOW TCustomRichEdit}); + +procedure TTntRichEditStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); +begin + if TAccessCustomRichEdit(RichEdit).PlainText then + inherited LoadFromStream_BOM(Stream, WithBOM) + else + TAccessCustomRichEdit(RichEdit).Lines.LoadFromStream(Stream); +end; + +procedure TTntRichEditStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); +begin + if TAccessCustomRichEdit(RichEdit).PlainText then + inherited SaveToStream_BOM(Stream, WithBOM) + else + TAccessCustomRichEdit(RichEdit).Lines.SaveToStream(Stream); +end; + +procedure TTntRichEditStrings.LoadFromFile(const FileName: WideString); +begin + if TAccessCustomRichEdit(RichEdit).PlainText then + inherited LoadFromFile(FileName) + else + TAccessCustomRichEdit(RichEdit).Lines.LoadFromFile(FileName); +end; + +procedure TTntRichEditStrings.SaveToFile(const FileName: WideString); +begin + if TAccessCustomRichEdit(RichEdit).PlainText then + inherited SaveToFile(FileName) + else + TAccessCustomRichEdit(RichEdit).Lines.SaveToFile(FileName); +end; + +{ TTntCustomRichEdit } + +constructor TTntCustomRichEdit.Create(AOwner: TComponent); +begin + inherited; + FRichEditStrings := TTntRichEditStrings.Create; + TTntRichEditStrings(FRichEditStrings).FMemo := Self; + TTntRichEditStrings(FRichEditStrings).FMemoLines := TAccessCustomRichEdit(Self).Lines; + TTntRichEditStrings(FRichEditStrings).FLineBreakStyle := Self.LineBreakStyle; + TTntRichEditStrings(FRichEditStrings).RichEdit := Self; +end; + +var + FRichEdit20Module: THandle = 0; + +function IsRichEdit20Available: Boolean; +const + RICHED20_DLL = 'RICHED20.DLL'; +begin + if FRichEdit20Module = 0 then + FRichEdit20Module := Tnt_LoadLibraryW(RICHED20_DLL); + Result := FRichEdit20Module <> 0; +end; + +{function IsRichEdit30Available: Boolean; +begin + Result := False; + exit; + Result := IsRichEdit20Available and (Win32MajorVersion >= 5); +end;} + +procedure TTntCustomRichEdit.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + if WordWrap then + Params.Style := Params.Style and not WS_HSCROLL; // more compatible with RichEdit 1.0 +end; + +procedure TTntCustomRichEdit.CreateWindowHandle(const Params: TCreateParams); +begin + if Win32PlatformIsUnicode and IsRichEdit20Available then + CreateUnicodeHandle(Self, Params, RICHEDIT_CLASSW) + else + inherited +end; + +var + AIMM: IActiveIMMApp = nil; + +function EnableActiveIMM: Boolean; +begin + if AIMM <> nil then + Result := True + else begin + Result := False; + try + if ClassIsRegistered(CLASS_CActiveIMM) then begin + AIMM := CoCActiveIMM.Create; + AIMM.Activate(1); + Result := True; + end; + except + AIMM := nil; + end; + end; +end; + +procedure TTntCustomRichEdit.CreateWnd; +const + EM_SETEDITSTYLE = WM_USER + 204; + SES_USEAIMM = 64; +begin + inherited; + // Only supported in RichEdit 3.0, but this flag is harmless to RichEdit1.0 or RichEdit 2.0 + if EnableActiveIMM then + SendMessage(Handle, EM_SETEDITSTYLE, SES_USEAIMM, SES_USEAIMM); +end; + +procedure TTntCustomRichEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +destructor TTntCustomRichEdit.Destroy; +begin + FreeAndNil(FRichEditStrings); + inherited; +end; + +procedure TTntCustomRichEdit.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited; + if (not WantReturns) and (Key = VK_RETURN) and (Shift <> [ssCtrl]) then + Key := 0; +end; + +function TTntCustomRichEdit.LineBreakStyle: TTntTextLineBreakStyle; +begin + if Win32PlatformIsUnicode and IsRichEdit20Available then + Result := tlbsCR + else + Result := tlbsCRLF; +end; + +procedure TTntCustomRichEdit.SetRichEditStrings(const Value: TTntStrings); +begin + FRichEditStrings.Assign(Value); +end; + +function TTntCustomRichEdit.GetSelText: string{TNT-ALLOW string}; +begin + Result := GetWideSelText; +end; + +function TTntCustomRichEdit.GetWideSelText: WideString; +var + CharRange: TCharRange; + Length: Integer; +begin + if (not IsWindowUnicode(Handle)) then + Result := inherited GetSelText + else begin + SendMessageW(Handle, EM_EXGETSEL, 0, Longint(@CharRange)); + SetLength(Result, CharRange.cpMax - CharRange.cpMin + 1); + Length := SendMessageW(Handle, EM_GETSELTEXT, 0, Longint(PWideChar(Result))); + SetLength(Result, Length); + end; + if LineBreakStyle <> tlbsCRLF then + Result := TntAdjustLineBreaks(Result, tlbsCRLF) +end; + +type + TSetTextEx = record + flags:dword; + codepage:uint; + end; + +procedure TTntCustomRichEdit.SetRTFText(Flags: DWORD; const Value: AnsiString); +const + EM_SETTEXTEX = (WM_USER + 97); +var + Info: TSetTextEx; +begin + Info.flags := Flags; + Info.codepage := CP_ACP{TNT-ALLOW CP_ACP}; + SendMessage(Handle, EM_SETTEXTEX, Integer(@Info), Integer(PAnsiChar(Value))); +end; + +procedure TTntCustomRichEdit.SetWideSelText(const Value: WideString); +const + ST_SELECTION = 2; +begin + if Win32PlatformIsUnicode and IsRichEdit20Available and IsRTF(Value) then begin + // emulate RichEdit 1.0 so that RTF code is inserted as RTF (not plain text) + SetRTFText(ST_SELECTION, Value) + end else + TntCustomEdit_SetSelText(Self, TntAdjustLineBreaks(Value, LineBreakStyle)); +end; + +function TTntCustomRichEdit.GetText: WideString; +begin + Result := TntControl_GetText(Self); + if (LineBreakStyle <> tlbsCRLF) then + Result := TntAdjustLineBreaks(Result, tlbsCRLF); +end; + +procedure TTntCustomRichEdit.SetText(const Value: WideString); +const + ST_DEFAULT = 0; +begin + if Win32PlatformIsUnicode and IsRichEdit20Available and IsRTF(Value) then begin + // emulate RichEdit 1.0 so that RTF code is inserted as RTF (not plain text) + SetRTFText(ST_DEFAULT, Value) + end else if Value <> Text then + TntControl_SetText(Self, TntAdjustLineBreaks(Value, LineBreakStyle)); +end; + +function TTntCustomRichEdit.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomRichEdit.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomRichEdit.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomRichEdit.WMGetTextLength(var Message: TWMGetTextLength); +begin + if FPrintingTextLength <> 0 then + Message.Result := FPrintingTextLength + else + inherited; +end; + +procedure TTntCustomRichEdit.Print(const Caption: string{TNT-ALLOW string}); +begin + if (LineBreakStyle <> tlbsCRLF) then + FPrintingTextLength := TntAdjustLineBreaksLength(Text, LineBreakStyle) + else + FPrintingTextLength := 0; + try + inherited + finally + FPrintingTextLength := 0; + end; +end; + +{$WARN SYMBOL_DEPRECATED OFF} + +function TTntCustomRichEdit.CharPosToGet(RawWin32CharPos: Integer): Integer; +begin + Result := EmulatedCharPos(RawWin32CharPos); +end; + +function TTntCustomRichEdit.CharPosToSet(EmulatedCharPos: Integer): Integer; +begin + Result := RawWin32CharPos(EmulatedCharPos); +end; +{$WARN SYMBOL_DEPRECATED ON} + +function TTntCustomRichEdit.EmulatedCharPos(RawWin32CharPos: Integer): Integer; +var + i: Integer; + ThisLine: Integer; + CharCount: Integer; + Line_Start: Integer; + NumLineBreaks: Integer; +begin + if (LineBreakStyle = tlbsCRLF) or (RawWin32CharPos <= 0) then + Result := RawWin32CharPos + else begin + Assert(Win32PlatformIsUnicode); + ThisLine := SendMessageW(Handle, EM_EXLINEFROMCHAR, 0, RawWin32CharPos); + if (not WordWrap) then + NumLineBreaks := ThisLine + else begin + CharCount := 0; + for i := 0 to ThisLine - 1 do + Inc(CharCount, TntMemo_LineLength(Handle, i)); + Line_Start := TntMemo_LineStart(Handle, ThisLine); + NumLineBreaks := Line_Start - CharCount; + end; + Result := RawWin32CharPos + NumLineBreaks; {inflate CR -> CR/LF} + end; +end; + +function TTntCustomRichEdit.RawWin32CharPos(EmulatedCharPos: Integer): Integer; +var + Line: Integer; + NumLineBreaks: Integer; + CharCount: Integer; + Line_Start: Integer; + LineLength: Integer; +begin + if (LineBreakStyle = tlbsCRLF) or (EmulatedCharPos <= 0) then + Result := EmulatedCharPos + else begin + Assert(Win32PlatformIsUnicode); + NumLineBreaks := 0; + CharCount := 0; + for Line := 0 to Lines.Count do begin + Line_Start := TntMemo_LineStart(Handle, Line); + if EmulatedCharPos < (Line_Start + NumLineBreaks) then + break; {found it (it must have been the line separator)} + if Line_Start > CharCount then begin + Inc(NumLineBreaks); + Inc(CharCount); + end; + LineLength := TntMemo_LineLength(Handle, Line, Line_Start); + Inc(CharCount, LineLength); + if (EmulatedCharPos >= (Line_Start + NumLineBreaks)) + and (EmulatedCharPos < (Line_Start + LineLength + NumLineBreaks)) then + break; {found it} + end; + Result := EmulatedCharPos - NumLineBreaks; {deflate CR/LF -> CR} + end; +end; + +function TTntCustomRichEdit.FindText(const SearchStr: WideString; + StartPos, Length: Integer; Options: TSearchTypes): Integer; +const + EM_FINDTEXTEXW = WM_USER + 124; +const + FR_DOWN = $00000001; + FR_WHOLEWORD = $00000002; + FR_MATCHCASE = $00000004; +var + Find: TFindTextW; + Flags: Integer; +begin + if (not Win32PlatformIsUnicode) then + Result := inherited FindText(SearchStr, StartPos, Length, Options) + else begin + with Find.chrg do + begin + cpMin := RawWin32CharPos(StartPos); + cpMax := RawWin32CharPos(StartPos + Length); + end; + Flags := FR_DOWN; { RichEdit 2.0 and later needs this } + if stWholeWord in Options then Flags := Flags or FR_WHOLEWORD; + if stMatchCase in Options then Flags := Flags or FR_MATCHCASE; + Find.lpstrText := PWideChar(SearchStr); + Result := SendMessageW(Handle, EM_FINDTEXT, Flags, LongInt(@Find)); + Result := EmulatedCharPos(Result); + end; +end; + +function TTntCustomRichEdit.GetSelStart: Integer; +begin + Result := TntCustomEdit_GetSelStart(Self); + Result := EmulatedCharPos(Result); +end; + +procedure TTntCustomRichEdit.SetSelStart(const Value: Integer); +begin + TntCustomEdit_SetSelStart(Self, RawWin32CharPos(Value)); +end; + +function TTntCustomRichEdit.GetSelLength: Integer; +var + CharRange: TCharRange; +begin + if (LineBreakStyle = tlbsCRLF) then + Result := TntCustomEdit_GetSelLength(Self) + else begin + Assert(Win32PlatformIsUnicode); + SendMessageW(Handle, EM_EXGETSEL, 0, Longint(@CharRange)); + Result := EmulatedCharPos(CharRange.cpMax) - EmulatedCharPos(CharRange.cpMin); + end; +end; + +procedure TTntCustomRichEdit.SetSelLength(const Value: Integer); +var + StartPos: Integer; + SelEnd: Integer; +begin + if (LineBreakStyle = tlbsCRLF) then + TntCustomEdit_SetSelLength(Self, Value) + else begin + StartPos := Self.SelStart; + SelEnd := StartPos + Value; + inherited SetSelLength(RawWin32CharPos(SelEnd) - RawWin32CharPos(StartPos)); + end; +end; + +procedure TTntCustomRichEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomRichEdit.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntTabStrings } + +type TAccessCustomTabControl = class(TCustomTabControl{TNT-ALLOW TCustomTabControl}); + +type + TTntTabStrings = class(TTntStrings) + private + FTabControl: TCustomTabControl{TNT-ALLOW TCustomTabControl}; + FAnsiTabs: TStrings{TNT-ALLOW TStrings}; + protected + function Get(Index: Integer): WideString; override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure Put(Index: Integer; const S: WideString); override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: WideString); override; + end; + +procedure TabControlError(const S: WideString); +begin + raise EListError.Create(S); +end; + +procedure TTntTabStrings.Clear; +begin + FAnsiTabs.Clear; +end; + +procedure TTntTabStrings.Delete(Index: Integer); +begin + FAnsiTabs.Delete(Index); +end; + +function TTntTabStrings.GetCount: Integer; +begin + Result := FAnsiTabs.Count; +end; + +function TTntTabStrings.GetObject(Index: Integer): TObject; +begin + Result := FAnsiTabs.Objects[Index]; +end; + +procedure TTntTabStrings.PutObject(Index: Integer; AObject: TObject); +begin + FAnsiTabs.Objects[Index] := AObject; +end; + +procedure TTntTabStrings.SetUpdateState(Updating: Boolean); +begin + inherited; + TAccessStrings(FAnsiTabs).SetUpdateState(Updating); +end; + +function TTntTabStrings.Get(Index: Integer): WideString; +const + RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); +var + TCItem: TTCItemW; + Buffer: array[0..4095] of WideChar; +begin + if (not Win32PlatformIsUnicode) then + Result := FAnsiTabs[Index] + else begin + TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading]; + TCItem.pszText := Buffer; + TCItem.cchTextMax := SizeOf(Buffer); + if SendMessageW(FTabControl.Handle, TCM_GETITEMW, Index, Longint(@TCItem)) = 0 then + TabControlError(WideFormat(sTabFailRetrieve, [Index])); + Result := Buffer; + end; +end; + +function GetTabControlImageIndex(Self: TCustomTabControl{TNT-ALLOW TCustomTabControl}; TabIndex: Integer): Integer; +begin + Result := TabIndex; + with TAccessCustomTabControl(Self) do + if Assigned(OnGetImageIndex) then OnGetImageIndex(Self, TabIndex, Result); +end; + +procedure TTntTabStrings.Put(Index: Integer; const S: WideString); +const + RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); +var + TCItem: TTCItemW; +begin + if (not Win32PlatformIsUnicode) then + FAnsiTabs[Index] := S + else begin + TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or TCIF_IMAGE; + TCItem.pszText := PWideChar(S); + TCItem.iImage := GetTabControlImageIndex(FTabControl, Index); + if SendMessageW(FTabControl.Handle, TCM_SETITEMW, Index, Longint(@TCItem)) = 0 then + TabControlError(WideFormat(sTabFailSet, [S, Index])); + TAccessCustomTabControl(FTabControl).UpdateTabImages; + end; +end; + +procedure TTntTabStrings.Insert(Index: Integer; const S: WideString); +const + RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); +var + TCItem: TTCItemW; +begin + if (not Win32PlatformIsUnicode) then + FAnsiTabs.Insert(Index, S) + else begin + TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or TCIF_IMAGE; + TCItem.pszText := PWideChar(S); + TCItem.iImage := GetTabControlImageIndex(FTabControl, Index); + if SendMessageW(FTabControl.Handle, TCM_INSERTITEMW, Index, Longint(@TCItem)) < 0 then + TabControlError(WideFormat(sTabFailSet, [S, Index])); + TAccessCustomTabControl(FTabControl).UpdateTabImages; + end; +end; + +{ TTntCustomTabControl } + +constructor TTntCustomTabControl.Create(AOwner: TComponent); +begin + inherited; + FTabs := TTntTabStrings.Create; + TTntTabStrings(FTabs).FTabControl := Self; + TTntTabStrings(FTabs).FAnsiTabs := inherited Tabs; +end; + +destructor TTntCustomTabControl.Destroy; +begin + TTntTabStrings(FTabs).FTabControl := nil; + TTntTabStrings(FTabs).FAnsiTabs := nil; + FreeAndNil(FTabs); + FreeAndNil(FSaveTabs); + inherited; +end; + +procedure TTntCustomTabControl.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_TABCONTROL); +end; + +procedure TTntCustomTabControl.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomTabControl.CreateWnd; +begin + inherited; + if FSaveTabs <> nil then + begin + FTabs.Assign(FSaveTabs); + FreeAndNil(FSaveTabs); + TabIndex := FSaveTabIndex; + end; +end; + +procedure TTntCustomTabControl.DestroyWnd; +begin + if (FTabs <> nil) and (FTabs.Count > 0) then + begin + FSaveTabs := TTntStringList.Create; + FSaveTabs.Assign(FTabs); + FSaveTabIndex := TabIndex; + end; + inherited; +end; + +function TTntCustomTabControl.GetTabs: TTntStrings; +begin + if FSaveTabs <> nil then + Result := FSaveTabs // Use FSaveTabs while the window is deallocated + else + Result := FTabs; +end; + +procedure TTntCustomTabControl.SetTabs(const Value: TTntStrings); +begin + FTabs.Assign(Value); +end; + +function TTntCustomTabControl.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomTabControl.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomTabControl.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomTabControl.CMDialogChar(var Message: TCMDialogChar); +var + I: Integer; +begin + for I := 0 to Tabs.Count - 1 do + if IsWideCharAccel(Message.CharCode, Tabs[I]) and CanShowTab(I) and CanFocus then + begin + Message.Result := 1; + if CanChange then + begin + TabIndex := I; + Change; + end; + Exit; + end; + Broadcast(Message); +end; + +procedure TTntCustomTabControl.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomTabControl.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntTabSheet } + +procedure TTntTabSheet.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +function TTntTabSheet.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntTabSheet.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntTabSheet.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntTabSheet.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntTabSheet.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntTabSheet.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntTabSheet.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntTabSheet.WMSetText(var Message: TWMSetText); +begin + if (not Win32PlatformIsUnicode) + or (HandleAllocated) + or (Message.Text = AnsiString(TntControl_GetText(Self))) + or (Force_Inherited_WMSETTEXT) then + inherited + else begin + // NT, handle not allocated and text is different + Force_Inherited_WMSETTEXT := True; + try + TntControl_SetText(Self, Message.Text) { sync WideCaption with ANSI Caption } + finally + Force_Inherited_WMSETTEXT := FALSE; + end; + end; +end; + +procedure TTntTabSheet.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntTabSheet.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntPageControl } + +procedure TTntPageControl.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_TABCONTROL); +end; + +procedure TTntPageControl.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPageControl.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntPageControl.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntPageControl.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntPageControl.WndProc(var Message: TMessage); +const + RTL: array[Boolean] of Cardinal = (0, TCIF_RTLREADING); +var + TCItemA: PTCItemA; + TabSheet: TTabSheet{TNT-ALLOW TTabSheet}; + Text: WideString; +begin + if (not Win32PlatformIsUnicode) then + inherited + else begin + case Message.Msg of + TCM_SETITEMA: + begin + TCItemA := PTCItemA(Message.lParam); + if ((TCItemA.mask and TCIF_PARAM) = TCIF_PARAM) then + TabSheet := TObject(TCItemA.lParam) as TTabSheet{TNT-ALLOW TTabSheet} + else if ((TCItemA.mask and TCIF_TEXT) = TCIF_TEXT) + and (Message.wParam >= 0) and (Message.wParam <= Tabs.Count - 1) then + TabSheet := Tabs.Objects[Message.wParam] as TTabSheet{TNT-ALLOW TTabSheet} + else + TabSheet := nil; + + if TabSheet = nil then begin + // will always be followed by TCM_SETITEMA(TCIF_PARAM) if TCIF_TEXT is present + TCItemA.mask := TCItemA.mask and (not TCIF_TEXT); + end else begin + // convert message to unicode, add text + Message.Msg := TCM_SETITEMW; + TCItemA.mask := TCItemA.mask or TCIF_TEXT or RTL[UseRightToLeftReading]; + if TabSheet is TTntTabSheet then + Text := TTntTabSheet(TabSheet).Caption + else + Text := TabSheet.Caption; + TCItemA.pszText := PAnsiChar(PWideChar(Text)); + end; + end; + TCM_INSERTITEMA: + begin + TCItemA := PTCItemA(Message.lParam); + // will always be followed by TCM_SETITEMA(TCIF_PARAM) if TCIF_TEXT is present + TCItemA.mask := TCItemA.mask and (not TCIF_TEXT); + end; + end; + inherited; + end; +end; + +procedure TTntPageControl.CMDialogChar(var Message: TCMDialogChar); +var + I: Integer; + TabText: WideString; +begin + for I := 0 to PageCount - 1 do begin + if Pages[i] is TTntTabSheet then + TabText := TTntTabSheet(Pages[i]).Caption + else + TabText := Pages[i].Caption; + if IsWideCharAccel(Message.CharCode, TabText) and CanShowTab(Pages[i].TabIndex) and CanFocus then + begin + Message.Result := 1; + if CanChange then + begin + TabIndex := Pages[i].TabIndex; + Change; + end; + Exit; + end; + end; + Broadcast(Message); +end; + +procedure TTntPageControl.CMDockClient(var Message: TCMDockClient); +var + IsVisible: Boolean; + DockCtl: TControl; +begin + Message.Result := 0; + FNewDockSheet := TTntTabSheet.Create(Self); + try + try + DockCtl := Message.DockSource.Control; + if DockCtl is TCustomForm then + FNewDockSheet.Caption := TntControl_GetText(DockCtl); + FNewDockSheet.PageControl := Self; + DockCtl.Dock(Self, Message.DockSource.DockRect); + except + FNewDockSheet.Free; + raise; + end; + IsVisible := DockCtl.Visible; + FNewDockSheet.TabVisible := IsVisible; + if IsVisible then ActivePage := FNewDockSheet; + DockCtl.Align := alClient; + finally + FNewDockSheet := nil; + end; +end; + +procedure TTntPageControl.DoAddDockClient(Client: TControl; const ARect: TRect); +begin + if FNewDockSheet <> nil then + Client.Parent := FNewDockSheet; +end; + +procedure TTntPageControl.CMDockNotification(var Message: TCMDockNotification); +var + I: Integer; + S: WideString; + Page: TTabSheet{TNT-ALLOW TTabSheet}; +begin + Page := GetPageFromDockClient(Message.Client); + if (Message.NotifyRec.ClientMsg <> WM_SETTEXT) + or (Page = nil) or (not (Page is TTntTabSheet)) then + inherited + else begin + if (Message.Client is TWinControl) + and (TWinControl(Message.Client).HandleAllocated) + and IsWindowUnicode(TWinControl(Message.Client).Handle) then + S := PWideChar(Message.NotifyRec.MsgLParam) + else + S := PAnsiChar(Message.NotifyRec.MsgLParam); + { Search for first CR/LF and end string there } + for I := 1 to Length(S) do + if S[I] in [CR, LF] then + begin + SetLength(S, I - 1); + Break; + end; + TTntTabSheet(Page).Caption := S; + end; +end; + +procedure TTntPageControl.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntPageControl.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntTrackBar } + +procedure TTntTrackBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, TRACKBAR_CLASS); +end; + +procedure TTntTrackBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntTrackBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntTrackBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntTrackBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntTrackBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntTrackBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntProgressBar } + +procedure TTntProgressBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, PROGRESS_CLASS); +end; + +procedure TTntProgressBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntProgressBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntProgressBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntProgressBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntProgressBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntProgressBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomUpDown } + +procedure TTntCustomUpDown.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, UPDOWN_CLASS); +end; + +procedure TTntCustomUpDown.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomUpDown.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomUpDown.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomUpDown.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomUpDown.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomUpDown.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntDateTimePicker } + +procedure TTntDateTimePicker.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, DATETIMEPICK_CLASS); +end; + +procedure TTntDateTimePicker.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDateTimePicker.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntDateTimePicker.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntDateTimePicker.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntDateTimePicker.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntDateTimePicker.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntDateTimePicker.CreateWnd; +var + SaveChecked: Boolean; +begin + FHadFirstMouseClick := False; + SaveChecked := Checked; + inherited; + // This fixes an issue where TDateTimePicker.CNNotify causes "FChecked := True" to occur + // during window creation. This issue results in .Checked to read True even though + // it is not visually checked. + Checked := SaveChecked; +end; + +procedure TTntDateTimePicker.WMLButtonDown(var Message: TWMLButtonDown); + + procedure UpdateValues; + var + Hdr: TNMDateTimeChange; + begin + Hdr.nmhdr.hwndFrom := Handle; + Hdr.nmhdr.idFrom := 0; + Hdr.nmhdr.code := DTN_DATETIMECHANGE; + Hdr.dwFlags := DateTime_GetSystemTime(Handle, Hdr.st); + if (Hdr.dwFlags <> Cardinal(GDT_ERROR)) then begin + if Hdr.dwFlags = GDT_NONE then + ZeroMemory(@Hdr.st, SizeOf(Hdr.st)); + Perform(CN_NOTIFY, Integer(Handle), Integer(@Hdr)); + end; + end; + +begin + inherited; + if ShowCheckBox and (not FHadFirstMouseClick) then begin + FHadFirstMouseClick := True; + UpdateValues; // Sometimes the first mouse click doesn't result in WM_NOTIFY. + end; +end; + +{ TTntMonthCalendar } + +procedure TTntMonthCalendar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, MONTHCAL_CLASS); + if Win32PlatformIsUnicode then begin + { For some reason WM_NOTIFY:MCN_GETDAYSTATE never gets called. } + ForceGetMonthInfo; + end; +end; + +procedure TTntMonthCalendar.ForceGetMonthInfo; +var + Hdr: TNMDayState; + Days: array of TMonthDayState; + Range: array[1..2] of TSystemTime; +begin + // populate Days array + Hdr.nmhdr.hwndFrom := Handle; + Hdr.nmhdr.idFrom := 0; + Hdr.nmhdr.code := MCN_GETDAYSTATE; + Hdr.cDayState := MonthCal_GetMonthRange(Handle, GMR_DAYSTATE, @Range[1]); + Hdr.stStart := Range[1]; + SetLength(Days, Hdr.cDayState); + Hdr.prgDayState := @Days[0]; + SendMessage(Handle, CN_NOTIFY, Integer(Handle), Integer(@Hdr)); + // update day state + SendMessage(Handle, MCM_SETDAYSTATE, Hdr.cDayState, Longint(Hdr.prgDayState)) +end; + +procedure TTntMonthCalendar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntMonthCalendar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntMonthCalendar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntMonthCalendar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntMonthCalendar.GetDate: TDate; +begin + Result := Trunc(inherited Date); { Fixes issue where Date always reflects time of saving dfm. } +end; + +procedure TTntMonthCalendar.SetDate(const Value: TDate); +begin + inherited Date := Trunc(Value); +end; + +procedure TTntMonthCalendar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntMonthCalendar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntPageScroller } + +procedure TTntPageScroller.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_PAGESCROLLER); +end; + +procedure TTntPageScroller.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPageScroller.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntPageScroller.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntPageScroller.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntPageScroller.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntPageScroller.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntStatusPanel } + +procedure TTntStatusPanel.Assign(Source: TPersistent); +begin + inherited; + if Source is TTntStatusPanel then + Text := TTntStatusPanel(Source).Text; +end; + +procedure TTntStatusPanel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntStatusPanel.GetText: Widestring; +begin + Result := GetSyncedWideString(FText, inherited Text); +end; + +procedure TTntStatusPanel.SetInheritedText(const Value: AnsiString); +begin + inherited Text := Value; +end; + +procedure TTntStatusPanel.SetText(const Value: Widestring); +begin + SetSyncedWideString(Value, FText, inherited Text, SetInheritedText); +end; + +{ TTntStatusPanels } + +function TTntStatusPanels.GetItem(Index: Integer): TTntStatusPanel; +begin + Result := (inherited GetItem(Index)) as TTntStatusPanel; +end; + +procedure TTntStatusPanels.SetItem(Index: Integer; Value: TTntStatusPanel); +begin + inherited SetItem(Index, Value); +end; + +function TTntStatusPanels.Add: TTntStatusPanel; +begin + Result := (inherited Add) as TTntStatusPanel; +end; + +function TTntStatusPanels.AddItem(Item: TTntStatusPanel; Index: Integer): TTntStatusPanel; +begin + Result := (inherited AddItem(Item, Index)) as TTntStatusPanel; +end; + +function TTntStatusPanels.Insert(Index: Integer): TTntStatusPanel; +begin + Result := (inherited Insert(Index)) as TTntStatusPanel; +end; + +{ TTntCustomStatusBar } + +function TTntCustomStatusBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomStatusBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntCustomStatusBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomStatusBar.CreatePanels: TStatusPanels{TNT-ALLOW TStatusPanels}; +begin + Result := TTntStatusPanels.Create(Self); +end; + +function TTntCustomStatusBar.GetPanelClass: TStatusPanelClass; +begin + Result := TTntStatusPanel; +end; + +function TTntCustomStatusBar.SyncLeadingTabs(const WideVal: WideString; const AnsiVal: AnsiString): WideString; + + function CountLeadingTabs(const Val: WideString): Integer; + var + i: integer; + begin + Result := 0; + for i := 1 to Length(Val) do begin + if Val[i] <> #9 then break; + Inc(Result); + end; + end; + +var + AnsiTabCount: Integer; + WideTabCount: Integer; +begin + AnsiTabCount := CountLeadingTabs(AnsiVal); + WideTabCount := CountLeadingTabs(WideVal); + Result := WideVal; + while WideTabCount < AnsiTabCount do begin + Insert(#9, Result, 1); + Inc(WideTabCount); + end; + while WideTabCount > AnsiTabCount do begin + Delete(Result, 1, 1); + Dec(WideTabCount); + end; +end; + +function TTntCustomStatusBar.GetSimpleText: WideString; +begin + FSimpleText := SyncLeadingTabs(FSimpleText, inherited SimpleText); + Result := GetSyncedWideString(FSimpleText, inherited SimpleText); +end; + +procedure TTntCustomStatusBar.SetInheritedSimpleText(const Value: AnsiString); +begin + inherited SimpleText := Value; +end; + +procedure TTntCustomStatusBar.SetSimpleText(const Value: WideString); +begin + SetSyncedWideString(Value, FSimpleText, inherited SimpleText, SetInheritedSimpleText); +end; + +procedure TTntCustomStatusBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomStatusBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, STATUSCLASSNAME); +end; + +procedure TTntCustomStatusBar.WndProc(var Msg: TMessage); +const + SB_SIMPLEID = Integer($FF); +var + iPart: Integer; + szText: PAnsiChar; + WideText: WideString; +begin + if Win32PlatformIsUnicode and (Msg.Msg = SB_SETTEXTA) and ((Msg.WParam and SBT_OWNERDRAW) = 0) + then begin + // convert SB_SETTEXTA message to Unicode + iPart := (Msg.WParam and SB_SIMPLEID); + szText := PAnsiChar(Msg.LParam); + if iPart = SB_SIMPLEID then + WideText := SimpleText + else if Panels.Count > 0 then + WideText := Panels[iPart].Text + else begin + WideText := szText; + end; + WideText := SyncLeadingTabs(WideText, szText); + Msg.Result := SendMessageW(Handle, SB_SETTEXTW, Msg.wParam, Integer(PWideChar(WideText))); + end else + inherited; +end; + +procedure TTntCustomStatusBar.WMGetTextLength(var Message: TWMGetTextLength); +begin + Message.Result := Length(SimpleText); +end; + +procedure TTntCustomStatusBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomStatusBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntCustomStatusBar.GetPanels: TTntStatusPanels; +begin + Result := inherited Panels as TTntStatusPanels; +end; + +procedure TTntCustomStatusBar.SetPanels(const Value: TTntStatusPanels); +begin + inherited Panels := Value; +end; + +function TTntCustomStatusBar.ExecuteAction(Action: TBasicAction): Boolean; +begin + if AutoHint and (Action is TTntHintAction) and not DoHint then + begin + if SimplePanel or (Panels.Count = 0) then + SimpleText := TTntHintAction(Action).Hint else + Panels[0].Text := TTntHintAction(Action).Hint; + Result := True; + end + else Result := inherited ExecuteAction(Action); +end; + +{ TTntStatusBar } + +function TTntStatusBar.GetOnDrawPanel: TDrawPanelEvent; +begin + Result := TDrawPanelEvent(inherited OnDrawPanel); +end; + +procedure TTntStatusBar.SetOnDrawPanel(const Value: TDrawPanelEvent); +begin + inherited OnDrawPanel := TCustomDrawPanelEvent(Value); +end; + +{ TTntTreeNode } + +function TTntTreeNode.IsEqual(Node: TTntTreeNode): Boolean; +begin + Result := (Text = Node.Text) and (Data = Node.Data); +end; + +procedure TTntTreeNode.ReadData(Stream: TStream; Info: PNodeInfo); +var + I, Size, ItemCount: Integer; + LNode: TTntTreeNode; + Utf8Text: AnsiString; +begin + Owner.ClearCache; + Stream.ReadBuffer(Size, SizeOf(Size)); + Stream.ReadBuffer(Info^, Size); + + if Pos(UTF8_BOM, Info^.Text) = 1 then begin + Utf8Text := Copy(Info^.Text, Length(UTF8_BOM) + 1, MaxInt); + try + Text := UTF8ToWideString(Utf8Text); + except + Text := Utf8Text; + end; + end else + Text := Info^.Text; + + ImageIndex := Info^.ImageIndex; + SelectedIndex := Info^.SelectedIndex; + StateIndex := Info^.StateIndex; + OverlayIndex := Info^.OverlayIndex; + Data := Info^.Data; + ItemCount := Info^.Count; + for I := 0 to ItemCount - 1 do + begin + LNode := Owner.AddChild(Self, ''); + LNode.ReadData(Stream, Info); + Owner.Owner.Added(LNode); + end; +end; + +procedure TTntTreeNode.WriteData(Stream: TStream; Info: PNodeInfo); +var + I, Size, L, ItemCount: Integer; + WideLen: Integer; Utf8Text: AnsiString; +begin + WideLen := 255; + repeat + Utf8Text := UTF8_BOM + WideStringToUTF8(Copy(Text, 1, WideLen)); + L := Length(Utf8Text); + Dec(WideLen); + until + L <= 255; + + Size := SizeOf(TNodeInfo) + L - 255; + Info^.Text := Utf8Text; + Info^.ImageIndex := ImageIndex; + Info^.SelectedIndex := SelectedIndex; + Info^.OverlayIndex := OverlayIndex; + Info^.StateIndex := StateIndex; + Info^.Data := Data; + ItemCount := Count; + Info^.Count := ItemCount; + Stream.WriteBuffer(Size, SizeOf(Size)); + Stream.WriteBuffer(Info^, Size); + for I := 0 to ItemCount - 1 do + Item[I].WriteData(Stream, Info); +end; + +procedure TTntTreeNode.Assign(Source: TPersistent); +var + Node: TTntTreeNode; +begin + inherited; + if (not Deleting) and (Source is TTntTreeNode) then + begin + Node := TTntTreeNode(Source); + Text := Node.Text; + end; +end; + +function TTntTreeNode.GetText: WideString; +begin + Result := GetSyncedWideString(FText, inherited Text); +end; + +procedure TTntTreeNode.SetInheritedText(const Value: AnsiString); +begin + inherited Text := Value; +end; + +procedure TTntTreeNode.SetText(const Value: WideString); +begin + SetSyncedWideString(Value, FText, inherited Text, SetInheritedText); +end; + +function TTntTreeNode.getFirstChild: TTntTreeNode; +begin + Result := inherited getFirstChild as TTntTreeNode; +end; + +function TTntTreeNode.GetItem(Index: Integer): TTntTreeNode; +begin + Result := inherited Item[Index] as TTntTreeNode; +end; + +procedure TTntTreeNode.SetItem(Index: Integer; const Value: TTntTreeNode); +begin + inherited Item[Index] := Value; +end; + +function TTntTreeNode.GetLastChild: TTntTreeNode; +begin + Result := inherited GetLastChild as TTntTreeNode; +end; + +function TTntTreeNode.GetNext: TTntTreeNode; +begin + Result := inherited GetNext as TTntTreeNode; +end; + +function TTntTreeNode.GetNextChild(Value: TTntTreeNode): TTntTreeNode; +begin + Result := inherited GetNextChild(Value) as TTntTreeNode; +end; + +function TTntTreeNode.getNextSibling: TTntTreeNode; +begin + Result := inherited getNextSibling as TTntTreeNode; +end; + +function TTntTreeNode.GetNextVisible: TTntTreeNode; +begin + Result := inherited GetNextVisible as TTntTreeNode; +end; + +function TTntTreeNode.GetNodeOwner: TTntTreeNodes; +begin + Result := inherited Owner as TTntTreeNodes; +end; + +function TTntTreeNode.GetParent: TTntTreeNode; +begin + Result := inherited Parent as TTntTreeNode; +end; + +function TTntTreeNode.GetPrev: TTntTreeNode; +begin + Result := inherited GetPrev as TTntTreeNode; +end; + +function TTntTreeNode.GetPrevChild(Value: TTntTreeNode): TTntTreeNode; +begin + Result := inherited GetPrevChild(Value) as TTntTreeNode; +end; + +function TTntTreeNode.getPrevSibling: TTntTreeNode; +begin + Result := inherited getPrevSibling as TTntTreeNode; +end; + +function TTntTreeNode.GetPrevVisible: TTntTreeNode; +begin + Result := inherited GetPrevVisible as TTntTreeNode; +end; + +function TTntTreeNode.GetTreeView: TTntCustomTreeView; +begin + Result := inherited TreeView as TTntCustomTreeView; +end; + +{ TTntTreeNodesEnumerator } + +constructor TTntTreeNodesEnumerator.Create(ATreeNodes: TTntTreeNodes); +begin + inherited Create; + FIndex := -1; + FTreeNodes := ATreeNodes; +end; + +function TTntTreeNodesEnumerator.GetCurrent: TTntTreeNode; +begin + Result := FTreeNodes[FIndex]; +end; + +function TTntTreeNodesEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FTreeNodes.Count - 1; + if Result then + Inc(FIndex); +end; + +{ TTntTreeNodes } + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackTreeNodes = class(TPersistent) + protected + FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; + FxxxUpdateCount: Integer; + FNodeCache: TNodeCache; + FReading: Boolean; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackTreeNodes = class(TPersistent) + protected + FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; + FxxxUpdateCount: Integer; + FNodeCache: TNodeCache; + FReading: Boolean; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackTreeNodes = class(TPersistent) + protected + FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; + FxxxUpdateCount: Integer; + FNodeCache: TNodeCache; + FReading: Boolean; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackTreeNodes = class(TPersistent) + protected + FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; + FxxxUpdateCount: Integer; + FNodeCache: TNodeCache; + FReading: Boolean; + end; +{$ENDIF} + +procedure SaveNodeTextToStrings(Nodes: TTntTreeNodes; sList: TTntStrings); +var + ANode: TTntTreeNode; +begin + sList.Clear; + if Nodes.Count > 0 then + begin + ANode := Nodes[0]; + while ANode <> nil do + begin + sList.Add(ANode.Text); + ANode := ANode.GetNext; + end; + end; +end; + +procedure TTntTreeNodes.Assign(Source: TPersistent); +var + TreeNodes: TTntTreeNodes; + MemStream: TTntMemoryStream; +begin + ClearCache; + if Source is TTntTreeNodes then + begin + TreeNodes := TTntTreeNodes(Source); + Clear; + MemStream := TTntMemoryStream.Create; + try + TreeNodes.WriteData(MemStream); + MemStream.Position := 0; + ReadData(MemStream); + finally + MemStream.Free; + end; + end else + inherited Assign(Source); +end; + +function TTntTreeNodes.GetNodeFromIndex(Index: Integer): TTntTreeNode; +begin + Result := inherited Item[Index] as TTntTreeNode; +end; + +function TTntTreeNodes.AddChildFirst(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Parent, S, nil, naAddChildFirst); +end; + +function TTntTreeNodes.AddChildObjectFirst(Parent: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Parent, S, Ptr, naAddChildFirst); +end; + +function TTntTreeNodes.AddChild(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Parent, S, nil, naAddChild); +end; + +function TTntTreeNodes.AddChildObject(Parent: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Parent, S, Ptr, naAddChild); +end; + +function TTntTreeNodes.AddFirst(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, nil, naAddFirst); +end; + +function TTntTreeNodes.AddObjectFirst(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, Ptr, naAddFirst); +end; + +function TTntTreeNodes.Add(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, nil, naAdd); +end; + +function TTntTreeNodes.AddObject(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, Ptr, naAdd); +end; + +function TTntTreeNodes.Insert(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, nil, naInsert); +end; + +function TTntTreeNodes.InsertObject(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, Ptr, naInsert); +end; + +function TTntTreeNodes.InsertNode(Node, Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(Node, Sibling, S, Ptr, naInsert); +end; + +function TTntTreeNodes.AddNode(Node, Relative: TTntTreeNode; const S: WideString; + Ptr: Pointer; Method: TNodeAttachMode): TTntTreeNode; +begin + Result := inherited AddNode(Node, Relative, '', Ptr, Method) as TTntTreeNode; + Result.Text := S; +end; + +function TTntTreeNodes.GetNode(ItemId: HTreeItem): TTntTreeNode; +begin + Result := inherited GetNode(ItemID) as TTntTreeNode; +end; + +function TTntTreeNodes.GetFirstNode: TTntTreeNode; +begin + Result := inherited GetFirstNode as TTntTreeNode; +end; + +function TTntTreeNodes.GetEnumerator: TTntTreeNodesEnumerator; +begin + Result := TTntTreeNodesEnumerator.Create(Self); +end; + +function TTntTreeNodes.GetNodesOwner: TTntCustomTreeView; +begin + Result := inherited Owner as TTntCustomTreeView; +end; + +procedure TTntTreeNodes.ClearCache; +begin + THackTreeNodes(Self).FNodeCache.CacheNode := nil; +end; + +procedure TTntTreeNodes.DefineProperties(Filer: TFiler); + + function WriteNodes: Boolean; + var + I: Integer; + Nodes: TTntTreeNodes; + begin + Nodes := TTntTreeNodes(Filer.Ancestor); + if Nodes = nil then + Result := Count > 0 + else if Nodes.Count <> Count then + Result := True + else + begin + Result := False; + for I := 0 to Count - 1 do + begin + Result := not Item[I].IsEqual(Nodes[I]); + if Result then + Break; + end + end; + end; + +begin + inherited DefineProperties(Filer); + Filer.DefineBinaryProperty('Utf8Data', ReadData, WriteData, WriteNodes); +end; + +procedure TTntTreeNodes.ReadData(Stream: TStream); +var + I, Count: Integer; + NodeInfo: TNodeInfo; + LNode: TTntTreeNode; + LHandleAllocated: Boolean; +begin + LHandleAllocated := Owner.HandleAllocated; + if LHandleAllocated then + BeginUpdate; + THackTreeNodes(Self).FReading := True; + try + Clear; + Stream.ReadBuffer(Count, SizeOf(Count)); + for I := 0 to Count - 1 do + begin + LNode := Add(nil, ''); + LNode.ReadData(Stream, @NodeInfo); + Owner.Added(LNode); + end; + finally + THackTreeNodes(Self).FReading := False; + if LHandleAllocated then + EndUpdate; + end; +end; + +procedure TTntTreeNodes.WriteData(Stream: TStream); +var + I: Integer; + Node: TTntTreeNode; + NodeInfo: TNodeInfo; +begin + I := 0; + Node := GetFirstNode; + while Node <> nil do + begin + Inc(I); + Node := Node.GetNextSibling; + end; + Stream.WriteBuffer(I, SizeOf(I)); + Node := GetFirstNode; + while Node <> nil do + begin + Node.WriteData(Stream, @NodeInfo); + Node := Node.GetNextSibling; + end; +end; + +{ TTntTreeStrings } + +type + TTntTreeStrings = class(TTntStringList) + protected + function GetBufStart(Buffer: PWideChar; var Level: Integer): PWideChar; + public + procedure SaveToTree(Tree: TTntCustomTreeView); + procedure LoadFromTree(Tree: TTntCustomTreeView); + end; + +function TTntTreeStrings.GetBufStart(Buffer: PWideChar; var Level: Integer): PWideChar; +begin + Level := 0; + while Buffer^ in [WideChar(' '), WideChar(#9)] do + begin + Inc(Buffer); + Inc(Level); + end; + Result := Buffer; +end; + +procedure TTntTreeStrings.SaveToTree(Tree: TTntCustomTreeView); +var + ANode, NextNode: TTntTreeNode; + ALevel, i: Integer; + CurrStr: WideString; + Owner: TTntTreeNodes; +begin + Owner := Tree.Items; + Owner.BeginUpdate; + try + try + Owner.Clear; + ANode := nil; + for i := 0 to Count - 1 do + begin + CurrStr := GetBufStart(PWideChar(Strings[i]), ALevel); + if ANode = nil then + ANode := Owner.AddChild(nil, CurrStr) + else if ANode.Level = ALevel then + ANode := Owner.AddChild(ANode.Parent, CurrStr) + else if ANode.Level = (ALevel - 1) then + ANode := Owner.AddChild(ANode, CurrStr) + else if ANode.Level > ALevel then + begin + NextNode := ANode.Parent; + while NextNode.Level > ALevel do + NextNode := NextNode.Parent; + ANode := Owner.AddChild(NextNode.Parent, CurrStr); + end + else + raise ETreeViewError.CreateFmt(sInvalidLevelEx, [ALevel, CurrStr]); + end; + finally + Owner.EndUpdate; + end; + except + Owner.Owner.Invalidate; // force repaint on exception + raise; + end; +end; + +procedure TTntTreeStrings.LoadFromTree(Tree: TTntCustomTreeView); +const + TabChar = #9; +var + i: Integer; + ANode: TTntTreeNode; + NodeStr: WideString; + Owner: TTntTreeNodes; +begin + Clear; + Owner := Tree.Items; + if Owner.Count > 0 then + begin + ANode := Owner[0]; + while ANode <> nil do + begin + NodeStr := ''; + for i := 0 to ANode.Level - 1 do NodeStr := NodeStr + TabChar; + NodeStr := NodeStr + ANode.Text; + Add(NodeStr); + ANode := ANode.GetNext; + end; + end; +end; + +{ _TntInternalCustomTreeView } + +function _TntInternalCustomTreeView.FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; +begin + Result := Wide_FindNextToSelect; +end; + +function _TntInternalCustomTreeView.Inherited_FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; +begin + Result := inherited FindNextToSelect; +end; + +{ TTntCustomTreeView } + +function TntDefaultTreeViewSort(Node1, Node2: TTntTreeNode; lParam: Integer): Integer; stdcall; +begin + with Node1 do + if Assigned(TreeView.OnCompare) then + TreeView.OnCompare(TreeView, Node1, Node2, lParam, Result) + else Result := lstrcmpw(PWideChar(Node1.Text), PWideChar(Node2.Text)); +end; + +constructor TTntCustomTreeView.Create(AOwner: TComponent); +begin + inherited; + FEditInstance := Classes.MakeObjectInstance(EditWndProcW); +end; + +destructor TTntCustomTreeView.Destroy; +begin + Destroying; + Classes.FreeObjectInstance(FEditInstance); + FreeAndNil(FSavedNodeText); + inherited; +end; + +var + ComCtrls_DefaultTreeViewSort: TTVCompare = nil; + +procedure TTntCustomTreeView.CreateWindowHandle(const Params: TCreateParams); + + procedure Capture_ComCtrls_DefaultTreeViewSort; + begin + FTestingForSortProc := True; + try + AlphaSort; + finally + FTestingForSortProc := False; + end; + end; + +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_TREEVIEW); + if (Win32PlatformIsUnicode) then begin + if not Assigned(ComCtrls_DefaultTreeViewSort) then + Capture_ComCtrls_DefaultTreeViewSort; + end; +end; + +procedure TTntCustomTreeView.CreateWnd; +begin + inherited; + if FSavedNodeText <> nil then begin + FreeAndNil(FSavedNodeText); + SortType := FSavedSortType; + end; +end; + +procedure TTntCustomTreeView.DestroyWnd; +begin + if (not (csDestroying in ComponentState)) then begin + FSavedNodeText := TTntStringList.Create; + FSavedSortType := SortType; + SortType := stNone; // when recreating window, we are expecting items to come back in same order + SaveNodeTextToStrings(Items, FSavedNodeText); + end; + inherited; +end; + +procedure TTntCustomTreeView.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomTreeView.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomTreeView.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomTreeView.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomTreeView.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomTreeView.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntCustomTreeView.CreateNode: TTreeNode{TNT-ALLOW TTreeNode}; +var + LClass: TClass; + TntLClass: TTntTreeNodeClass; +begin + LClass := TTntTreeNode; + if Assigned(OnCreateNodeClass) then + OnCreateNodeClass(Self, TTreeNodeClass(LClass)); + if not LClass.InheritsFrom(TTntTreeNode) then + raise ETntInternalError.Create('Internal Error: OnCreateNodeClass.ItemClass must inherit from TTntTreeNode.'); + TntLClass := TTntTreeNodeClass(LClass); + Result := TntLClass.Create(inherited Items); +end; + +function TTntCustomTreeView.CreateNodes: TTreeNodes{TNT-ALLOW TTreeNodes}; +begin + Result := TTntTreeNodes.Create(Self); +end; + +function TTntCustomTreeView.GetTreeNodes: TTntTreeNodes; +begin + Result := inherited Items as TTntTreeNodes; +end; + +procedure TTntCustomTreeView.SetTreeNodes(const Value: TTntTreeNodes); +begin + Items.Assign(Value); +end; + +function TTntCustomTreeView.GetNodeFromItem(const Item: TTVItem): TTntTreeNode; +begin + Result := nil; + if Items <> nil then + with Item do + if (state and TVIF_PARAM) <> 0 then + Result := Pointer(lParam) + else + Result := Items.GetNode(hItem); +end; + +function TTntCustomTreeView.Wide_FindNextToSelect: TTntTreeNode; +begin + Result := FindNextToSelect; +end; + +function TTntCustomTreeView.FindNextToSelect: TTntTreeNode; +begin + Result := Inherited_FindNextToSelect as TTntTreeNode; +end; + +function TTntCustomTreeView.GetDropTarget: TTntTreeNode; +begin + Result := inherited DropTarget as TTntTreeNode; +end; + +function TTntCustomTreeView.GetNodeAt(X, Y: Integer): TTntTreeNode; +begin + Result := inherited GetNodeAt(X, Y) as TTntTreeNode; +end; + +function TTntCustomTreeView.GetSelected: TTntTreeNode; +begin + Result := inherited Selected as TTntTreeNode; +end; + +function TTntCustomTreeView.GetSelection(Index: Integer): TTntTreeNode; +begin + Result := inherited Selections[Index] as TTntTreeNode; +end; + +function TTntCustomTreeView.GetSelections(AList: TList): TTntTreeNode; +begin + Result := inherited GetSelections(AList) as TTntTreeNode; +end; + +function TTntCustomTreeView.GetTopItem: TTntTreeNode; +begin + Result := inherited TopItem as TTntTreeNode; +end; + +procedure TTntCustomTreeView.SetDropTarget(const Value: TTntTreeNode); +begin + inherited DropTarget := Value; +end; + +procedure TTntCustomTreeView.SetSelected(const Value: TTntTreeNode); +begin + inherited Selected := Value; +end; + +procedure TTntCustomTreeView.SetTopItem(const Value: TTntTreeNode); +begin + inherited TopItem := Value; +end; + +procedure TTntCustomTreeView.WndProc(var Message: TMessage); +type + PTVSortCB = ^TTVSortCB; +begin + with Message do begin + // capture ANSI version of DefaultTreeViewSort from ComCtrls + if (FTestingForSortProc) + and (Msg = TVM_SORTCHILDRENCB) then begin + ComCtrls_DefaultTreeViewSort := PTVSortCB(lParam).lpfnCompare; + exit; + end; + + if (Win32PlatformIsUnicode) + and (Msg = TVM_SORTCHILDRENCB) + and (@PTVSortCB(lParam).lpfnCompare = @ComCtrls_DefaultTreeViewSort) then + begin + // Unicode:: call wide version of sort proc instead + PTVSortCB(lParam)^.lpfnCompare := TTVCompare(@TntDefaultTreeViewSort); + Result := SendMessageW(Handle, TVM_SORTCHILDRENCB, wParam, lParam); + end else + inherited; + end; +end; + +procedure TTntCustomTreeView.CNNotify(var Message: TWMNotify); +var + Node: TTntTreeNode; +begin + if (not Win32PlatformIsUnicode) then + inherited + else begin + with Message do begin + case NMHdr^.code of + TVN_BEGINDRAGW: + begin + NMHdr^.code := TVN_BEGINDRAGA; + try + inherited; + finally + NMHdr^.code := TVN_BEGINDRAGW; + end; + end; + TVN_BEGINLABELEDITW: + begin + with PTVDispInfo(NMHdr)^ do + if Dragging or not CanEdit(GetNodeFromItem(item)) then + Result := 1; + if Result = 0 then + begin + FEditHandle := TreeView_GetEditControl(Handle); + FDefEditProc := Pointer(GetWindowLongW(FEditHandle, GWL_WNDPROC)); + SetWindowLongW(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance)); + end; + end; + TVN_ENDLABELEDITW: + Edit(PTVDispInfo(NMHdr)^.item); + TVN_ITEMEXPANDINGW: + begin + NMHdr^.code := TVN_ITEMEXPANDINGA; + try + inherited; + finally + NMHdr^.code := TVN_ITEMEXPANDINGW; + end; + end; + TVN_ITEMEXPANDEDW: + begin + NMHdr^.code := TVN_ITEMEXPANDEDA; + try + inherited; + finally + NMHdr^.code := TVN_ITEMEXPANDEDW; + end; + end; + TVN_DELETEITEMW: + begin + NMHdr^.code := TVN_DELETEITEMA; + try + inherited; + finally + NMHdr^.code := TVN_DELETEITEMW; + end; + end; + TVN_SETDISPINFOW: + with PTVDispInfo(NMHdr)^ do + begin + Node := GetNodeFromItem(item); + if (Node <> nil) and ((item.mask and TVIF_TEXT) <> 0) then + Node.Text := TTVItemW(item).pszText; + end; + TVN_GETDISPINFOW: + with PTVDispInfo(NMHdr)^ do + begin + Node := GetNodeFromItem(item); + if Node <> nil then + begin + if (item.mask and TVIF_TEXT) <> 0 then begin + if (FSavedNodeText <> nil) + and (FSavedNodeText.Count > 0) + and (AnsiString(FSavedNodeText[0]) = AnsiString(Node.Text)) then + begin + Node.FText := FSavedNodeText[0]; // recover saved text + FSavedNodeText.Delete(0); + end; + WStrLCopy(TTVItemW(item).pszText, PWideChar(Node.Text), item.cchTextMax - 1); + end; + + if (item.mask and TVIF_IMAGE) <> 0 then + begin + GetImageIndex(Node); + item.iImage := Node.ImageIndex; + end; + if (item.mask and TVIF_SELECTEDIMAGE) <> 0 then + begin + GetSelectedIndex(Node); + item.iSelectedImage := Node.SelectedIndex; + end; + end; + end; + else + inherited; + end; + end; + end; +end; + +procedure TTntCustomTreeView.WMNotify(var Message: TWMNotify); +var + Node: TTntTreeNode; + FWideText: WideString; + MaxTextLen: Integer; + Pt: TPoint; +begin + with Message do + if NMHdr^.code = TTN_NEEDTEXTW then + begin + // Work around NT COMCTL32 problem with tool tips >= 80 characters + GetCursorPos(Pt); + Pt := ScreenToClient(Pt); + Node := GetNodeAt(Pt.X, Pt.Y); + if (Node = nil) or (Node.Text = '') or + (PToolTipTextW(NMHdr)^.uFlags and TTF_IDISHWND = 0) then Exit; + if (GetComCtlVersion >= ComCtlVersionIE4) + or {Borland's VCL wrongly uses "and"} (Length(Node.Text) < 80) then + begin + DefaultHandler(Message); + Exit; + end; + FWideText := Node.Text; + MaxTextLen := SizeOf(PToolTipTextW(NMHdr)^.szText) div SizeOf(WideChar); + if Length(FWideText) >= MaxTextLen then + SetLength(FWideText, MaxTextLen - 1); + PToolTipTextW(NMHdr)^.lpszText := PWideChar(FWideText); + FillChar(PToolTipTextW(NMHdr)^.szText, MaxTextLen, 0); + Move(Pointer(FWideText)^, PToolTipTextW(NMHdr)^.szText, Length(FWideText) * SizeOf(WideChar)); + PToolTipTextW(NMHdr)^.hInst := 0; + SetWindowPos(NMHdr^.hwndFrom, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE or + SWP_NOSIZE or SWP_NOMOVE or SWP_NOOWNERZORDER); + Result := 1; + end + else inherited; +end; + +procedure TTntCustomTreeView.Edit(const Item: TTVItem); +var + S: WideString; + AnsiS: AnsiString; + Node: TTntTreeNode; + AnsiEvent: TTVEditedEvent; +begin + with Item do + begin + Node := GetNodeFromItem(Item); + if pszText <> nil then + begin + if Win32PlatformIsUnicode then + S := TTVItemW(Item).pszText + else + S := pszText; + + if Assigned(FOnEdited) then + FOnEdited(Self, Node, S) + else if Assigned(inherited OnEdited) then + begin + AnsiEvent := inherited OnEdited; + AnsiS := S; + AnsiEvent(Self, Node, AnsiS); + S := AnsiS; + end; + + if Node <> nil then Node.Text := S; + end + else if Assigned(OnCancelEdit) then + OnCancelEdit(Self, Node); + end; +end; + +procedure TTntCustomTreeView.EditWndProcW(var Message: TMessage); +begin + Assert(Win32PlatformIsUnicode); + try + with Message do + begin + case Msg of + WM_KEYDOWN, + WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit; + WM_CHAR: + begin + MakeWMCharMsgSafeForAnsi(Message); + try + if DoKeyPress(TWMKey(Message)) then Exit; + finally + RestoreWMCharMsg(Message); + end; + end; + WM_KEYUP, + WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit; + CN_KEYDOWN, + CN_CHAR, CN_SYSKEYDOWN, + CN_SYSCHAR: + begin + WndProc(Message); + Exit; + end; + end; + Result := CallWindowProcW(FDefEditProc, FEditHandle, Msg, WParam, LParam); + end; + except + Application.HandleException(Self); + end; +end; + +procedure TTntCustomTreeView.LoadFromFile(const FileName: WideString); +var + TreeStrings: TTntTreeStrings; +begin + TreeStrings := TTntTreeStrings.Create; + try + TreeStrings.LoadFromFile(FileName); + TreeStrings.SaveToTree(Self); + finally + TreeStrings.Free; + end; +end; + +procedure TTntCustomTreeView.LoadFromStream(Stream: TStream); +var + TreeStrings: TTntTreeStrings; +begin + TreeStrings := TTntTreeStrings.Create; + try + TreeStrings.LoadFromStream(Stream); + TreeStrings.SaveToTree(Self); + finally + TreeStrings.Free; + end; +end; + +procedure TTntCustomTreeView.SaveToFile(const FileName: WideString); +var + TreeStrings: TTntTreeStrings; +begin + TreeStrings := TTntTreeStrings.Create; + try + TreeStrings.LoadFromTree(Self); + TreeStrings.SaveToFile(FileName); + finally + TreeStrings.Free; + end; +end; + +procedure TTntCustomTreeView.SaveToStream(Stream: TStream); +var + TreeStrings: TTntTreeStrings; +begin + TreeStrings := TTntTreeStrings.Create; + try + TreeStrings.LoadFromTree(Self); + TreeStrings.SaveToStream(Stream); + finally + TreeStrings.Free; + end; +end; + +initialization + +finalization + if Assigned(AIMM) then + AIMM.Deactivate; + if FRichEdit20Module <> 0 then + FreeLibrary(FRichEdit20Module); + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc new file mode 100644 index 0000000000..5ab13901ba --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc @@ -0,0 +1,356 @@ +//---------------------------------------------------------------------------------------------------------------------- +// Include file to determine which compiler is currently being used to build the project/component. +// This file uses ideas from Brad Stowers DFS.inc file (www.delphifreestuff.com). +// +// Portions created by Mike Lischke are Copyright +// (C) 1999-2002 Dipl. Ing. Mike Lischke. All Rights Reserved. +//---------------------------------------------------------------------------------------------------------------------- +// The following symbols are defined: +// +// COMPILER_1 : Kylix/Delphi/BCB 1.x is the compiler. +// COMPILER_1_UP : Kylix/Delphi/BCB 1.x or higher is the compiler. +// COMPILER_2 : Kylix/Delphi 2.x or BCB 1.x is the compiler. +// COMPILER_2_UP : Kylix/Delphi 2.x or higher, or BCB 1.x or higher is the compiler. +// COMPILER_3 : Kylix/Delphi/BCB 3.x is the compiler. +// COMPILER_3_UP : Kylix/Delphi/BCB 3.x or higher is the compiler. +// COMPILER_4 : Kylix/Delphi/BCB 4.x is the compiler. +// COMPILER_4_UP : Kylix/Delphi/BCB 4.x or higher is the compiler. +// COMPILER_5 : Kylix/Delphi/BCB 5.x is the compiler. +// COMPILER_5_UP : Kylix/Delphi/BCB 5.x or higher is the compiler. +// COMPILER_6 : Kylix/Delphi/BCB 6.x is the compiler. +// COMPILER_6_UP : Kylix/Delphi/BCB 6.x or higher is the compiler. +// COMPILER_7 : Kylix/Delphi/BCB 7.x is the compiler. +// COMPILER_7_UP : Kylix/Delphi/BCB 7.x or higher is the compiler. +// +// Only defined if Windows is the target: +// CPPB : Any version of BCB is being used. +// CPPB_1 : BCB v1.x is being used. +// CPPB_3 : BCB v3.x is being used. +// CPPB_3_UP : BCB v3.x or higher is being used. +// CPPB_4 : BCB v4.x is being used. +// CPPB_4_UP : BCB v4.x or higher is being used. +// CPPB_5 : BCB v5.x is being used. +// CPPB_5_UP : BCB v5.x or higher is being used. +// CPPB_6 : BCB v6.x is being used. +// CPPB_6_UP : BCB v6.x or higher is being used. +// +// Only defined if Windows is the target: +// DELPHI : Any version of Delphi is being used. +// DELPHI_1 : Delphi v1.x is being used. +// DELPHI_2 : Delphi v2.x is being used. +// DELPHI_2_UP : Delphi v2.x or higher is being used. +// DELPHI_3 : Delphi v3.x is being used. +// DELPHI_3_UP : Delphi v3.x or higher is being used. +// DELPHI_4 : Delphi v4.x is being used. +// DELPHI_4_UP : Delphi v4.x or higher is being used. +// DELPHI_5 : Delphi v5.x is being used. +// DELPHI_5_UP : Delphi v5.x or higher is being used. +// DELPHI_6 : Delphi v6.x is being used. +// DELPHI_6_UP : Delphi v6.x or higher is being used. +// DELPHI_7 : Delphi v7.x is being used. +// DELPHI_7_UP : Delphi v7.x or higher is being used. +// +// Only defined if Linux is the target: +// KYLIX : Any version of Kylix is being used. +// KYLIX_1 : Kylix 1.x is being used. +// KYLIX_1_UP : Kylix 1.x or higher is being used. +// KYLIX_2 : Kylix 2.x is being used. +// KYLIX_2_UP : Kylix 2.x or higher is being used. +// KYLIX_3 : Kylix 3.x is being used. +// KYLIX_3_UP : Kylix 3.x or higher is being used. +// +// Only defined if Linux is the target: +// QT_CLX : Trolltech's QT library is being used. +//---------------------------------------------------------------------------------------------------------------------- + +{$ifdef Win32} + + {$ifdef VER180} + {$define COMPILER_10} + {$define DELPHI} + {$define DELPHI_10} + {$endif} + + {$ifdef VER170} + {$define COMPILER_9} + {$define DELPHI} + {$define DELPHI_9} + {$endif} + + {$ifdef VER150} + {$define COMPILER_7} + {$define DELPHI} + {$define DELPHI_7} + {$endif} + + {$ifdef VER140} + {$define COMPILER_6} + {$ifdef BCB} + {$define CPPB} + {$define CPPB_6} + {$else} + {$define DELPHI} + {$define DELPHI_6} + {$endif} + {$endif} + + {$ifdef VER130} + {$define COMPILER_5} + {$ifdef BCB} + {$define CPPB} + {$define CPPB_5} + {$else} + {$define DELPHI} + {$define DELPHI_5} + {$endif} + {$endif} + + {$ifdef VER125} + {$define COMPILER_4} + {$define CPPB} + {$define CPPB_4} + {$endif} + + {$ifdef VER120} + {$define COMPILER_4} + {$define DELPHI} + {$define DELPHI_4} + {$endif} + + {$ifdef VER110} + {$define COMPILER_3} + {$define CPPB} + {$define CPPB_3} + {$endif} + + {$ifdef VER100} + {$define COMPILER_3} + {$define DELPHI} + {$define DELPHI_3} + {$endif} + + {$ifdef VER93} + {$define COMPILER_2} // C++ Builder v1 compiler is really v2 + {$define CPPB} + {$define CPPB_1} + {$endif} + + {$ifdef VER90} + {$define COMPILER_2} + {$define DELPHI} + {$define DELPHI_2} + {$endif} + + {$ifdef VER80} + {$define COMPILER_1} + {$define DELPHI} + {$define DELPHI_1} + {$endif} + + {$ifdef DELPHI_2} + {$define DELPHI_2_UP} + {$endif} + + {$ifdef DELPHI_3} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$endif} + + {$ifdef DELPHI_4} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$endif} + + {$ifdef DELPHI_5} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$endif} + + {$ifdef DELPHI_6} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$endif} + + {$ifdef DELPHI_7} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$endif} + + {$ifdef DELPHI_9} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_9_UP} + {$endif} + + {$ifdef DELPHI_10} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_9_UP} + {$define DELPHI_10_UP} + {$endif} + + {$ifdef CPPB_3} + {$define CPPB_3_UP} + {$endif} + + {$ifdef CPPB_4} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$endif} + + {$ifdef CPPB_5} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$define CPPB_5_UP} + {$endif} + + {$ifdef CPPB_6} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$define CPPB_5_UP} + {$define CPPB_6_UP} + {$endif} + + {$ifdef CPPB_3_UP} + // C++ Builder requires this if you use Delphi components in run-time packages. + {$ObjExportAll On} + {$endif} + +{$else (not Windows)} + // Linux is the target + {$define QT_CLX} + + {$define KYLIX} + {$define KYLIX_1} + {$define KYLIX_1_UP} + + {$ifdef VER150} + {$define COMPILER_7} + {$define KYLIX_3} + {$endif} + + {$ifdef VER140} + {$define COMPILER_6} + {$define KYLIX_2} + {$endif} + + {$ifdef KYLIX_2} + {$define KYLIX_2_UP} + {$endif} + + {$ifdef KYLIX_3} + {$define KYLIX_2_UP} + {$define KYLIX_3_UP} + {$endif} + +{$endif} + +// Compiler defines common to all platforms. +{$ifdef COMPILER_1} + {$define COMPILER_1_UP} +{$endif} + +{$ifdef COMPILER_2} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} +{$endif} + +{$ifdef COMPILER_3} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} +{$endif} + +{$ifdef COMPILER_4} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} +{$endif} + +{$ifdef COMPILER_5} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} +{$endif} + +{$ifdef COMPILER_6} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} +{$endif} + +{$ifdef COMPILER_7} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} +{$endif} + +{$ifdef COMPILER_9} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} + {$define COMPILER_9_UP} +{$endif} + +{$ifdef COMPILER_10} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} + {$define COMPILER_9_UP} + {$define COMPILER_10_UP} +{$endif} + +//---------------------------------------------------------------------------------------------------------------------- + +{$ALIGN ON} +{$BOOLEVAL OFF} + +{$ifdef COMPILER_7_UP} + {$define THEME_7_UP} { Allows experimental theme support on pre-Delphi 7. } +{$endif} + +{$IFDEF COMPILER_6_UP} +{$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! } +{$ENDIF} + +{$IFDEF COMPILER_7_UP} +{$WARN UNSAFE_CODE OFF} { We are not going to be "safe"! } +{$WARN UNSAFE_TYPE OFF} +{$WARN UNSAFE_CAST OFF} +{$ENDIF} \ No newline at end of file diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas new file mode 100644 index 0000000000..55025ecdc2 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas @@ -0,0 +1,1099 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntControls; + +{$INCLUDE TntCompilers.inc} + +{ + Windows NT provides support for native Unicode windows. To add Unicode support to a + TWinControl descendant, override CreateWindowHandle() and call CreateUnicodeHandle(). + + One major reason this works is because the VCL only uses the ANSI version of + SendMessage() -- SendMessageA(). If you call SendMessageA() on a UNICODE + window, Windows deals with the ANSI/UNICODE conversion automatically. So + for example, if the VCL sends WM_SETTEXT to a window using SendMessageA, + Windows actually *expects* a PAnsiChar even if the target window is a UNICODE + window. So caling SendMessageA with PChars causes no problems. + + A problem in the VCL has to do with the TControl.Perform() method. Perform() + calls the window procedure directly and assumes an ANSI window. This is a + problem if, for example, the VCL calls Perform(WM_SETTEXT, ...) passing in a + PAnsiChar which eventually gets passed downto DefWindowProcW() which expects a PWideChar. + + This is the reason for SubClassUnicodeControl(). This procedure will subclass the + Windows WndProc, and the TWinControl.WindowProc pointer. It will determine if the + message came from Windows or if the WindowProc was called directly. It will then + call SendMessageA() for Windows to perform proper conversion on certain text messages. + + Another problem has to do with TWinControl.DoKeyPress(). It is called from the WM_CHAR + message. It casts the WideChar to an AnsiChar, and sends the resulting character to + DefWindowProc. In order to avoid this, the DefWindowProc is subclassed as well. WindowProc + will make a WM_CHAR message safe for ANSI handling code by converting the char code to + #FF before passing it on. It stores the original WideChar in the .Unused field of TWMChar. + The code #FF is converted back to the WideChar before passing onto DefWindowProc. +} + +{ + Things to consider when designing new controls: + 1) Check that a WideString Hint property is published. + 2) If descending from TWinControl, override CreateWindowHandle(). + 3) If not descending from TWinControl, handle CM_HINTSHOW message. + 4) Check to make sure that CN_CHAR, CN_SYSCHAR and CM_DIALOGCHAR are handled properly. + 5) If descending from TWinControl, verify Unicode chars are preserved after RecreateWnd. + 6) Consider using storage specifiers for Hint and Caption properties. + 7) If any class could possibly have published WideString properties, + override DefineProperties and call TntPersistent_AfterInherited_DefineProperties. + 8) Check if TTntThemeManager needs to be updated. + 9) Override GetActionLinkClass() and ActionChange(). + 10) If class updates Application.Hint then update TntApplication.Hint instead. +} + +interface + +{ TODO: Unicode enable .OnKeyPress event } + +uses + Classes, Windows, Messages, Controls, Menus; + + +{TNT-WARN TCaption} +type TWideCaption = type WideString; + +// caption/text management +function TntControl_IsCaptionStored(Control: TControl): Boolean; +function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString; +procedure TntControl_SetStoredText(Control: TControl; const Value: WideString); +function TntControl_GetText(Control: TControl): WideString; +procedure TntControl_SetText(Control: TControl; const Text: WideString); + +// hint management +function TntControl_IsHintStored(Control: TControl): Boolean; +function TntControl_GetHint(Control: TControl): WideString; +procedure TntControl_SetHint(Control: TControl; const Value: WideString); + +function WideGetHint(Control: TControl): WideString; +function WideGetShortHint(const Hint: WideString): WideString; +function WideGetLongHint(const Hint: WideString): WideString; +procedure ProcessCMHintShowMsg(var Message: TMessage); + +type + TTntCustomHintWindow = class(THintWindow) + private + FActivating: Boolean; + FBlockPaint: Boolean; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; +{$IFNDEF COMPILER_7_UP} + procedure CreateParams(var Params: TCreateParams); override; +{$ENDIF} + procedure Paint; override; + public + procedure ActivateHint(Rect: TRect; const AHint: AnsiString); override; + procedure ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); override; + function CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; override; + property Caption: TWideCaption read GetCaption write SetCaption; + end; + + TTntHintWindow = class(TTntCustomHintWindow) + public + procedure ActivateHint(Rect: TRect; const AHint: WideString); reintroduce; + procedure ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); reintroduce; + function CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; reintroduce; + end; + +// text/char message +function IsTextMessage(Msg: UINT): Boolean; +procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage); +procedure RestoreWMCharMsg(var Message: TMessage); +function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar; +procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar); + +// register/create window +procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False); +procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False); +procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams; + const SubClass: WideString; IDEWindow: Boolean = False); +procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False); + +type + IWideCustomListControl = interface + ['{C1801F41-51E9-4DB5-8DB8-58AC86698C2E}'] + procedure AddItem(const Item: WideString; AObject: TObject); + end; + +procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject); + +var + _IsShellProgramming: Boolean = False; + +var + TNT_WM_DESTROY: Cardinal; + +implementation + +uses + ActnList, Forms, SysUtils, Contnrs, + TntGraphics, TntWindows, TntClasses, TntMenus, TntSysUtils; + +type + TAccessControl = class(TControl); + TAccessWinControl = class(TWinControl); + TAccessControlActionLink = class(TControlActionLink{TNT-ALLOW TControlActionLink}); + +//----------------------------------------------- WIDE CAPTION HOLDERS -------- + +{ TWideControlHelper } + +var + WideControlHelpers: TComponentList = nil; + +type + TWideControlHelper = class(TWideComponentHelper) + private + FControl: TControl; + FWideCaption: WideString; + FWideHint: WideString; + procedure SetAnsiText(const Value: AnsiString); + procedure SetAnsiHint(const Value: AnsiString); + public + constructor Create(AOwner: TControl); reintroduce; + property WideCaption: WideString read FWideCaption; + property WideHint: WideString read FWideHint; + end; + +constructor TWideControlHelper.Create(AOwner: TControl); +begin + inherited CreateHelper(AOwner, WideControlHelpers); + FControl := AOwner; +end; + +procedure TWideControlHelper.SetAnsiText(const Value: AnsiString); +begin + TAccessControl(FControl).Text := Value; +end; + +procedure TWideControlHelper.SetAnsiHint(const Value: AnsiString); +begin + FControl.Hint := Value; +end; + +function FindWideControlHelper(Control: TControl; CreateIfNotFound: Boolean = True): TWideControlHelper; +begin + Result := TWideControlHelper(FindWideComponentHelper(WideControlHelpers, Control)); + if (Result = nil) and CreateIfNotFound then + Result := TWideControlHelper.Create(Control); +end; + +//----------------------------------------------- GET/SET WINDOW CAPTION/HINT ------------- + +function TntControl_IsCaptionStored(Control: TControl): Boolean; +begin + with TAccessControl(Control) do + Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsCaptionLinked; +end; + +function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString; +var + WideControlHelper: TWideControlHelper; +begin + WideControlHelper := FindWideControlHelper(Control, False); + if WideControlHelper <> nil then + Result := WideControlHelper.WideCaption + else + Result := Default; +end; + +procedure TntControl_SetStoredText(Control: TControl; const Value: WideString); +begin + FindWideControlHelper(Control).FWideCaption := Value; + TAccessControl(Control).Text := Value; +end; + +function TntControl_GetText(Control: TControl): WideString; +var + WideControlHelper: TWideControlHelper; +begin + if (not Win32PlatformIsUnicode) + or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then + // Win9x / non-unicode handle + Result := TAccessControl(Control).Text + else if (not (Control is TWinControl)) then begin + // non-windowed TControl + WideControlHelper := FindWideControlHelper(Control, False); + if WideControlHelper = nil then + Result := TAccessControl(Control).Text + else + Result := GetSyncedWideString(WideControlHelper.FWideCaption, TAccessControl(Control).Text); + end else if (not TWinControl(Control).HandleAllocated) then begin + // NO HANDLE + Result := TntControl_GetStoredText(Control, TAccessControl(Control).Text) + end else begin + // UNICODE & HANDLE + SetLength(Result, GetWindowTextLengthW(TWinControl(Control).Handle) + 1); + GetWindowTextW(TWinControl(Control).Handle, PWideChar(Result), Length(Result)); + SetLength(Result, Length(Result) - 1); + end; +end; + +procedure TntControl_SetText(Control: TControl; const Text: WideString); +begin + if (not Win32PlatformIsUnicode) + or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then + // Win9x / non-unicode handle + TAccessControl(Control).Text := Text + else if (not (Control is TWinControl)) then begin + // non-windowed TControl + with FindWideControlHelper(Control) do + SetSyncedWideString(Text, FWideCaption, TAccessControl(Control).Text, SetAnsiText) + end else if (not TWinControl(Control).HandleAllocated) then begin + // NO HANDLE + TntControl_SetStoredText(Control, Text); + end else if TntControl_GetText(Control) <> Text then begin + // UNICODE & HANDLE + Tnt_SetWindowTextW(TWinControl(Control).Handle, PWideChar(Text)); + Control.Perform(CM_TEXTCHANGED, 0, 0); + end; +end; + +// hint management ----------------------------------------------------------------------- + +function TntControl_IsHintStored(Control: TControl): Boolean; +begin + with TAccessControl(Control) do + Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsHintLinked; +end; + +function TntControl_GetHint(Control: TControl): WideString; +var + WideControlHelper: TWideControlHelper; +begin + if (not Win32PlatformIsUnicode) then + Result := Control.Hint + else begin + WideControlHelper := FindWideControlHelper(Control, False); + if WideControlHelper <> nil then + Result := GetSyncedWideString(WideControlHelper.FWideHint, Control.Hint) + else + Result := Control.Hint; + end; +end; + +procedure TntControl_SetHint(Control: TControl; const Value: WideString); +begin + if (not Win32PlatformIsUnicode) then + Control.Hint := Value + else + with FindWideControlHelper(Control) do + SetSyncedWideString(Value, FWideHint, Control.Hint, SetAnsiHint); +end; + +function WideGetHint(Control: TControl): WideString; +begin + while Control <> nil do + if TntControl_GetHint(Control) = '' then + Control := Control.Parent + else + begin + Result := TntControl_GetHint(Control); + Exit; + end; + Result := ''; +end; + +function WideGetShortHint(const Hint: WideString): WideString; +var + I: Integer; +begin + I := Pos('|', Hint); + if I = 0 then + Result := Hint else + Result := Copy(Hint, 1, I - 1); +end; + +function WideGetLongHint(const Hint: WideString): WideString; +var + I: Integer; +begin + I := Pos('|', Hint); + if I = 0 then + Result := Hint else + Result := Copy(Hint, I + 1, Maxint); +end; + +//---------------------------------------------------------------------------------------- + +var UnicodeCreationControl: TWinControl = nil; + +function IsUnicodeCreationControl(Handle: HWND): Boolean; +begin + Result := (UnicodeCreationControl <> nil) + and (UnicodeCreationControl.HandleAllocated) + and (UnicodeCreationControl.Handle = Handle); +end; + +function WMNotifyFormatResult(FromHandle: HWND): Integer; +begin + if Win32PlatformIsUnicode + and (IsWindowUnicode(FromHandle) or IsUnicodeCreationControl(FromHandle)) then + Result := NFR_UNICODE + else + Result := NFR_ANSI; +end; + +function IsTextMessage(Msg: UINT): Boolean; +begin + // WM_CHAR is omitted because of the special handling it receives + Result := (Msg = WM_SETTEXT) + or (Msg = WM_GETTEXT) + or (Msg = WM_GETTEXTLENGTH); +end; + +const + ANSI_UNICODE_HOLDER = $FF; + +procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage); +begin + with TWMChar(Message) do begin + Assert(Msg = WM_CHAR); + if not _IsShellProgramming then + Assert(Unused = 0) + else begin + Assert((Unused = 0) or (CharCode <= Word(High(AnsiChar)))); + // When a Unicode control is embedded under non-Delphi Unicode + // window something strange happens + if (Unused <> 0) then begin + CharCode := (Unused shl 8) or CharCode; + end; + end; + if (CharCode > Word(High(AnsiChar))) then begin + Unused := CharCode; + CharCode := ANSI_UNICODE_HOLDER; + end; + end; +end; + +procedure RestoreWMCharMsg(var Message: TMessage); +begin + with TWMChar(Message) do begin + Assert(Message.Msg = WM_CHAR); + if (Unused > 0) + and (CharCode = ANSI_UNICODE_HOLDER) then + CharCode := Unused; + Unused := 0; + end; +end; + +function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar; +begin + if (Message.CharCode = ANSI_UNICODE_HOLDER) + and (Message.Unused <> 0) then + Result := WideChar(Message.Unused) + else + Result := WideChar(Message.CharCode); +end; + +procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar); +begin + Message.CharCode := Word(Ch); + Message.Unused := 0; + MakeWMCharMsgSafeForAnsi(TMessage(Message)); +end; + +//----------------------------------------------------------------------------------- +type + TWinControlTrap = class(TComponent) + private + WinControl_ObjectInstance: Pointer; + ObjectInstance: Pointer; + DefObjectInstance: Pointer; + function IsInSubclassChain(Control: TWinControl): Boolean; + procedure SubClassWindowProc; + private + FControl: TAccessWinControl; + Handle: THandle; + PrevWin32Proc: Pointer; + PrevDefWin32Proc: Pointer; + PrevWindowProc: TWndMethod; + private + LastWin32Msg: UINT; + Win32ProcLevel: Integer; + IDEWindow: Boolean; + DestroyTrap: Boolean; + TestForNull: Boolean; + FoundNull: Boolean; + {$IFDEF TNT_VERIFY_WINDOWPROC} + LastVerifiedWindowProc: TWndMethod; + {$ENDIF} + procedure Win32Proc(var Message: TMessage); + procedure DefWin32Proc(var Message: TMessage); + procedure WindowProc(var Message: TMessage); + private + procedure SubClassControl(Params_Caption: PAnsiChar); + procedure UnSubClassUnicodeControl; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + +constructor TWinControlTrap.Create(AOwner: TComponent); +begin + FControl := TAccessWinControl(AOwner as TWinControl); + inherited Create(nil); + FControl.FreeNotification(Self); + + WinControl_ObjectInstance := Classes.MakeObjectInstance(FControl.MainWndProc); + ObjectInstance := Classes.MakeObjectInstance(Win32Proc); + DefObjectInstance := Classes.MakeObjectInstance(DefWin32Proc); +end; + +destructor TWinControlTrap.Destroy; +begin + Classes.FreeObjectInstance(ObjectInstance); + Classes.FreeObjectInstance(DefObjectInstance); + Classes.FreeObjectInstance(WinControl_ObjectInstance); + inherited; +end; + +procedure TWinControlTrap.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (AComponent = FControl) and (Operation = opRemove) then begin + FControl := nil; + if Win32ProcLevel = 0 then + Free + else + DestroyTrap := True; + end; +end; + +procedure TWinControlTrap.SubClassWindowProc; +begin + if not IsInSubclassChain(FControl) then begin + PrevWindowProc := FControl.WindowProc; + FControl.WindowProc := Self.WindowProc; + end; + {$IFDEF TNT_VERIFY_WINDOWPROC} + LastVerifiedWindowProc := FControl.WindowProc; + {$ENDIF} +end; + +procedure TWinControlTrap.SubClassControl(Params_Caption: PAnsiChar); +begin + // initialize trap object + Handle := FControl.Handle; + PrevWin32Proc := Pointer(GetWindowLongW(FControl.Handle, GWL_WNDPROC)); + PrevDefWin32Proc := FControl.DefWndProc; + + // subclass Window Procedures + SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(ObjectInstance)); + FControl.DefWndProc := DefObjectInstance; + SubClassWindowProc; + + // For some reason, caption gets garbled after calling SetWindowLongW(.., GWL_WNDPROC). + TntControl_SetText(FControl, TntControl_GetStoredText(FControl, Params_Caption)); +end; + +function SameWndMethod(A, B: TWndMethod): Boolean; +begin + Result := @A = @B; +end; + +var + PendingRecreateWndTrapList: TComponentList = nil; + +procedure TWinControlTrap.UnSubClassUnicodeControl; +begin + // remember caption for future window creation + if not (csDestroying in FControl.ComponentState) then + TntControl_SetStoredText(FControl, TntControl_GetText(FControl)); + + // restore window procs (restore WindowProc only if we are still the direct subclass) + if SameWndMethod(FControl.WindowProc, Self.WindowProc) then + FControl.WindowProc := PrevWindowProc; + TAccessWinControl(FControl).DefWndProc := PrevDefWin32Proc; + SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(PrevWin32Proc)); + + if IDEWindow then + DestroyTrap := True + else if not (csDestroying in FControl.ComponentState) then + // control not being destroyed, probably recreating window + PendingRecreateWndTrapList.Add(Self); +end; + +var + Finalized: Boolean; { If any tnt controls are still around after finalization it must be due to a memory leak. + Windows will still try to send a WM_DESTROY, but we will just ignore it if we're finalized. } + +procedure TWinControlTrap.Win32Proc(var Message: TMessage); +begin + if (not Finalized) then begin + Inc(Win32ProcLevel); + try + with Message do begin + {$IFDEF TNT_VERIFY_WINDOWPROC} + if not SameWndMethod(FControl.WindowProc, LastVerifiedWindowProc) then begin + SubClassWindowProc; + LastVerifiedWindowProc := FControl.WindowProc; + end; + {$ENDIF} + LastWin32Msg := Msg; + Result := CallWindowProcW(PrevWin32Proc, Handle, Msg, wParam, lParam); + end; + finally + Dec(Win32ProcLevel); + end; + if (Win32ProcLevel = 0) and (DestroyTrap) then + Free; + end else if (Message.Msg = WM_DESTROY) or (Message.Msg = TNT_WM_DESTROY) then + FControl.WindowHandle := 0 +end; + +procedure TWinControlTrap.DefWin32Proc(var Message: TMessage); + + function IsChildEdit(AHandle: HWND): Boolean; + var + AHandleClass: WideString; + begin + Result := False; + if (FControl.Handle = GetParent(Handle)) then begin + // child control + SetLength(AHandleClass, 255); + SetLength(AHandleClass, GetClassNameW(AHandle, PWideChar(AHandleClass), Length(AHandleClass))); + Result := WideSameText(AHandleClass, 'EDIT'); + end; + end; + +begin + with Message do begin + if Msg = WM_NOTIFYFORMAT then + Result := WMNotifyFormatResult(HWND(Message.wParam)) + else begin + if (Msg = WM_CHAR) then begin + RestoreWMCharMsg(Message) + end; + if (Msg = WM_IME_CHAR) and (not _IsShellProgramming) and (not Win32PlatformIsXP) then + begin + { In Windows XP, DefWindowProc handles WM_IME_CHAR fine for VCL windows. } + { Before XP, DefWindowProc will sometimes produce incorrect, non-Unicode WM_CHAR. } + { Also, using PostMessageW on Windows 2000 didn't always produce the correct results. } + Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam) + end else if (Msg = WM_IME_CHAR) and (_IsShellProgramming) then begin + { When a Tnt control is hosted by a non-delphi control, DefWindowProc doesn't always work even on XP. } + if IsChildEdit(Handle) then + Message.Result := Integer(PostMessageW(Handle, WM_CHAR, wParam, lParam)) // native edit child control + else + Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam); + end else begin + if (Msg = WM_DESTROY) then begin + UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. } + end; + { Normal DefWindowProc } + Result := CallWindowProcW(PrevDefWin32Proc, Handle, Msg, wParam, lParam); + end; + end; + end; +end; + +procedure ProcessCMHintShowMsg(var Message: TMessage); +begin + if Win32PlatformIsUnicode then begin + with TCMHintShow(Message) do begin + if (HintInfo.HintWindowClass = THintWindow) + or (HintInfo.HintWindowClass.InheritsFrom(TTntCustomHintWindow)) then begin + if (HintInfo.HintWindowClass = THintWindow) then + HintInfo.HintWindowClass := TTntCustomHintWindow; + HintInfo.HintData := HintInfo; + HintInfo.HintStr := WideGetShortHint(WideGetHint(HintInfo.HintControl)); + end; + end; + end; +end; + +function TWinControlTrap.IsInSubclassChain(Control: TWinControl): Boolean; +var + Message: TMessage; +begin + if SameWndMethod(Control.WindowProc, TAccessWinControl(Control).WndProc) then + Result := False { no subclassing } + else if SameWndMethod(Control.WindowProc, Self.WindowProc) then + Result := True { directly subclassed } + else begin + TestForNull := True; + FoundNull := False; + ZeroMemory(@Message, SizeOf(Message)); + Message.Msg := WM_NULL; + Control.WindowProc(Message); + Result := FoundNull; { indirectly subclassed } + end; +end; + +procedure TWinControlTrap.WindowProc(var Message: TMessage); +var + CameFromWindows: Boolean; +begin + if TestForNull and (Message.Msg = WM_NULL) then + FoundNull := True; + + if (not FControl.HandleAllocated) then + FControl.WndProc(Message) + else begin + CameFromWindows := LastWin32Msg <> WM_NULL; + LastWin32Msg := WM_NULL; + with Message do begin + if Msg = CM_HINTSHOW then + ProcessCMHintShowMsg(Message); + if (not CameFromWindows) + and (IsTextMessage(Msg)) then + Result := SendMessageA(Handle, Msg, wParam, lParam) + else begin + if (Msg = WM_CHAR) then begin + MakeWMCharMsgSafeForAnsi(Message); + end; + PrevWindowProc(Message) + end; + if (Msg = TNT_WM_DESTROY) then + UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. } + end; + end; +end; + +//---------------------------------------------------------------------------------- + +function FindOrCreateWinControlTrap(Control: TWinControl): TWinControlTrap; +var + i: integer; +begin + // find or create trap object + Result := nil; + for i := PendingRecreateWndTrapList.Count - 1 downto 0 do begin + if TWinControlTrap(PendingRecreateWndTrapList[i]).FControl = Control then begin + Result := TWinControlTrap(PendingRecreateWndTrapList[i]); + PendingRecreateWndTrapList.Delete(i); + break; { found it } + end; + end; + if Result = nil then + Result := TWinControlTrap.Create(Control); +end; + +procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False); +var + WinControlTrap: TWinControlTrap; +begin + if not IsWindowUnicode(Control.Handle) then + raise ETntInternalError.Create('Internal Error: SubClassUnicodeControl.Control is not Unicode.'); + + WinControlTrap := FindOrCreateWinControlTrap(Control); + WinControlTrap.SubClassControl(Params_Caption); + WinControlTrap.IDEWindow := IDEWindow; +end; + + +//----------------------------------------------- CREATE/DESTROY UNICODE HANDLE + +var + WindowAtom: TAtom; + ControlAtom: TAtom; + WindowAtomString: AnsiString; + ControlAtomString: AnsiString; + +type + TWndProc = function(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; + +function InitWndProcW(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; + + function GetObjectInstance(Control: TWinControl): Pointer; + var + WinControlTrap: TWinControlTrap; + begin + WinControlTrap := FindOrCreateWinControlTrap(Control); + PendingRecreateWndTrapList.Add(WinControlTrap); + Result := WinControlTrap.WinControl_ObjectInstance; + end; + +var + ObjectInstance: Pointer; +begin + TAccessWinControl(CreationControl).WindowHandle := HWindow; + ObjectInstance := GetObjectInstance(CreationControl); + {Controls.InitWndProc converts control to ANSI here by calling SetWindowLongA()!} + SetWindowLongW(HWindow, GWL_WNDPROC, Integer(ObjectInstance)); + if (GetWindowLongW(HWindow, GWL_STYLE) and WS_CHILD <> 0) + and (GetWindowLongW(HWindow, GWL_ID) = 0) then + SetWindowLongW(HWindow, GWL_ID, Integer(HWindow)); + SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl)); + SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl)); + CreationControl := nil; + Result := TWndProc(ObjectInstance)(HWindow, Message, WParam, lParam); +end; + +procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False); +const + UNICODE_CLASS_EXT = '.UnicodeClass'; +var + TempClass: TWndClassW; + WideClass: TWndClassW; + ClassRegistered: Boolean; + InitialProc: TFNWndProc; +begin + if IDEWindow then + InitialProc := @InitWndProc + else + InitialProc := @InitWndProcW; + + with Params do begin + WideWinClassName := WinClassName + UNICODE_CLASS_EXT; + ClassRegistered := GetClassInfoW(hInstance, PWideChar(WideWinClassName), TempClass); + if (not ClassRegistered) or (TempClass.lpfnWndProc <> InitialProc) + then begin + if ClassRegistered then Win32Check(Windows.UnregisterClassW(PWideChar(WideWinClassName), hInstance)); + // Prepare a TWndClassW record + WideClass := TWndClassW(WindowClass); + WideClass.hInstance := hInstance; + WideClass.lpfnWndProc := InitialProc; + if not Tnt_Is_IntResource(PWideChar(WindowClass.lpszMenuName)) then begin + WideClass.lpszMenuName := PWideChar(WideString(WindowClass.lpszMenuName)); + end; + WideClass.lpszClassName := PWideChar(WideWinClassName); + + // Register the UNICODE class + if RegisterClassW(WideClass) = 0 then RaiseLastOSError; + end; + end; +end; + +procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams; + const SubClass: WideString; IDEWindow: Boolean = False); +var + TempSubClass: TWndClassW; + WideWinClassName: WideString; + Handle: THandle; +begin + if (not Win32PlatformIsUnicode) then begin + with Params do + TAccessWinControl(Control).WindowHandle := CreateWindowEx(ExStyle, WinClassName, + Caption, Style, X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param); + end else begin + // SubClass the unicode version of this control by getting the correct DefWndProc + if (SubClass <> '') + and GetClassInfoW(Params.WindowClass.hInstance, PWideChar(SubClass), TempSubClass) then + TAccessWinControl(Control).DefWndProc := TempSubClass.lpfnWndProc + else + TAccessWinControl(Control).DefWndProc := @DefWindowProcW; + + // make sure Unicode window class is registered + RegisterUnicodeClass(Params, WideWinClassName, IDEWindow); + + // Create UNICODE window handle + UnicodeCreationControl := Control; + try + with Params do + Handle := CreateWindowExW(ExStyle, PWideChar(WideWinClassName), nil, + Style, X, Y, Width, Height, WndParent, 0, hInstance, Param); + if Handle = 0 then + RaiseLastOSError; + TAccessWinControl(Control).WindowHandle := Handle; + if IDEWindow then + SetWindowLongW(Handle, GWL_WNDPROC, GetWindowLong(Handle, GWL_WNDPROC)); + finally + UnicodeCreationControl := nil; + end; + + SubClassUnicodeControl(Control, Params.Caption, IDEWindow); + end; +end; + +procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False); +var + WasFocused: Boolean; + Params: TCreateParams; +begin + with TAccessWinControl(Control) do begin + WasFocused := Focused; + DestroyHandle; + CreateParams(Params); + CreationControl := Control; + CreateUnicodeHandle(Control, Params, SubClass, IDEWindow); + StrDispose{TNT-ALLOW StrDispose}(WindowText); + WindowText := nil; + Perform(WM_SETFONT, Integer(Font.Handle), 1); + if AutoSize then AdjustSize; + UpdateControlState; + if WasFocused and (WindowHandle <> 0) then Windows.SetFocus(WindowHandle); + end; +end; + +{ TTntCustomHintWindow procs } + +function DataPointsToHintInfoForTnt(AData: Pointer): Boolean; +begin + try + Result := (AData <> nil) + and (PHintInfo(AData).HintData = AData) {points to self} + and (PHintInfo(AData).HintWindowClass.InheritsFrom(TTntCustomHintWindow)); + except + Result := False; + end; +end; + +function ExtractTntHintCaption(AData: Pointer): WideString; +var + Control: TControl; + WideHint: WideString; + AnsiHintWithShortCut: AnsiString; + ShortCut: TShortCut; +begin + Result := PHintInfo(AData).HintStr; + if Result <> '' then begin + Control := PHintInfo(AData).HintControl; + WideHint := WideGetShortHint(WideGetHint(Control)); + if (AnsiString(WideHint) = PHintInfo(AData).HintStr) then + Result := WideHint + else if Application.HintShortCuts and (Control <> nil) + and (Control.Action is TCustomAction{TNT-ALLOW TCustomAction}) then begin + ShortCut := TCustomAction{TNT-ALLOW TCustomAction}(Control.Action).ShortCut; + if (ShortCut <> scNone) then + begin + AnsiHintWithShortCut := Format{TNT-ALLOW Format}('%s (%s)', [WideHint, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut)]); + if AnsiHintWithShortCut = PHintInfo(AData).HintStr then + Result := WideFormat('%s (%s)', [WideHint, WideShortCutToText(ShortCut)]); + end; + end; + end; +end; + +{ TTntCustomHintWindow } + +procedure TTntCustomHintWindow.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +{$IFNDEF COMPILER_7_UP} +procedure TTntCustomHintWindow.CreateParams(var Params: TCreateParams); +const + CS_DROPSHADOW = $00020000; +begin + inherited; + if Win32PlatformIsXP then { Enable drop shadow effect on Windows XP and later. } + Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW; +end; +{$ENDIF} + +function TTntCustomHintWindow.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomHintWindow.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomHintWindow.Paint; +var + R: TRect; +begin + if FBlockPaint then + exit; + if (not Win32PlatformIsUnicode) then + inherited + else begin + R := ClientRect; + Inc(R.Left, 2); + Inc(R.Top, 2); + Canvas.Font.Color := Screen.HintFont.Color; + Tnt_DrawTextW(Canvas.Handle, PWideChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or + DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly); + end; +end; + +procedure TTntCustomHintWindow.CMTextChanged(var Message: TMessage); +begin + { Avoid flicker when calling ActivateHint } + if FActivating then Exit; + Width := WideCanvasTextWidth(Canvas, Caption) + 6; + Height := WideCanvasTextHeight(Canvas, Caption) + 6; +end; + +procedure TTntCustomHintWindow.ActivateHint(Rect: TRect; const AHint: AnsiString); +var + SaveActivating: Boolean; +begin + SaveActivating := FActivating; + try + FActivating := True; + inherited; + finally + FActivating := SaveActivating; + end; +end; + +procedure TTntCustomHintWindow.ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); +var + SaveActivating: Boolean; +begin + if (not Win32PlatformIsUnicode) + or (not DataPointsToHintInfoForTnt(AData)) then + inherited + else begin + FBlockPaint := True; + try + SaveActivating := FActivating; + try + FActivating := True; + inherited; + Caption := ExtractTntHintCaption(AData); + finally + FActivating := SaveActivating; + end; + finally + FBlockPaint := False; + end; + Invalidate; + end; +end; + +function TntHintWindow_CalcHintRect(HintWindow: TTntCustomHintWindow; MaxWidth: Integer; const AHint: WideString): TRect; +begin + Result := Rect(0, 0, MaxWidth, 0); + Tnt_DrawTextW(HintWindow.Canvas.Handle, PWideChar(AHint), -1, Result, DT_CALCRECT or DT_LEFT or + DT_WORDBREAK or DT_NOPREFIX or HintWindow.DrawTextBiDiModeFlagsReadingOnly); + Inc(Result.Right, 6); + Inc(Result.Bottom, 2); +end; + +function TTntCustomHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; +var + WideHintStr: WideString; +begin + if (not Win32PlatformIsUnicode) + or (not DataPointsToHintInfoForTnt(AData)) then + Result := inherited CalcHintRect(MaxWidth, AHint, AData) + else begin + WideHintStr := ExtractTntHintCaption(AData); + Result := TntHintWindow_CalcHintRect(Self, MaxWidth, WideHintStr); + end; +end; + +{ TTntHintWindow } + +procedure TTntHintWindow.ActivateHint(Rect: TRect; const AHint: WideString); +var + SaveActivating: Boolean; +begin + SaveActivating := FActivating; + try + FActivating := True; + Caption := AHint; + inherited ActivateHint(Rect, AHint); + finally + FActivating := SaveActivating; + end; +end; + +procedure TTntHintWindow.ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); +var + SaveActivating: Boolean; +begin + FBlockPaint := True; + try + SaveActivating := FActivating; + try + FActivating := True; + Caption := AHint; + inherited ActivateHintData(Rect, AHint, AData); + finally + FActivating := SaveActivating; + end; + finally + FBlockPaint := False; + end; + Invalidate; +end; + +function TTntHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; +begin + Result := TntHintWindow_CalcHintRect(Self, MaxWidth, AHint); +end; + +procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject); +var + WideControl: IWideCustomListControl; +begin + if Control.GetInterface(IWideCustomListControl, WideControl) then + WideControl.AddItem(Item, AObject) + else + Control.AddItem(Item, AObject); +end; + +procedure InitControls; + + procedure InitAtomStrings_D6_D7_D9; + var + Controls_HInstance: Cardinal; + begin + Controls_HInstance := FindClassHInstance(TWinControl); + WindowAtomString := Format{TNT-ALLOW Format}('Delphi%.8X',[GetCurrentProcessID]); + ControlAtomString := Format{TNT-ALLOW Format}('ControlOfs%.8X%.8X', [Controls_HInstance, GetCurrentThreadID]); + end; + + {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + procedure InitAtomStrings; + begin + InitAtomStrings_D6_D7_D9; + end; + {$ENDIF} + {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + procedure InitAtomStrings; + begin + InitAtomStrings_D6_D7_D9; + end; + {$ENDIF} + {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + procedure InitAtomStrings; + begin + InitAtomStrings_D6_D7_D9; + end; + {$ENDIF} + {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + procedure InitAtomStrings; + begin + InitAtomStrings_D6_D7_D9; + end; + {$ENDIF} + +begin + InitAtomStrings; + WindowAtom := WinCheckH(GlobalAddAtom(PAnsiChar(WindowAtomString))); + ControlAtom := WinCheckH(GlobalAddAtom(PAnsiChar(ControlAtomString))); +end; + +initialization + TNT_WM_DESTROY := RegisterWindowMessage('TntUnicodeVcl.DestroyWindow'); + WideControlHelpers := TComponentList.Create(True); + PendingRecreateWndTrapList := TComponentList.Create(False); + InitControls; + +finalization + GlobalDeleteAtom(ControlAtom); + GlobalDeleteAtom(WindowAtom); + FreeAndNil(WideControlHelpers); + FreeAndNil(PendingRecreateWndTrapList); + Finalized := True; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas new file mode 100644 index 0000000000..4490bd12e2 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas @@ -0,0 +1,900 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDB; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, DB; + +type +{TNT-WARN TDateTimeField} + TTntDateTimeField = class(TDateTimeField{TNT-ALLOW TDateTimeField}) + protected + procedure SetAsString(const Value: AnsiString); override; + end; + +{TNT-WARN TDateField} + TTntDateField = class(TDateField{TNT-ALLOW TDateField}) + protected + procedure SetAsString(const Value: AnsiString); override; + end; + +{TNT-WARN TTimeField} + TTntTimeField = class(TTimeField{TNT-ALLOW TTimeField}) + protected + procedure SetAsString(const Value: AnsiString); override; + end; + + TFieldGetWideTextEvent = procedure(Sender: TField; var Text: WideString; + DoDisplayText: Boolean) of object; + TFieldSetWideTextEvent = procedure(Sender: TField; const Text: WideString) of object; + + IWideStringField = interface + ['{679C5F1A-4356-4696-A8F3-9C7C6970A9F6}'] + {$IFNDEF COMPILER_10_UP} + function GetAsWideString: WideString; + procedure SetAsWideString(const Value: WideString); + {$ENDIF} + function GetWideDisplayText: WideString; + function GetWideEditText: WideString; + procedure SetWideEditText(const Value: WideString); + //-- + {$IFNDEF COMPILER_10_UP} + property AsWideString: WideString read GetAsWideString write SetAsWideString{inherited}; + {$ENDIF} + property WideDisplayText: WideString read GetWideDisplayText; + property WideText: WideString read GetWideEditText write SetWideEditText; + end; + +{TNT-WARN TWideStringField} + TTntWideStringField = class(TWideStringField{TNT-ALLOW TWideStringField}, IWideStringField) + private + FOnGetText: TFieldGetWideTextEvent; + FOnSetText: TFieldSetWideTextEvent; + procedure SetOnGetText(const Value: TFieldGetWideTextEvent); + procedure SetOnSetText(const Value: TFieldSetWideTextEvent); + procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); + procedure LegacySetText(Sender: TField; const AnsiText: AnsiString); + function GetWideDisplayText: WideString; + function GetWideEditText: WideString; + procedure SetWideEditText(const Value: WideString); + protected + {$IFNDEF COMPILER_10_UP} + function GetAsWideString: WideString; + {$ENDIF} + public + property Value: WideString read GetAsWideString write SetAsWideString; + property DisplayText{TNT-ALLOW DisplayText}: WideString read GetWideDisplayText; + property Text: WideString read GetWideEditText write SetWideEditText; + {$IFNDEF COMPILER_10_UP} + property AsWideString: WideString read GetAsWideString write SetAsWideString; + {$ENDIF} + property WideDisplayText: WideString read GetWideDisplayText; + property WideText: WideString read GetWideEditText write SetWideEditText; + published + property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText; + property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText; + end; + + TTntStringFieldEncodingMode = (emNone, emUTF8, emUTF7, emFixedCodePage, emFixedCodePage_Safe); + + //------------------------------------------------------------------------------------------- + // Comments on TTntStringFieldEncodingMode: + // + // emNone - Works like TStringField. + // emUTF8 - Should work well most databases. + // emUTF7 - Almost guaranteed to work with any database. Wasteful in database space. + // emFixedCodePage - Only tested it with Access 97, which doesn't support Unicode. + // emFixedCodePage_Safe - Like emFixedCodePage but uses char<=#128. Wasteful in database space. + // + // Only emUTF8 and emUTF7 fully support Unicode. + //------------------------------------------------------------------------------------------- + + TTntStringFieldCodePageEnum = (fcpOther, + fcpThai, fcpJapanese, fcpSimplifiedChinese, fcpTraditionalChinese, fcpKorean, + fcpCentralEuropean, fcpCyrillic, fcpLatinWestern, fcpGreek, fcpTurkish, + fcpHebrew, fcpArabic, fcpBaltic, fcpVietnamese); + +const + TntStringFieldCodePageEnumMap: array[TTntStringFieldCodePageEnum] of Word = (0, + 874, 932, 936, 950, 949, + 1250, 1251, 1252, 1253, 1254, + 1255, 1256, 1257, 1258); + +type +{TNT-WARN TStringField} + TTntStringField = class(TStringField{TNT-ALLOW TStringField},IWideStringField) + private + FOnGetText: TFieldGetWideTextEvent; + FOnSetText: TFieldSetWideTextEvent; + FEncodingMode: TTntStringFieldEncodingMode; + FFixedCodePage: Word; + FRawVariantAccess: Boolean; + procedure SetOnGetText(const Value: TFieldGetWideTextEvent); + procedure SetOnSetText(const Value: TFieldSetWideTextEvent); + procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); + procedure LegacySetText(Sender: TField; const AnsiText: AnsiString); + function GetWideDisplayText: WideString; + function GetWideEditText: WideString; + procedure SetWideEditText(const Value: WideString); + function GetFixedCodePageEnum: TTntStringFieldCodePageEnum; + procedure SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); + function IsFixedCodePageStored: Boolean; + protected + {$IFDEF COMPILER_10_UP} + function GetAsWideString: WideString; override; + procedure SetAsWideString(const Value: WideString); override; + {$ELSE} + function GetAsWideString: WideString; virtual; + procedure SetAsWideString(const Value: WideString); virtual; + {$ENDIF} + function GetAsVariant: Variant; override; + procedure SetVarValue(const Value: Variant); override; + function GetAsString: string{TNT-ALLOW string}; override; + procedure SetAsString(const Value: string{TNT-ALLOW string}); override; + public + constructor Create(AOwner: TComponent); override; + property Value: WideString read GetAsWideString write SetAsWideString; + property DisplayText{TNT-ALLOW DisplayText}: WideString read GetWideDisplayText; + property Text: WideString read GetWideEditText write SetWideEditText; + {$IFNDEF COMPILER_10_UP} + property AsWideString: WideString read GetAsWideString write SetAsWideString; + {$ENDIF} + property WideDisplayText: WideString read GetWideDisplayText; + property WideText: WideString read GetWideEditText write SetWideEditText; + published + property EncodingMode: TTntStringFieldEncodingMode read FEncodingMode write FEncodingMode default emUTF8; + property FixedCodePageEnum: TTntStringFieldCodePageEnum read GetFixedCodePageEnum write SetFixedCodePageEnum stored False; + property FixedCodePage: Word read FFixedCodePage write FFixedCodePage stored IsFixedCodePageStored; + property RawVariantAccess: Boolean read FRawVariantAccess write FRawVariantAccess default False; + property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText; + property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText; + end; + +//====================== +type +{TNT-WARN TMemoField} + TTntMemoField = class(TMemoField{TNT-ALLOW TMemoField}, IWideStringField) + private + FOnGetText: TFieldGetWideTextEvent; + FOnSetText: TFieldSetWideTextEvent; + FEncodingMode: TTntStringFieldEncodingMode; + FFixedCodePage: Word; + FRawVariantAccess: Boolean; + procedure SetOnGetText(const Value: TFieldGetWideTextEvent); + procedure SetOnSetText(const Value: TFieldSetWideTextEvent); + procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); + procedure LegacySetText(Sender: TField; const AnsiText: AnsiString); + function GetWideDisplayText: WideString; + function GetWideEditText: WideString; + procedure SetWideEditText(const Value: WideString); + function GetFixedCodePageEnum: TTntStringFieldCodePageEnum; + procedure SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); + function IsFixedCodePageStored: Boolean; + protected + {$IFDEF COMPILER_10_UP} + function GetAsWideString: WideString; override; + procedure SetAsWideString(const Value: WideString); override; + {$ELSE} + function GetAsWideString: WideString; virtual; + procedure SetAsWideString(const Value: WideString); virtual; + {$ENDIF} + function GetAsVariant: Variant; override; + procedure SetVarValue(const Value: Variant); override; + function GetAsString: string{TNT-ALLOW string}; override; + procedure SetAsString(const Value: string{TNT-ALLOW string}); override; + public + constructor Create(AOwner: TComponent); override; + property Value: WideString read GetAsWideString write SetAsWideString; + property DisplayText{TNT-ALLOW DisplayText}: WideString read GetWideDisplayText; + property Text: WideString read GetWideEditText write SetWideEditText; + {$IFNDEF COMPILER_10_UP} + property AsWideString: WideString read GetAsWideString write SetAsWideString; + {$ENDIF} + property WideDisplayText: WideString read GetWideDisplayText; + property WideText: WideString read GetWideEditText write SetWideEditText; + published + property EncodingMode: TTntStringFieldEncodingMode read FEncodingMode write FEncodingMode default emUTF8; + property FixedCodePageEnum: TTntStringFieldCodePageEnum read GetFixedCodePageEnum write SetFixedCodePageEnum stored False; + property FixedCodePage: Word read FFixedCodePage write FFixedCodePage stored IsFixedCodePageStored; + property RawVariantAccess: Boolean read FRawVariantAccess write FRawVariantAccess default False; + property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText; + property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText; + end; + +//====================== +function GetTntFieldClass(FieldClass: TFieldClass): TFieldClass; + +function GetWideDisplayName(Field: TField): WideString; deprecated; // for Unicode-enabled functionality, use Delphi 2006 or newer +function GetWideDisplayLabel(Field: TField): WideString; deprecated; // for Unicode-enabled functionality, use Delphi 2006 or newer +procedure SetWideDisplayLabel(Field: TField; const Value: WideString); deprecated; // for Unicode-enabled functionality, use Delphi 2006 or newer + +{TNT-WARN AsString} +{TNT-WARN DisplayText} + +function GetAsWideString(Field: TField): WideString; +procedure SetAsWideString(Field: TField; const Value: WideString); + +function GetWideDisplayText(Field: TField): WideString; + +function GetWideText(Field: TField): WideString; +procedure SetWideText(Field: TField; const Value: WideString); + +procedure RegisterTntFields; + +{ TTntWideStringField / TTntStringField common handlers } +procedure TntWideStringField_GetWideText(Field: TField; + var Text: WideString; DoDisplayText: Boolean); +function TntWideStringField_GetWideDisplayText(Field: TField; + OnGetText: TFieldGetWideTextEvent): WideString; +function TntWideStringField_GetWideEditText(Field: TField; + OnGetText: TFieldGetWideTextEvent): WideString; +procedure TntWideStringField_SetWideText(Field: TField; + const Value: WideString); +procedure TntWideStringField_SetWideEditText(Field: TField; + OnSetText: TFieldSetWideTextEvent; const Value: WideString); + + +implementation + +uses + SysUtils, MaskUtils, Variants, Contnrs, TntSystem, TntSysUtils; + +function GetTntFieldClass(FieldClass: TFieldClass): TFieldClass; +begin + if FieldClass = TDateTimeField{TNT-ALLOW TDateTimeField} then + Result := TTntDateTimeField + else if FieldClass = TDateField{TNT-ALLOW TDateField} then + Result := TTntDateField + else if FieldClass = TTimeField{TNT-ALLOW TTimeField} then + Result := TTntTimeField + else if FieldClass = TWideStringField{TNT-ALLOW TWideStringField} then + Result := TTntWideStringField + else if FieldClass = TStringField{TNT-ALLOW TStringField} then + Result := TTntStringField + else + Result := FieldClass; +end; + +function GetWideDisplayName(Field: TField): WideString; +begin + Result := Field.DisplayName; +end; + +function GetWideDisplayLabel(Field: TField): WideString; +begin + Result := Field.DisplayLabel; +end; + +procedure SetWideDisplayLabel(Field: TField; const Value: WideString); +begin + Field.DisplayLabel := Value; +end; + +function GetAsWideString(Field: TField): WideString; +{$IFDEF COMPILER_10_UP} +begin + if (Field.ClassType = TMemoField{TNT-ALLOW TMemoField}) then + Result := VarToWideStr(Field.AsVariant) { works for NexusDB BLOB Wide } + else + Result := Field.AsWideString +end; +{$ELSE} +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + Result := WideField.AsWideString + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) then + begin + if Field.IsNull then + // This fixes a bug in TWideStringField.GetAsWideString which does not handle Null at all. + Result := '' + else + Result := TWideStringField{TNT-ALLOW TWideStringField}(Field).Value + end else if (Field is TMemoField{TNT-ALLOW TMemoField}) then + Result := VarToWideStr(Field.AsVariant) { works for NexusDB BLOB Wide } + else + Result := Field.AsString{TNT-ALLOW AsString}; +end; +{$ENDIF} + +procedure SetAsWideString(Field: TField; const Value: WideString); +{$IFDEF COMPILER_10_UP} +begin + if (Field.ClassType = TMemoField{TNT-ALLOW TMemoField}) then + Field.AsVariant := Value { works for NexusDB BLOB Wide } + else + Field.AsWideString := Value; +end; +{$ELSE} +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + WideField.AsWideString := Value + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) then + TWideStringField{TNT-ALLOW TWideStringField}(Field).Value := Value + else if (Field is TMemoField{TNT-ALLOW TMemoField}) then + Field.AsVariant := Value { works for NexusDB BLOB Wide } + else + Field.AsString{TNT-ALLOW AsString} := Value; +end; +{$ENDIF} + +function GetWideDisplayText(Field: TField): WideString; +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + Result := WideField.WideDisplayText + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) + and (not Assigned(Field.OnGetText)) then + Result := GetAsWideString(Field) + else + Result := Field.DisplayText{TNT-ALLOW DisplayText}; +end; + +function GetWideText(Field: TField): WideString; +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + Result := WideField.WideText + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) + and (not Assigned(Field.OnGetText)) then + Result := GetAsWideString(Field) + else + Result := Field.Text; +end; + +procedure SetWideText(Field: TField; const Value: WideString); +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + WideField.WideText := Value + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) + and (not Assigned(Field.OnSetText)) then + SetAsWideString(Field, Value) + else + Field.Text := Value +end; + +{ TTntDateTimeField } + +procedure TTntDateTimeField.SetAsString(const Value: AnsiString); +begin + if Value = '' then + inherited + else + SetAsDateTime(TntStrToDateTime(Value)); +end; + +{ TTntDateField } + +procedure TTntDateField.SetAsString(const Value: AnsiString); +begin + if Value = '' then + inherited + else + SetAsDateTime(TntStrToDate(Value)); +end; + +{ TTntTimeField } + +procedure TTntTimeField.SetAsString(const Value: AnsiString); +begin + if Value = '' then + inherited + else + SetAsDateTime(TntStrToTime(Value)); +end; + +{ TTntWideStringField / TTntStringField common handlers } + +procedure TntWideStringField_LegacyGetText(Sender: TField; OnGetText: TFieldGetWideTextEvent; + var AnsiText: AnsiString; DoDisplayText: Boolean); +var + WideText: WideString; +begin + if Assigned(OnGetText) then begin + WideText := AnsiText; + OnGetText(Sender, WideText, DoDisplayText); + AnsiText := WideText; + end; +end; + +procedure TntWideStringField_LegacySetText(Sender: TField; OnSetText: TFieldSetWideTextEvent; + const AnsiText: AnsiString); +begin + if Assigned(OnSetText) then + OnSetText(Sender, AnsiText); +end; + +procedure TntWideStringField_GetWideText(Field: TField; + var Text: WideString; DoDisplayText: Boolean); +var + WideStringField: IWideStringField; +begin + Field.GetInterface(IWideStringField, WideStringField); + Assert(WideStringField <> nil); + if DoDisplayText and (Field.EditMaskPtr <> '') then + { to gain the mask, we lose Unicode! } + Text := FormatMaskText(Field.EditMaskPtr, GetAsWideString(Field)) + else + Text := GetAsWideString(Field); +end; + +function TntWideStringField_GetWideDisplayText(Field: TField; + OnGetText: TFieldGetWideTextEvent): WideString; +begin + Result := ''; + if Assigned(OnGetText) then + OnGetText(Field, Result, True) + else if Assigned(Field.OnGetText) then + Result := Field.DisplayText{TNT-ALLOW DisplayText} {we lose Unicode to handle this event} + else + TntWideStringField_GetWideText(Field, Result, True); +end; + +function TntWideStringField_GetWideEditText(Field: TField; + OnGetText: TFieldGetWideTextEvent): WideString; +begin + Result := ''; + if Assigned(OnGetText) then + OnGetText(Field, Result, False) + else if Assigned(Field.OnGetText) then + Result := Field.Text {we lose Unicode to handle this event} + else + TntWideStringField_GetWideText(Field, Result, False); +end; + +procedure TntWideStringField_SetWideText(Field: TField; + const Value: WideString); +{$IFDEF COMPILER_10_UP} +begin + Field.AsWideString := Value; +end; +{$ELSE} +var + WideStringField: IWideStringField; +begin + Field.GetInterface(IWideStringField, WideStringField); + Assert(WideStringField <> nil); + WideStringField.SetAsWideString(Value); +end; +{$ENDIF} + +procedure TntWideStringField_SetWideEditText(Field: TField; + OnSetText: TFieldSetWideTextEvent; const Value: WideString); +begin + if Assigned(OnSetText) then + OnSetText(Field, Value) + else if Assigned(Field.OnSetText) then + Field.Text := Value {we lose Unicode to handle this event} + else + TntWideStringField_SetWideText(Field, Value); +end; + +{ TTntWideStringField } + +{$IFNDEF COMPILER_10_UP} +function TTntWideStringField.GetAsWideString: WideString; +begin + if not GetData(@Result, False) then + Result := ''; {fixes a bug in inherited which has unpredictable results for NULL} +end; +{$ENDIF} + +procedure TTntWideStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; + DoDisplayText: Boolean); +begin + TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText); +end; + +procedure TTntWideStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString); +begin + TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText); +end; + +procedure TTntWideStringField.SetOnGetText(const Value: TFieldGetWideTextEvent); +begin + FOnGetText := Value; + if Assigned(OnGetText) then + inherited OnGetText := LegacyGetText + else + inherited OnGetText := nil; +end; + +procedure TTntWideStringField.SetOnSetText(const Value: TFieldSetWideTextEvent); +begin + FOnSetText := Value; + if Assigned(OnSetText) then + inherited OnSetText := LegacySetText + else + inherited OnSetText := nil; +end; + +function TTntWideStringField.GetWideDisplayText: WideString; +begin + Result := TntWideStringField_GetWideDisplayText(Self, OnGetText); +end; + +function TTntWideStringField.GetWideEditText: WideString; +begin + Result := TntWideStringField_GetWideEditText(Self, OnGetText); +end; + +procedure TTntWideStringField.SetWideEditText(const Value: WideString); +begin + TntWideStringField_SetWideEditText(Self, OnSetText, Value); +end; + +(* This stuffing method works with CJK codepages - intended to store accented characters in Access 97 *) + +function SafeStringToWideStringEx(const S: AnsiString; Codepage: Word): WideString; +var + R: AnsiString; + i: Integer; +begin + R := ''; + i := 1; + while i <= Length(S) do + begin + if (S[i] = #128) then + begin + Inc(i); + if S[i] = #128 then + R := R + #128 + else + R := R + Chr(Ord(S[i]) + 128); + Inc(i); + end + else + begin + R := R + S[I]; + Inc(i); + end; + end; + Result := StringToWideStringEx(R, CodePage); +end; + +function SafeWideStringToStringEx(const W: WideString; CodePage: Word): AnsiString; +var + TempS: AnsiString; + i: integer; +begin + TempS := WideStringToStringEx(W, CodePage); + Result := ''; + for i := 1 to Length(TempS) do + begin + if TempS[i] > #128 then + Result := Result + #128 + Chr(Ord(TempS[i]) - 128) + else if TempS[i] = #128 then + Result := Result + #128 + #128 + else + Result := Result + TempS[i]; + end; +end; + +{ TTntStringField } + +constructor TTntStringField.Create(AOwner: TComponent); +begin + inherited; + FEncodingMode := emUTF8; + FFixedCodePage := TntStringFieldCodePageEnumMap[fcpLatinWestern] +end; + +function TTntStringField.GetFixedCodePageEnum: TTntStringFieldCodePageEnum; +var + i: TTntStringFieldCodePageEnum; +begin + Result := fcpOther; + for i := Low(TntStringFieldCodePageEnumMap) to High(TntStringFieldCodePageEnumMap) do begin + if TntStringFieldCodePageEnumMap[i] = FixedCodePage then begin + Result := i; + Break; {found it} + end; + end; +end; + +procedure TTntStringField.SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); +begin + if (Value <> fcpOther) then + FixedCodePage := TntStringFieldCodePageEnumMap[Value]; +end; + +function TTntStringField.GetAsVariant: Variant; +begin + if RawVariantAccess then + Result := inherited GetAsVariant + else if IsNull then + Result := Null + else + Result := GetAsWideString; +end; + +procedure TTntStringField.SetVarValue(const Value: Variant); +begin + if RawVariantAccess then + inherited + else + SetAsWideString(Value); +end; + +function TTntStringField.GetAsWideString: WideString; +begin + case EncodingMode of + emNone: Result := (inherited GetAsString); + emUTF8: Result := UTF8ToWideString(inherited GetAsString); + emUTF7: try + Result := UTF7ToWideString(inherited GetAsString); + except + Result := inherited GetAsString; + end; + emFixedCodePage: Result := StringToWideStringEx(inherited GetAsString, FixedCodePage); + emFixedCodePage_Safe: Result := SafeStringToWideStringEx(inherited GetAsString, FixedCodePage); + else + raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); + end; +end; + +procedure TTntStringField.SetAsWideString(const Value: WideString); +begin + case EncodingMode of + emNone: inherited SetAsString(Value); + emUTF8: inherited SetAsString(WideStringToUTF8(Value)); + emUTF7: inherited SetAsString(WideStringToUTF7(Value)); + emFixedCodePage: inherited SetAsString(WideStringToStringEx(Value, FixedCodePage)); + emFixedCodePage_Safe: inherited SetAsString(SafeWideStringToStringEx(Value, FixedCodePage)); + else + raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); + end; +end; + +function TTntStringField.GetAsString: string{TNT-ALLOW string}; +begin + if EncodingMode = emNone then + Result := inherited GetAsString + else + Result := GetAsWideString; +end; + +procedure TTntStringField.SetAsString(const Value: string{TNT-ALLOW string}); +begin + if EncodingMode = emNone then + inherited SetAsString(Value) + else + SetAsWideString(Value); +end; + +procedure TTntStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; + DoDisplayText: Boolean); +begin + TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText); +end; + +procedure TTntStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString); +begin + TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText); +end; + +procedure TTntStringField.SetOnGetText(const Value: TFieldGetWideTextEvent); +begin + FOnGetText := Value; + if Assigned(OnGetText) then + inherited OnGetText := LegacyGetText + else + inherited OnGetText := nil; +end; + +procedure TTntStringField.SetOnSetText(const Value: TFieldSetWideTextEvent); +begin + FOnSetText := Value; + if Assigned(OnSetText) then + inherited OnSetText := LegacySetText + else + inherited OnSetText := nil; +end; + +function TTntStringField.GetWideDisplayText: WideString; +begin + Result := TntWideStringField_GetWideDisplayText(Self, OnGetText) +end; + +function TTntStringField.GetWideEditText: WideString; +begin + Result := TntWideStringField_GetWideEditText(Self, OnGetText); +end; + +procedure TTntStringField.SetWideEditText(const Value: WideString); +begin + TntWideStringField_SetWideEditText(Self, OnSetText, Value); +end; + +function TTntStringField.IsFixedCodePageStored: Boolean; +begin + Result := EncodingMode = emFixedCodePage; +end; + +//--------------------------------------------------------------------------------------------- +{ TTntMemoField } + +constructor TTntMemoField.Create(AOwner: TComponent); +begin + inherited; + FEncodingMode := emUTF8; + FFixedCodePage := TntStringFieldCodePageEnumMap[fcpLatinWestern] +end; + +function TTntMemoField.GetFixedCodePageEnum: TTntStringFieldCodePageEnum; +var + i: TTntStringFieldCodePageEnum; +begin + Result := fcpOther; + for i := Low(TntStringFieldCodePageEnumMap) to High(TntStringFieldCodePageEnumMap) do begin + if TntStringFieldCodePageEnumMap[i] = FixedCodePage then begin + Result := i; + Break; {found it} + end; + end; +end; + +procedure TTntMemoField.SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); +begin + if (Value <> fcpOther) then + FixedCodePage := TntStringFieldCodePageEnumMap[Value]; +end; + +function TTntMemoField.GetAsVariant: Variant; +begin + if RawVariantAccess then + Result := inherited GetAsVariant + else if IsNull then + Result := Null + else + Result := GetAsWideString; +end; + +procedure TTntMemoField.SetVarValue(const Value: Variant); +begin + if RawVariantAccess then + inherited + else + SetAsWideString(Value); +end; + +function TTntMemoField.GetAsWideString: WideString; +begin + case EncodingMode of + emNone: Result := (inherited GetAsString); + emUTF8: Result := UTF8ToWideString(inherited GetAsString); + emUTF7: try + Result := UTF7ToWideString(inherited GetAsString); + except + Result := inherited GetAsString; + end; + emFixedCodePage: Result := StringToWideStringEx(inherited GetAsString, FixedCodePage); + emFixedCodePage_Safe: Result := SafeStringToWideStringEx(inherited GetAsString, FixedCodePage); + else + raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); + end; +end; + +procedure TTntMemoField.SetAsWideString(const Value: WideString); +begin + case EncodingMode of + emNone: inherited SetAsString(Value); + emUTF8: inherited SetAsString(WideStringToUTF8(Value)); + emUTF7: inherited SetAsString(WideStringToUTF7(Value)); + emFixedCodePage: inherited SetAsString(WideStringToStringEx(Value, FixedCodePage)); + emFixedCodePage_Safe: inherited SetAsString(SafeWideStringToStringEx(Value, FixedCodePage)); + else + raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); + end; +end; + +function TTntMemoField.GetAsString: string{TNT-ALLOW string}; +begin + if EncodingMode = emNone then + Result := inherited GetAsString + else + Result := GetAsWideString; +end; + +procedure TTntMemoField.SetAsString(const Value: string{TNT-ALLOW string}); +begin + if EncodingMode = emNone then + inherited SetAsString(Value) + else + SetAsWideString(Value); +end; + +procedure TTntMemoField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; + DoDisplayText: Boolean); +begin + TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText); +end; + +procedure TTntMemoField.LegacySetText(Sender: TField; const AnsiText: AnsiString); +begin + TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText); +end; + +procedure TTntMemoField.SetOnGetText(const Value: TFieldGetWideTextEvent); +begin + FOnGetText := Value; + if Assigned(OnGetText) then + inherited OnGetText := LegacyGetText + else + inherited OnGetText := nil; +end; + +procedure TTntMemoField.SetOnSetText(const Value: TFieldSetWideTextEvent); +begin + FOnSetText := Value; + if Assigned(OnSetText) then + inherited OnSetText := LegacySetText + else + inherited OnSetText := nil; +end; + +function TTntMemoField.GetWideDisplayText: WideString; +begin + Result := TntWideStringField_GetWideDisplayText(Self, OnGetText) +end; + +function TTntMemoField.GetWideEditText: WideString; +begin + Result := TntWideStringField_GetWideEditText(Self, OnGetText); +end; + +procedure TTntMemoField.SetWideEditText(const Value: WideString); +begin + TntWideStringField_SetWideEditText(Self, OnSetText, Value); +end; + +function TTntMemoField.IsFixedCodePageStored: Boolean; +begin + Result := EncodingMode = emFixedCodePage; +end; +//================================================================== +procedure RegisterTntFields; +begin + RegisterFields([TTntDateTimeField]); + RegisterFields([TTntDateField]); + RegisterFields([TTntTimeField]); + RegisterFields([TTntWideStringField]); + RegisterFields([TTntStringField]); + RegisterFields([TTntMemoField]); +end; + +type PFieldClass = ^TFieldClass; + +initialization +{$IFDEF TNT_FIELDS} + PFieldClass(@DefaultFieldClasses[ftDate])^ := TTntDateField; + PFieldClass(@DefaultFieldClasses[ftTime])^ := TTntTimeField; + PFieldClass(@DefaultFieldClasses[ftDateTime])^ := TTntDateTimeField; + PFieldClass(@DefaultFieldClasses[ftWideString])^ := TTntWideStringField; + PFieldClass(@DefaultFieldClasses[ftString])^ := TTntStringField; + PFieldClass(@DefaultFieldClasses[ftFixedChar])^ := TTntStringField; +{$ENDIF} + +finalization + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas new file mode 100644 index 0000000000..681257ec1a --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas @@ -0,0 +1,594 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, ActnList, DBActns, TntActnList; + +type +{TNT-WARN TDataSetAction} + TTntDataSetAction = class(TDataSetAction{TNT-ALLOW TDataSetAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetFirst} + TTntDataSetFirst = class(TDataSetFirst{TNT-ALLOW TDataSetFirst}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetPrior} + TTntDataSetPrior = class(TDataSetPrior{TNT-ALLOW TDataSetPrior}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetNext} + TTntDataSetNext = class(TDataSetNext{TNT-ALLOW TDataSetNext}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetLast} + TTntDataSetLast = class(TDataSetLast{TNT-ALLOW TDataSetLast}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetInsert} + TTntDataSetInsert = class(TDataSetInsert{TNT-ALLOW TDataSetInsert}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetDelete} + TTntDataSetDelete = class(TDataSetDelete{TNT-ALLOW TDataSetDelete}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetEdit} + TTntDataSetEdit = class(TDataSetEdit{TNT-ALLOW TDataSetEdit}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetPost} + TTntDataSetPost = class(TDataSetPost{TNT-ALLOW TDataSetPost}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetCancel} + TTntDataSetCancel = class(TDataSetCancel{TNT-ALLOW TDataSetCancel}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetRefresh} + TTntDataSetRefresh = class(TDataSetRefresh{TNT-ALLOW TDataSetRefresh}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +procedure TntDBActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); + +implementation + +uses + TntClasses; + +{TNT-IGNORE-UNIT} + +procedure TntDBActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntAction_AfterInherited_Assign(Action, Source); + // TDataSetAction + if (Action is TDataSetAction) and (Source is TDataSetAction) then begin + TDataSetAction(Action).DataSource := TDataSetAction(Source).DataSource; + end; +end; + +//------------------------- +// TNT DB ACTNS +//------------------------- + +{ TTntDataSetAction } + +procedure TTntDataSetAction.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetFirst } + +procedure TTntDataSetFirst.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetFirst.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetFirst.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetFirst.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetFirst.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetFirst.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetPrior } + +procedure TTntDataSetPrior.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetPrior.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetPrior.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetPrior.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetPrior.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetPrior.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetNext } + +procedure TTntDataSetNext.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetNext.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetNext.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetNext.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetNext.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetNext.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetLast } + +procedure TTntDataSetLast.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetLast.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetLast.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetLast.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetLast.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetLast.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetInsert } + +procedure TTntDataSetInsert.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetInsert.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetInsert.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetInsert.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetInsert.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetInsert.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetDelete } + +procedure TTntDataSetDelete.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetDelete.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetDelete.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetDelete.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetDelete.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetDelete.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetEdit } + +procedure TTntDataSetEdit.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetEdit.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetEdit.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetEdit.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetEdit.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetPost } + +procedure TTntDataSetPost.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetPost.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetPost.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetPost.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetPost.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetPost.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetCancel } + +procedure TTntDataSetCancel.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetCancel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetCancel.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetCancel.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetCancel.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetCancel.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetRefresh } + +procedure TTntDataSetRefresh.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetRefresh.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetRefresh.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetRefresh.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetRefresh.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetRefresh.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas new file mode 100644 index 0000000000..98904c7380 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas @@ -0,0 +1,197 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBClientActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, ActnList, DBClientActns, TntActnList; + +type +{TNT-WARN TClientDataSetApply} + TTntClientDataSetApply = class(TClientDataSetApply{TNT-ALLOW TClientDataSetApply}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TClientDataSetRevert} + TTntClientDataSetRevert = class(TClientDataSetRevert{TNT-ALLOW TClientDataSetRevert}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TClientDataSetUndo} + TTntClientDataSetUndo = class(TClientDataSetUndo{TNT-ALLOW TClientDataSetUndo}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +implementation + +uses + TntClasses, TntDBActns; + +{TNT-IGNORE-UNIT} + +procedure TntDBClientActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntDBActn_AfterInherited_Assign(Action, Source); + // TClientDataSetApply + if (Action is TClientDataSetApply) and (Source is TClientDataSetApply) then begin + TClientDataSetApply(Action).MaxErrors := TClientDataSetApply(Source).MaxErrors; + TClientDataSetApply(Action).DisplayErrorDlg := TClientDataSetApply(Source).DisplayErrorDlg; + end; + // TClientDataSetUndo + if (Action is TClientDataSetUndo) and (Source is TClientDataSetUndo) then begin + TClientDataSetUndo(Action).FollowChange := TClientDataSetUndo(Source).FollowChange; + end; +end; + +//------------------------- +// TNT DB ACTNS +//------------------------- + +{ TTntClientDataSetApply } + +procedure TTntClientDataSetApply.Assign(Source: TPersistent); +begin + inherited; + TntDBClientActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntClientDataSetApply.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntClientDataSetApply.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntClientDataSetApply.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntClientDataSetApply.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntClientDataSetApply.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntClientDataSetRevert } + +procedure TTntClientDataSetRevert.Assign(Source: TPersistent); +begin + inherited; + TntDBClientActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntClientDataSetRevert.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntClientDataSetRevert.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntClientDataSetRevert.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntClientDataSetRevert.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntClientDataSetRevert.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntClientDataSetUndo } + +procedure TTntClientDataSetUndo.Assign(Source: TPersistent); +begin + inherited; + TntDBClientActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntClientDataSetUndo.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntClientDataSetUndo.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntClientDataSetUndo.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntClientDataSetUndo.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntClientDataSetUndo.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas new file mode 100644 index 0000000000..49111d4aba --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas @@ -0,0 +1,2195 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Windows, Messages, DB, DBCtrls, Controls, StdCtrls, + TntClasses, TntStdCtrls, TntControls, TntComCtrls, TntExtCtrls; + +type +{TNT-WARN TPaintControl} + TTntPaintControl = class + private + FOwner: TWinControl; + FClassName: WideString; + FHandle: HWnd; + FObjectInstance: Pointer; + FDefWindowProc: Pointer; + FCtl3dButton: Boolean; + function GetHandle: HWnd; + procedure SetCtl3DButton(Value: Boolean); + procedure WndProc(var Message: TMessage); + public + constructor Create(AOwner: TWinControl; const ClassName: WideString); + destructor Destroy; override; + procedure DestroyHandle; + property Ctl3DButton: Boolean read FCtl3dButton write SetCtl3dButton; + property Handle: HWnd read GetHandle; + end; + +type +{TNT-WARN TDBEdit} + TTntDBEdit = class(TDBEdit{TNT-ALLOW TDBEdit}) + private + InheritedDataChange: TNotifyEvent; + FPasswordChar: WideChar; + procedure DataChange(Sender: TObject); + procedure UpdateData(Sender: TObject); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + function GetTextMargins: TPoint; + function GetPasswordChar: WideChar; + procedure SetPasswordChar(const Value: WideChar); + procedure CMEnter(var Message: TCMEnter); message CM_ENTER; + private + function GetSelStart: Integer; reintroduce; virtual; + procedure SetSelStart(const Value: Integer); reintroduce; virtual; + function GetSelLength: Integer; reintroduce; virtual; + procedure SetSelLength(const Value: Integer); reintroduce; virtual; + function GetSelText: WideString; reintroduce; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property PasswordChar: WideChar read GetPasswordChar write SetPasswordChar default #0; + end; + +{TNT-WARN TDBText} + TTntDBText = class(TDBText{TNT-ALLOW TDBText}) + private + FDataLink: TFieldDataLink; + InheritedDataChange: TNotifyEvent; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + function GetCaption: TWideCaption; + function IsCaptionStored: Boolean; + procedure SetCaption(const Value: TWideCaption); + function GetFieldText: WideString; + procedure DataChange(Sender: TObject); + protected + procedure DefineProperties(Filer: TFiler); override; + function GetLabelText: WideString; reintroduce; virtual; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure DoDrawText(var Rect: TRect; Flags: Longint); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TDBComboBox} + TTntCustomDBComboBox = class(TDBComboBox{TNT-ALLOW TDBComboBox}, + IWideCustomListControl) + private + FDataLink: TFieldDataLink; + FFilter: WideString; + FLastTime: Cardinal; + procedure UpdateData(Sender: TObject); + procedure EditingChange(Sender: TObject); + procedure CMEnter(var Message: TCMEnter); message CM_ENTER; + procedure SetReadOnly; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Message: TWMChar); message WM_CHAR; + private + FItems: TTntStrings; + FSaveItems: TTntStrings; + FSaveItemIndex: integer; + function GetItems: TTntStrings; + procedure SetItems(const Value: TTntStrings); reintroduce; + function GetSelStart: Integer; + procedure SetSelStart(const Value: Integer); + function GetSelLength: Integer; + procedure SetSelLength(const Value: Integer); + function GetSelText: WideString; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + protected + procedure DataChange(Sender: TObject); + function GetAutoComplete_UniqueMatchOnly: Boolean; dynamic; + function GetAutoComplete_PreserveDataEntryCase: Boolean; dynamic; + procedure DoEditCharMsg(var Message: TWMChar); virtual; + function GetFieldValue: Variant; virtual; + procedure SetFieldValue(const Value: Variant); virtual; + function GetComboValue: Variant; virtual; abstract; + procedure SetComboValue(const Value: Variant); virtual; abstract; + {$IFDEF DELPHI_7} // fix for Delphi 7 only + function GetItemsClass: TCustomComboBoxStringsClass; override; + {$ENDIF} + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure WndProc(var Message: TMessage); override; + procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); override; + procedure KeyPress(var Key: AnsiChar); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + public + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property Items: TTntStrings read GetItems write SetItems; + end; + + TTntDBComboBox = class(TTntCustomDBComboBox) + protected + function GetFieldValue: Variant; override; + procedure SetFieldValue(const Value: Variant); override; + function GetComboValue: Variant; override; + procedure SetComboValue(const Value: Variant); override; + end; + +type +{TNT-WARN TDBCheckBox} + TTntDBCheckBox = class(TDBCheckBox{TNT-ALLOW TDBCheckBox}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure Toggle; override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TDBRichEdit} + TTntDBRichEdit = class(TTntCustomRichEdit) + private + FDataLink: TFieldDataLink; + FAutoDisplay: Boolean; + FFocused: Boolean; + FMemoLoaded: Boolean; + FDataSave: AnsiString; + procedure BeginEditing; + procedure DataChange(Sender: TObject); + procedure EditingChange(Sender: TObject); + function GetDataField: WideString; + function GetDataSource: TDataSource; + function GetField: TField; + function GetReadOnly: Boolean; + procedure SetDataField(const Value: WideString); + procedure SetDataSource(Value: TDataSource); + procedure SetReadOnly(Value: Boolean); + procedure SetAutoDisplay(Value: Boolean); + procedure SetFocused(Value: Boolean); + procedure UpdateData(Sender: TObject); + procedure WMCut(var Message: TMessage); message WM_CUT; + procedure WMPaste(var Message: TMessage); message WM_PASTE; + procedure CMEnter(var Message: TCMEnter); message CM_ENTER; + procedure CMExit(var Message: TCMExit); message CM_EXIT; + procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; + procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; + procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; + protected + procedure InternalLoadMemo; dynamic; + procedure InternalSaveMemo; dynamic; + protected + procedure Change; override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: AnsiChar); override; + procedure Loaded; override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function ExecuteAction(Action: TBasicAction): Boolean; override; + procedure LoadMemo; virtual; + function UpdateAction(Action: TBasicAction): Boolean; override; + function UseRightToLeftAlignment: Boolean; override; + property Field: TField read GetField; + published + property Align; + property Alignment; + property Anchors; + property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property Color; + property Constraints; + property Ctl3D; + property DataField: WideString read GetDataField write SetDataField; + property DataSource: TDataSource read GetDataSource write SetDataSource; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property HideScrollBars; + property ImeMode; + property ImeName; + property MaxLength; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PlainText; + property PopupMenu; + property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; + property ScrollBars; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property WantReturns; + property WantTabs; + property WordWrap; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnResizeRequest; + property OnSelectionChange; + property OnProtectChange; + property OnSaveClipboard; + property OnStartDock; + property OnStartDrag; + end; + +type +{TNT-WARN TDBMemo} + TTntDBMemo = class(TTntCustomMemo) + private + FDataLink: TFieldDataLink; + FAutoDisplay: Boolean; + FFocused: Boolean; + FMemoLoaded: Boolean; + FPaintControl: TTntPaintControl; + procedure DataChange(Sender: TObject); + procedure EditingChange(Sender: TObject); + function GetDataField: WideString; + function GetDataSource: TDataSource; + function GetField: TField; + function GetReadOnly: Boolean; + procedure SetDataField(const Value: WideString); + procedure SetDataSource(Value: TDataSource); + procedure SetReadOnly(Value: Boolean); + procedure SetAutoDisplay(Value: Boolean); + procedure SetFocused(Value: Boolean); + procedure UpdateData(Sender: TObject); + procedure WMCut(var Message: TMessage); message WM_CUT; + procedure WMPaste(var Message: TMessage); message WM_PASTE; + procedure WMUndo(var Message: TMessage); message WM_UNDO; + procedure CMEnter(var Message: TCMEnter); message CM_ENTER; + procedure CMExit(var Message: TCMExit); message CM_EXIT; + procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; + protected + procedure Change; override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; + procedure Loaded; override; + procedure Notification(AComponent: TComponent; + Operation: TOperation); override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function ExecuteAction(Action: TBasicAction): Boolean; override; + procedure LoadMemo; virtual; + function UpdateAction(Action: TBasicAction): Boolean; override; + function UseRightToLeftAlignment: Boolean; override; + property Field: TField read GetField; + published + property Align; + property Alignment; + property Anchors; + property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property Color; + property Constraints; + property Ctl3D; + property DataField: WideString read GetDataField write SetDataField; + property DataSource: TDataSource read GetDataSource write SetDataSource; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property ImeMode; + property ImeName; + property MaxLength; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; + property ScrollBars; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property WantReturns; + property WantTabs; + property WordWrap; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +{ TDBRadioGroup } +type + TTntDBRadioGroup = class(TTntCustomRadioGroup) + private + FDataLink: TFieldDataLink; + FValue: WideString; + FValues: TTntStrings; + FInSetValue: Boolean; + FOnChange: TNotifyEvent; + procedure DataChange(Sender: TObject); + procedure UpdateData(Sender: TObject); + function GetDataField: WideString; + function GetDataSource: TDataSource; + function GetField: TField; + function GetReadOnly: Boolean; + function GetButtonValue(Index: Integer): WideString; + procedure SetDataField(const Value: WideString); + procedure SetDataSource(Value: TDataSource); + procedure SetReadOnly(Value: Boolean); + procedure SetValue(const Value: WideString); + procedure SetItems(Value: TTntStrings); + procedure SetValues(Value: TTntStrings); + procedure CMExit(var Message: TCMExit); message CM_EXIT; + procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; + protected + procedure Change; dynamic; + procedure Click; override; + procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; + function CanModify: Boolean; override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + property DataLink: TFieldDataLink read FDataLink; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function ExecuteAction(Action: TBasicAction): Boolean; override; + function UpdateAction(Action: TBasicAction): Boolean; override; + function UseRightToLeftAlignment: Boolean; override; + property Field: TField read GetField; + property ItemIndex; + property Value: WideString read FValue write SetValue; + published + property Align; + property Anchors; + property BiDiMode; + property Caption; + property Color; + property Columns; + property Constraints; + property Ctl3D; + property DataField: WideString read GetDataField write SetDataField; + property DataSource: TDataSource read GetDataSource write SetDataSource; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property Items write SetItems; + {$IFDEF COMPILER_7_UP} + property ParentBackground; + {$ENDIF} + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; + property ShowHint; + property TabOrder; + property TabStop; + property Values: TTntStrings read FValues write SetValues; + property Visible; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnStartDock; + property OnStartDrag; + end; + +implementation + +uses + Forms, SysUtils, Graphics, Variants, TntDB, + TntActnList, TntGraphics, TntSysUtils, RichEdit, Mask; + +function FieldIsBlobLike(Field: TField): Boolean; +begin + Result := False; + if Assigned(Field) then begin + if (Field.IsBlob) + or (Field.DataType in [Low(TBlobType).. High(TBlobType)]) then + Result := True + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) + and (Field.Size = MaxInt) then + Result := True; { wide string field filling in for a blob field } + end; +end; + +{ TTntPaintControl } + +type + TAccessWinControl = class(TWinControl); + +constructor TTntPaintControl.Create(AOwner: TWinControl; const ClassName: WideString); +begin + FOwner := AOwner; + FClassName := ClassName; +end; + +destructor TTntPaintControl.Destroy; +begin + DestroyHandle; +end; + +procedure TTntPaintControl.DestroyHandle; +begin + if FHandle <> 0 then DestroyWindow(FHandle); + Classes.FreeObjectInstance(FObjectInstance); + FHandle := 0; + FObjectInstance := nil; +end; + +function TTntPaintControl.GetHandle: HWnd; +var + Params: TCreateParams; +begin + if FHandle = 0 then + begin + FObjectInstance := Classes.MakeObjectInstance(WndProc); + TAccessWinControl(FOwner).CreateParams(Params); + Params.Style := Params.Style and not (WS_HSCROLL or WS_VSCROLL); + if (not Win32PlatformIsUnicode) then begin + with Params do + FHandle := CreateWindowEx(ExStyle, PAnsiChar(AnsiString(FClassName)), + PAnsiChar(TAccessWinControl(FOwner).Text), Style or WS_VISIBLE, + X, Y, Width, Height, Application.Handle, 0, HInstance, nil); + FDefWindowProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC)); + SetWindowLong(FHandle, GWL_WNDPROC, Integer(FObjectInstance)); + end else begin + with Params do + FHandle := CreateWindowExW(ExStyle, PWideChar(FClassName), + PWideChar(TntControl_GetText(FOwner)), Style or WS_VISIBLE, + X, Y, Width, Height, Application.Handle, 0, HInstance, nil); + FDefWindowProc := Pointer(GetWindowLongW(FHandle, GWL_WNDPROC)); + SetWindowLongW(FHandle, GWL_WNDPROC, Integer(FObjectInstance)); + end; + SendMessage(FHandle, WM_SETFONT, Integer(TAccessWinControl(FOwner).Font.Handle), 1); + end; + Result := FHandle; +end; + +procedure TTntPaintControl.SetCtl3DButton(Value: Boolean); +begin + if FHandle <> 0 then DestroyHandle; + FCtl3DButton := Value; +end; + +procedure TTntPaintControl.WndProc(var Message: TMessage); +begin + with Message do + if (Msg >= CN_CTLCOLORMSGBOX) and (Msg <= CN_CTLCOLORSTATIC) then + Result := FOwner.Perform(Msg, WParam, LParam) + else if (not Win32PlatformIsUnicode) then + Result := CallWindowProcA(FDefWindowProc, FHandle, Msg, WParam, LParam) + else + Result := CallWindowProcW(FDefWindowProc, FHandle, Msg, WParam, LParam); +end; + +{ THackFieldDataLink } +type + THackFieldDataLink_D6_D7_D9 = class(TDataLink) + protected + FxxxField: TField; + FxxxFieldName: string{TNT-ALLOW string}; + FxxxControl: TComponent; + FxxxEditing: Boolean; + FModified: Boolean; + end; + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackFieldDataLink = THackFieldDataLink_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackFieldDataLink = THackFieldDataLink_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackFieldDataLink = THackFieldDataLink_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackFieldDataLink = class(TDataLink) + protected + FxxxField: TField; + FxxxFieldName: WideString; + FxxxControl: TComponent; + FxxxEditing: Boolean; + FModified: Boolean; + end; +{$ENDIF} + +{ TTntDBEdit } + +type + THackDBEdit_D6_D7_D9 = class(TCustomMaskEdit) + protected + FDataLink: TFieldDataLink; + FCanvas: TControlCanvas; + FAlignment: TAlignment; + FFocused: Boolean; + end; + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackDBEdit = THackDBEdit_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackDBEdit = THackDBEdit_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackDBEdit = THackDBEdit_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackDBEdit = THackDBEdit_D6_D7_D9; +{$ENDIF} + +constructor TTntDBEdit.Create(AOwner: TComponent); +begin + inherited; + InheritedDataChange := THackDBEdit(Self).FDataLink.OnDataChange; + THackDBEdit(Self).FDataLink.OnDataChange := DataChange; + THackDBEdit(Self).FDataLink.OnUpdateData := UpdateData; +end; + +procedure TTntDBEdit.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'EDIT'); +end; + +procedure TTntDBEdit.CreateWnd; +begin + inherited; + TntCustomEdit_AfterInherited_CreateWnd(Self, FPasswordChar); +end; + +procedure TTntDBEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDBEdit.GetSelStart: Integer; +begin + Result := TntCustomEdit_GetSelStart(Self); +end; + +procedure TTntDBEdit.SetSelStart(const Value: Integer); +begin + TntCustomEdit_SetSelStart(Self, Value); +end; + +function TTntDBEdit.GetSelLength: Integer; +begin + Result := TntCustomEdit_GetSelLength(Self); +end; + +procedure TTntDBEdit.SetSelLength(const Value: Integer); +begin + TntCustomEdit_SetSelLength(Self, Value); +end; + +function TTntDBEdit.GetSelText: WideString; +begin + Result := TntCustomEdit_GetSelText(Self); +end; + +procedure TTntDBEdit.SetSelText(const Value: WideString); +begin + TntCustomEdit_SetSelText(Self, Value); +end; + +function TTntDBEdit.GetPasswordChar: WideChar; +begin + Result := TntCustomEdit_GetPasswordChar(Self, FPasswordChar) +end; + +procedure TTntDBEdit.SetPasswordChar(const Value: WideChar); +begin + TntCustomEdit_SetPasswordChar(Self, FPasswordChar, Value); +end; + +function TTntDBEdit.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntDBEdit.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntDBEdit.DataChange(Sender: TObject); +begin + with THackDBEdit(Self), Self do begin + if Field = nil then + InheritedDataChange(Sender) + else begin + if FAlignment <> Field.Alignment then + begin + EditText := ''; {forces update} + FAlignment := Field.Alignment; + end; + EditMask := Field.EditMask; + if not (csDesigning in ComponentState) then + begin + if (Field.DataType in [ftString, ftWideString]) and (MaxLength = 0) then + MaxLength := Field.Size; + end; + if FFocused and FDataLink.CanModify then + Text := GetWideText(Field) + else + begin + Text := GetWideDisplayText(Field); + if FDataLink.Editing and THackFieldDataLink(FDataLink).FModified then + Modified := True; + end; + end; + end; +end; + +procedure TTntDBEdit.UpdateData(Sender: TObject); +begin + ValidateEdit; + SetWideText(Field, Text); +end; + +procedure TTntDBEdit.CMEnter(var Message: TCMEnter); +var + SaveFarEast: Boolean; +begin + SaveFarEast := SysLocale.FarEast; + try + SysLocale.FarEast := False; + inherited; // inherited tries to work around Win95 FarEast bug, but introduces others + finally + SysLocale.FarEast := SaveFarEast; + end; +end; + +function TTntDBEdit.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntDBEdit.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntDBEdit.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntDBEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntDBEdit.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntDBEdit.WMPaint(var Message: TWMPaint); +const + AlignStyle : array[Boolean, TAlignment] of DWORD = + ((WS_EX_LEFT, WS_EX_RIGHT, WS_EX_LEFT), + (WS_EX_RIGHT, WS_EX_LEFT, WS_EX_LEFT)); +var + ALeft: Integer; + _Margins: TPoint; + R: TRect; + DC: HDC; + PS: TPaintStruct; + S: WideString; + AAlignment: TAlignment; + I: Integer; +begin + with THackDBEdit(Self), Self do begin + AAlignment := FAlignment; + if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment); + if ((AAlignment = taLeftJustify) or FFocused) and (not (csPaintCopy in ControlState)) + or (not Win32PlatformIsUnicode) then + begin + inherited; + Exit; + end; + { Since edit controls do not handle justification unless multi-line (and + then only poorly) we will draw right and center justify manually unless + the edit has the focus. } + if FCanvas = nil then + begin + FCanvas := TControlCanvas.Create; + FCanvas.Control := Self; + end; + DC := Message.DC; + if DC = 0 then DC := BeginPaint(Handle, PS); + FCanvas.Handle := DC; + try + FCanvas.Font := Font; + with FCanvas do + begin + R := ClientRect; + if not (NewStyleControls and Ctl3D) and (BorderStyle = bsSingle) then + begin + Brush.Color := clWindowFrame; + FrameRect(R); + InflateRect(R, -1, -1); + end; + Brush.Color := Color; + if not Enabled then + Font.Color := clGrayText; + if (csPaintCopy in ControlState) and (Field <> nil) then + begin + S := GetWideDisplayText(Field); + case CharCase of + ecUpperCase: + S := Tnt_WideUpperCase(S); + ecLowerCase: + S := Tnt_WideLowerCase(S); + end; + end else + S := Text { EditText? }; + if PasswordChar <> #0 then + for I := 1 to Length(S) do S[I] := PasswordChar; + _Margins := GetTextMargins; + case AAlignment of + taLeftJustify: ALeft := _Margins.X; + taRightJustify: ALeft := ClientWidth - WideCanvasTextWidth(FCanvas, S) - _Margins.X - 1; + else + ALeft := (ClientWidth - WideCanvasTextWidth(FCanvas, S)) div 2; + end; + if SysLocale.MiddleEast then UpdateTextFlags; + WideCanvasTextRect(FCanvas, R, ALeft, _Margins.Y, S); + end; + finally + FCanvas.Handle := 0; + if Message.DC = 0 then EndPaint(Handle, PS); + end; + end; +end; + +function TTntDBEdit.GetTextMargins: TPoint; +var + DC: HDC; + SaveFont: HFont; + I: Integer; + SysMetrics, Metrics: TTextMetric; +begin + if NewStyleControls then + begin + if BorderStyle = bsNone then I := 0 else + if Ctl3D then I := 1 else I := 2; + Result.X := SendMessage(Handle, EM_GETMARGINS, 0, 0) and $0000FFFF + I; + Result.Y := I; + end else + begin + if BorderStyle = bsNone then I := 0 else + begin + DC := GetDC(0); + GetTextMetrics(DC, SysMetrics); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + I := SysMetrics.tmHeight; + if I > Metrics.tmHeight then I := Metrics.tmHeight; + I := I div 4; + end; + Result.X := I; + Result.Y := I; + end; +end; + +{ TTntDBText } + +constructor TTntDBText.Create(AOwner: TComponent); +begin + inherited; + FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; + InheritedDataChange := FDataLink.OnDataChange; + FDataLink.OnDataChange := DataChange; +end; + +destructor TTntDBText.Destroy; +begin + FDataLink := nil; + inherited; +end; + +procedure TTntDBText.CMDialogChar(var Message: TCMDialogChar); +begin + TntLabel_CMDialogChar(Self, Message, Caption); +end; + +function TTntDBText.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntDBText.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntDBText.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntDBText.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDBText.GetLabelText: WideString; +begin + if csPaintCopy in ControlState then + Result := GetFieldText + else + Result := Caption; +end; + +procedure TTntDBText.DoDrawText(var Rect: TRect; Flags: Integer); +begin + if not TntLabel_DoDrawText(Self, Rect, Flags, GetLabelText) then + inherited; +end; + +function TTntDBText.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntDBText.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntDBText.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntDBText.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntDBText.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntDBText.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntDBText.GetFieldText: WideString; +begin + if Field <> nil then + Result := GetWideDisplayText(Field) + else + if csDesigning in ComponentState then Result := Name else Result := ''; +end; + +procedure TTntDBText.DataChange(Sender: TObject); +begin + Caption := GetFieldText; +end; + +{ TTntCustomDBComboBox } + +constructor TTntCustomDBComboBox.Create(AOwner: TComponent); +begin + inherited; + FItems := TTntComboBoxStrings.Create; + TTntComboBoxStrings(FItems).ComboBox := Self; + FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; + FDataLink.OnDataChange := DataChange; + FDataLink.OnUpdateData := UpdateData; + FDataLink.OnEditingChange := EditingChange; +end; + +destructor TTntCustomDBComboBox.Destroy; +begin + FreeAndNil(FItems); + FreeAndNil(FSaveItems); + FDataLink := nil; + inherited; +end; + +procedure TTntCustomDBComboBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'COMBOBOX'); +end; + +procedure TTntCustomDBComboBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +type + TAccessCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}); + +procedure TTntCustomDBComboBox.CreateWnd; +var + PreInheritedAnsiText: AnsiString; +begin + PreInheritedAnsiText := TAccessCustomComboBox(Self).Text; + inherited; + TntCombo_AfterInherited_CreateWnd(Self, Items, FSaveItems, FSaveItemIndex, PreInheritedAnsiText); +end; + +procedure TTntCustomDBComboBox.DestroyWnd; +var + SavedText: WideString; +begin + if not (csDestroyingHandle in ControlState) then begin { avoid recursion when parent is TToolBar and system font changes. } + TntCombo_BeforeInherited_DestroyWnd(Self, Items, FSaveItems, ItemIndex, FSaveItemIndex, SavedText); + inherited; + TntControl_SetStoredText(Self, SavedText); + end; +end; + +procedure TTntCustomDBComboBox.SetReadOnly; +begin + if (Style in [csDropDown, csSimple]) and HandleAllocated then + SendMessage(EditHandle, EM_SETREADONLY, Ord(not FDataLink.CanModify), 0); +end; + +procedure TTntCustomDBComboBox.EditingChange(Sender: TObject); +begin + SetReadOnly; +end; + +procedure TTntCustomDBComboBox.CMEnter(var Message: TCMEnter); +var + SaveFarEast: Boolean; +begin + SaveFarEast := SysLocale.FarEast; + try + SysLocale.FarEast := False; + inherited; // inherited tries to work around Win95 FarEast bug, but introduces others + finally + SysLocale.FarEast := SaveFarEast; + end; +end; + +procedure TTntCustomDBComboBox.WndProc(var Message: TMessage); +begin + if (not (csDesigning in ComponentState)) + and (Message.Msg = CB_SHOWDROPDOWN) + and (Message.WParam = 0) + and (not FDataLink.Editing) then begin + DataChange(Self); {Restore text} + Dispatch(Message); {Do NOT call inherited!} + end else + inherited WndProc(Message); +end; + +procedure TTntCustomDBComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); +begin + if not TntCombo_ComboWndProc(Self, Message, ComboWnd, ComboProc, DoEditCharMsg) then + inherited; +end; + +procedure TTntCustomDBComboBox.KeyPress(var Key: AnsiChar); +var + SaveAutoComplete: Boolean; +begin + TntCombo_BeforeKeyPress(Self, SaveAutoComplete); + try + inherited; + finally + TntCombo_AfterKeyPress(Self, SaveAutoComplete); + end; +end; + +procedure TTntCustomDBComboBox.DoEditCharMsg(var Message: TWMChar); +begin + TntCombo_AutoCompleteKeyPress(Self, Items, Message, + GetAutoComplete_UniqueMatchOnly, GetAutoComplete_PreserveDataEntryCase); +end; + +procedure TTntCustomDBComboBox.WMChar(var Message: TWMChar); +begin + TntCombo_AutoSearchKeyPress(Self, Items, Message, FFilter, FLastTime); + inherited; +end; + +function TTntCustomDBComboBox.GetItems: TTntStrings; +begin + Result := FItems; +end; + +procedure TTntCustomDBComboBox.SetItems(const Value: TTntStrings); +begin + FItems.Assign(Value); + DataChange(Self); +end; + +function TTntCustomDBComboBox.GetSelStart: Integer; +begin + Result := TntCombo_GetSelStart(Self); +end; + +procedure TTntCustomDBComboBox.SetSelStart(const Value: Integer); +begin + TntCombo_SetSelStart(Self, Value); +end; + +function TTntCustomDBComboBox.GetSelLength: Integer; +begin + Result := TntCombo_GetSelLength(Self); +end; + +procedure TTntCustomDBComboBox.SetSelLength(const Value: Integer); +begin + TntCombo_SetSelLength(Self, Value); +end; + +function TTntCustomDBComboBox.GetSelText: WideString; +begin + Result := TntCombo_GetSelText(Self); +end; + +procedure TTntCustomDBComboBox.SetSelText(const Value: WideString); +begin + TntCombo_SetSelText(Self, Value); +end; + +function TTntCustomDBComboBox.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomDBComboBox.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomDBComboBox.CNCommand(var Message: TWMCommand); +begin + if not TntCombo_CNCommand(Self, Items, Message) then + inherited; +end; + +function TTntCustomDBComboBox.GetFieldValue: Variant; +begin + Result := Field.Value; +end; + +procedure TTntCustomDBComboBox.SetFieldValue(const Value: Variant); +begin + Field.Value := Value; +end; + +procedure TTntCustomDBComboBox.DataChange(Sender: TObject); +begin + if not (Style = csSimple) and DroppedDown then Exit; + if Field <> nil then + SetComboValue(GetFieldValue) + else + if csDesigning in ComponentState then + SetComboValue(Name) + else + SetComboValue(Null); +end; + +procedure TTntCustomDBComboBox.UpdateData(Sender: TObject); +begin + SetFieldValue(GetComboValue); +end; + +function TTntCustomDBComboBox.GetAutoComplete_PreserveDataEntryCase: Boolean; +begin + Result := True; +end; + +function TTntCustomDBComboBox.GetAutoComplete_UniqueMatchOnly: Boolean; +begin + Result := False; +end; + +function TTntCustomDBComboBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomDBComboBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomDBComboBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomDBComboBox.AddItem(const Item: WideString; AObject: TObject); +begin + TntComboBox_AddItem(Items, Item, AObject); +end; + +procedure TTntCustomDBComboBox.CopySelection(Destination: TCustomListControl); +begin + TntComboBox_CopySelection(Items, ItemIndex, Destination); +end; + +procedure TTntCustomDBComboBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomDBComboBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{$IFDEF DELPHI_7} // fix for Delphi 7 only +function TTntCustomDBComboBox.GetItemsClass: TCustomComboBoxStringsClass; +begin + Result := TD7PatchedComboBoxStrings; +end; +{$ENDIF} + +{ TTntDBComboBox } + +function TTntDBComboBox.GetFieldValue: Variant; +begin + Result := GetWideText(Field); +end; + +procedure TTntDBComboBox.SetFieldValue(const Value: Variant); +begin + SetWideText(Field, Value); +end; + +procedure TTntDBComboBox.SetComboValue(const Value: Variant); +var + I: Integer; + Redraw: Boolean; + OldValue: WideString; + NewValue: WideString; +begin + OldValue := VarToWideStr(GetComboValue); + NewValue := VarToWideStr(Value); + + if NewValue <> OldValue then + begin + if Style <> csDropDown then + begin + Redraw := (Style <> csSimple) and HandleAllocated; + if Redraw then Items.BeginUpdate; + try + if NewValue = '' then I := -1 else I := Items.IndexOf(NewValue); + ItemIndex := I; + finally + Items.EndUpdate; + end; + if I >= 0 then Exit; + end; + if Style in [csDropDown, csSimple] then Text := NewValue; + end; +end; + +function TTntDBComboBox.GetComboValue: Variant; +var + I: Integer; +begin + if Style in [csDropDown, csSimple] then Result := Text else + begin + I := ItemIndex; + if I < 0 then Result := '' else Result := Items[I]; + end; +end; + +{ TTntDBCheckBox } + +procedure TTntDBCheckBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntDBCheckBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDBCheckBox.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntDBCheckBox.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntDBCheckBox.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntDBCheckBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntDBCheckBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntDBCheckBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntDBCheckBox.Toggle; +var + FDataLink: TDataLink; +begin + inherited; + FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; + FDataLink.UpdateRecord; +end; + +procedure TTntDBCheckBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntDBCheckBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntDBRichEdit } + +constructor TTntDBRichEdit.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + inherited ReadOnly := True; + FAutoDisplay := True; + FDataLink := TFieldDataLink.Create; + FDataLink.Control := Self; + FDataLink.OnDataChange := DataChange; + FDataLink.OnEditingChange := EditingChange; + FDataLink.OnUpdateData := UpdateData; +end; + +destructor TTntDBRichEdit.Destroy; +begin + FDataLink.Free; + FDataLink := nil; + inherited Destroy; +end; + +procedure TTntDBRichEdit.Loaded; +begin + inherited Loaded; + if (csDesigning in ComponentState) then + DataChange(Self) +end; + +procedure TTntDBRichEdit.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (Operation = opRemove) and (FDataLink <> nil) and + (AComponent = DataSource) then DataSource := nil; +end; + +function TTntDBRichEdit.UseRightToLeftAlignment: Boolean; +begin + Result := DBUseRightToLeftAlignment(Self, Field); +end; + +procedure TTntDBRichEdit.BeginEditing; +begin + if not FDataLink.Editing then + try + if FieldIsBlobLike(Field) then + FDataSave := Field.AsString{TNT-ALLOW AsString}; + FDataLink.Edit; + finally + FDataSave := ''; + end; +end; + +procedure TTntDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited KeyDown(Key, Shift); + if FMemoLoaded then + begin + if (Key = VK_DELETE) or (Key = VK_BACK) or + ((Key = VK_INSERT) and (ssShift in Shift)) or + (((Key = Ord('V')) or (Key = Ord('X'))) and (ssCtrl in Shift)) then + BeginEditing; + end; +end; + +procedure TTntDBRichEdit.KeyPress(var Key: AnsiChar); +begin + inherited KeyPress(Key); + if FMemoLoaded then + begin + if (Key in [#32..#255]) and (Field <> nil) and + not Field.IsValidChar(Key) then + begin + MessageBeep(0); + Key := #0; + end; + case Key of + ^H, ^I, ^J, ^M, ^V, ^X, #32..#255: + BeginEditing; + #27: + FDataLink.Reset; + end; + end else + begin + if Key = #13 then LoadMemo; + Key := #0; + end; +end; + +procedure TTntDBRichEdit.Change; +begin + if FMemoLoaded then + FDataLink.Modified; + FMemoLoaded := True; + inherited Change; +end; + +procedure TTntDBRichEdit.CNNotify(var Message: TWMNotify); +begin + inherited; + if Message.NMHdr^.code = EN_PROTECTED then + Message.Result := 0 { allow the operation (otherwise the control might appear stuck) } +end; + +function TTntDBRichEdit.GetDataSource: TDataSource; +begin + Result := FDataLink.DataSource; +end; + +procedure TTntDBRichEdit.SetDataSource(Value: TDataSource); +begin + FDataLink.DataSource := Value; + if Value <> nil then Value.FreeNotification(Self); +end; + +function TTntDBRichEdit.GetDataField: WideString; +begin + Result := FDataLink.FieldName; +end; + +procedure TTntDBRichEdit.SetDataField(const Value: WideString); +begin + FDataLink.FieldName := Value; +end; + +function TTntDBRichEdit.GetReadOnly: Boolean; +begin + Result := FDataLink.ReadOnly; +end; + +procedure TTntDBRichEdit.SetReadOnly(Value: Boolean); +begin + FDataLink.ReadOnly := Value; +end; + +function TTntDBRichEdit.GetField: TField; +begin + Result := FDataLink.Field; +end; + +procedure TTntDBRichEdit.InternalLoadMemo; +var + Stream: TStringStream{TNT-ALLOW TStringStream}; +begin + if PlainText then + Text := GetAsWideString(Field) + else begin + Stream := TStringStream{TNT-ALLOW TStringStream}.Create(Field.AsString{TNT-ALLOW AsString}); + try + Lines.LoadFromStream(Stream); + finally + Stream.Free; + end; + end; +end; + +procedure TTntDBRichEdit.LoadMemo; +begin + if not FMemoLoaded and Assigned(Field) and FieldIsBlobLike(Field) then + begin + try + InternalLoadMemo; + FMemoLoaded := True; + except + { Rich Edit Load failure } + on E:EOutOfResources do + Lines.Text := WideFormat('(%s)', [E.Message]); + end; + EditingChange(Self); + end; +end; + +procedure TTntDBRichEdit.DataChange(Sender: TObject); +begin + if Field <> nil then + if FieldIsBlobLike(Field) then + begin + if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then + begin + { Check if the data has changed since we read it the first time } + if (FDataSave <> '') and (FDataSave = Field.AsString{TNT-ALLOW AsString}) then Exit; + FMemoLoaded := False; + LoadMemo; + end else + begin + Text := WideFormat('(%s)', [Field.DisplayName]); + FMemoLoaded := False; + end; + end else + begin + if FFocused and FDataLink.CanModify then + Text := GetWideText(Field) + else + Text := GetWideDisplayText(Field); + FMemoLoaded := True; + end + else + begin + if csDesigning in ComponentState then Text := Name else Text := ''; + FMemoLoaded := False; + end; + if HandleAllocated then + RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME); +end; + +procedure TTntDBRichEdit.EditingChange(Sender: TObject); +begin + inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded); +end; + +procedure TTntDBRichEdit.InternalSaveMemo; +var + Stream: TStringStream{TNT-ALLOW TStringStream}; +begin + if PlainText then + SetAsWideString(Field, Text) + else begin + Stream := TStringStream{TNT-ALLOW TStringStream}.Create(''); + try + Lines.SaveToStream(Stream); + Field.AsString{TNT-ALLOW AsString} := Stream.DataString; + finally + Stream.Free; + end; + end; +end; + +procedure TTntDBRichEdit.UpdateData(Sender: TObject); +begin + if FieldIsBlobLike(Field) then + InternalSaveMemo + else + SetAsWideString(Field, Text); +end; + +procedure TTntDBRichEdit.SetFocused(Value: Boolean); +begin + if FFocused <> Value then + begin + FFocused := Value; + if not Assigned(Field) or not FieldIsBlobLike(Field) then + FDataLink.Reset; + end; +end; + +procedure TTntDBRichEdit.CMEnter(var Message: TCMEnter); +begin + SetFocused(True); + inherited; +end; + +procedure TTntDBRichEdit.CMExit(var Message: TCMExit); +begin + try + FDataLink.UpdateRecord; + except + SetFocus; + raise; + end; + SetFocused(False); + inherited; +end; + +procedure TTntDBRichEdit.SetAutoDisplay(Value: Boolean); +begin + if FAutoDisplay <> Value then + begin + FAutoDisplay := Value; + if Value then LoadMemo; + end; +end; + +procedure TTntDBRichEdit.WMLButtonDblClk(var Message: TWMLButtonDblClk); +begin + if not FMemoLoaded then LoadMemo else inherited; +end; + +procedure TTntDBRichEdit.WMCut(var Message: TMessage); +begin + BeginEditing; + inherited; +end; + +procedure TTntDBRichEdit.WMPaste(var Message: TMessage); +begin + BeginEditing; + inherited; +end; + +procedure TTntDBRichEdit.CMGetDataLink(var Message: TMessage); +begin + Message.Result := Integer(FDataLink); +end; + +function TTntDBRichEdit.ExecuteAction(Action: TBasicAction): Boolean; +begin + Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and + FDataLink.ExecuteAction(Action); +end; + +function TTntDBRichEdit.UpdateAction(Action: TBasicAction): Boolean; +begin + Result := inherited UpdateAction(Action) or (FDataLink <> nil) and + FDataLink.UpdateAction(Action); +end; + +{ TTntDBMemo } + +constructor TTntDBMemo.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + inherited ReadOnly := True; + ControlStyle := ControlStyle + [csReplicatable]; + FAutoDisplay := True; + FDataLink := TFieldDataLink.Create; + FDataLink.Control := Self; + FDataLink.OnDataChange := DataChange; + FDataLink.OnEditingChange := EditingChange; + FDataLink.OnUpdateData := UpdateData; + FPaintControl := TTntPaintControl.Create(Self, 'EDIT'); +end; + +destructor TTntDBMemo.Destroy; +begin + FPaintControl.Free; + FDataLink.Free; + FDataLink := nil; + inherited Destroy; +end; + +procedure TTntDBMemo.Loaded; +begin + inherited Loaded; + if (csDesigning in ComponentState) then DataChange(Self); +end; + +procedure TTntDBMemo.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (FDataLink <> nil) and + (AComponent = DataSource) then DataSource := nil; +end; + +function TTntDBMemo.UseRightToLeftAlignment: Boolean; +begin + Result := DBUseRightToLeftAlignment(Self, Field); +end; + +procedure TTntDBMemo.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited KeyDown(Key, Shift); + if FMemoLoaded then + begin + if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then + FDataLink.Edit; + end; +end; + +procedure TTntDBMemo.KeyPress(var Key: Char{TNT-ALLOW Char}); +begin + inherited KeyPress(Key); + if FMemoLoaded then + begin + if (Key in [#32..#255]) and (FDataLink.Field <> nil) and + not FDataLink.Field.IsValidChar(Key) then + begin + MessageBeep(0); + Key := #0; + end; + case Key of + ^H, ^I, ^J, ^M, ^V, ^X, #32..#255: + FDataLink.Edit; + #27: + FDataLink.Reset; + end; + end else + begin + if Key = #13 then LoadMemo; + Key := #0; + end; +end; + +procedure TTntDBMemo.Change; +begin + if FMemoLoaded then FDataLink.Modified; + FMemoLoaded := True; + inherited Change; +end; + +function TTntDBMemo.GetDataSource: TDataSource; +begin + Result := FDataLink.DataSource; +end; + +procedure TTntDBMemo.SetDataSource(Value: TDataSource); +begin + if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then + FDataLink.DataSource := Value; + if Value <> nil then Value.FreeNotification(Self); +end; + +function TTntDBMemo.GetDataField: WideString; +begin + Result := FDataLink.FieldName; +end; + +procedure TTntDBMemo.SetDataField(const Value: WideString); +begin + FDataLink.FieldName := Value; +end; + +function TTntDBMemo.GetReadOnly: Boolean; +begin + Result := FDataLink.ReadOnly; +end; + +procedure TTntDBMemo.SetReadOnly(Value: Boolean); +begin + FDataLink.ReadOnly := Value; +end; + +function TTntDBMemo.GetField: TField; +begin + Result := FDataLink.Field; +end; + +procedure TTntDBMemo.LoadMemo; +begin + if not FMemoLoaded and Assigned(FDataLink.Field) and FieldIsBlobLike(FDataLink.Field) then + begin + try + Lines.Text := GetAsWideString(FDataLink.Field); + FMemoLoaded := True; + except + { Memo too large } + on E:EInvalidOperation do + Lines.Text := WideFormat('(%s)', [E.Message]); + end; + EditingChange(Self); + end; +end; + +procedure TTntDBMemo.DataChange(Sender: TObject); +begin + if FDataLink.Field <> nil then + if FieldIsBlobLike(FDataLink.Field) then + begin + if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then + begin + FMemoLoaded := False; + LoadMemo; + end else + begin + Text := WideFormat('(%s)', [FDataLink.Field.DisplayName]); + FMemoLoaded := False; + EditingChange(Self); + end; + end else + begin + if FFocused and FDataLink.CanModify then + Text := GetWideText(FDataLink.Field) + else + Text := GetWideDisplayText(FDataLink.Field); + FMemoLoaded := True; + end + else + begin + if csDesigning in ComponentState then Text := Name else Text := ''; + FMemoLoaded := False; + end; + if HandleAllocated then + RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME); +end; + +procedure TTntDBMemo.EditingChange(Sender: TObject); +begin + inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded); +end; + +procedure TTntDBMemo.UpdateData(Sender: TObject); +begin + SetAsWideString(FDataLink.Field, Text); +end; + +procedure TTntDBMemo.SetFocused(Value: Boolean); +begin + if FFocused <> Value then + begin + FFocused := Value; + if not Assigned(FDataLink.Field) or not FieldIsBlobLike(FDataLink.Field) then + FDataLink.Reset; + end; +end; + +procedure TTntDBMemo.WndProc(var Message: TMessage); +begin + with Message do + if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or + (Msg = CM_FONTCHANGED) then FPaintControl.DestroyHandle; + inherited; +end; + +procedure TTntDBMemo.CMEnter(var Message: TCMEnter); +begin + SetFocused(True); + inherited; +end; + +procedure TTntDBMemo.CMExit(var Message: TCMExit); +begin + try + FDataLink.UpdateRecord; + except + SetFocus; + raise; + end; + SetFocused(False); + inherited; +end; + +procedure TTntDBMemo.SetAutoDisplay(Value: Boolean); +begin + if FAutoDisplay <> Value then + begin + FAutoDisplay := Value; + if Value then LoadMemo; + end; +end; + +procedure TTntDBMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk); +begin + if not FMemoLoaded then LoadMemo else inherited; +end; + +procedure TTntDBMemo.WMCut(var Message: TMessage); +begin + FDataLink.Edit; + inherited; +end; + +procedure TTntDBMemo.WMUndo(var Message: TMessage); +begin + FDataLink.Edit; + inherited; +end; + +procedure TTntDBMemo.WMPaste(var Message: TMessage); +begin + FDataLink.Edit; + inherited; +end; + +procedure TTntDBMemo.CMGetDataLink(var Message: TMessage); +begin + Message.Result := Integer(FDataLink); +end; + +procedure TTntDBMemo.WMPaint(var Message: TWMPaint); +var + S: WideString; +begin + if not (csPaintCopy in ControlState) then + inherited + else begin + if FDataLink.Field <> nil then + if FieldIsBlobLike(FDataLink.Field) then + begin + if FAutoDisplay then + S := TntAdjustLineBreaks(GetAsWideString(FDataLink.Field)) else + S := WideFormat('(%s)', [FDataLink.Field.DisplayName]); + end else + S := GetWideDisplayText(FDataLink.Field); + if (not Win32PlatformIsUnicode) then + SendMessageA(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PAnsiChar(AnsiString(S)))) + else begin + SendMessageW(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PWideChar(S))); + end; + SendMessage(FPaintControl.Handle, WM_ERASEBKGND, Integer(Message.DC), 0); + SendMessage(FPaintControl.Handle, WM_PAINT, Integer(Message.DC), 0); + end; +end; + +function TTntDBMemo.ExecuteAction(Action: TBasicAction): Boolean; +begin + Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and + FDataLink.ExecuteAction(Action); +end; + +function TTntDBMemo.UpdateAction(Action: TBasicAction): Boolean; +begin + Result := inherited UpdateAction(Action) or (FDataLink <> nil) and + FDataLink.UpdateAction(Action); +end; + +{ TTntDBRadioGroup } + +constructor TTntDBRadioGroup.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FDataLink := TFieldDataLink.Create; + FDataLink.Control := Self; + FDataLink.OnDataChange := DataChange; + FDataLink.OnUpdateData := UpdateData; + FValues := TTntStringList.Create; +end; + +destructor TTntDBRadioGroup.Destroy; +begin + FDataLink.Free; + FDataLink := nil; + FValues.Free; + inherited Destroy; +end; + +procedure TTntDBRadioGroup.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (FDataLink <> nil) and + (AComponent = DataSource) then DataSource := nil; +end; + +function TTntDBRadioGroup.UseRightToLeftAlignment: Boolean; +begin + Result := inherited UseRightToLeftAlignment; +end; + +procedure TTntDBRadioGroup.DataChange(Sender: TObject); +begin + if FDataLink.Field <> nil then + Value := GetWideText(FDataLink.Field) else + Value := ''; +end; + +procedure TTntDBRadioGroup.UpdateData(Sender: TObject); +begin + if FDataLink.Field <> nil then + SetWideText(FDataLink.Field, Value); +end; + +function TTntDBRadioGroup.GetDataSource: TDataSource; +begin + Result := FDataLink.DataSource; +end; + +procedure TTntDBRadioGroup.SetDataSource(Value: TDataSource); +begin + FDataLink.DataSource := Value; + if Value <> nil then Value.FreeNotification(Self); +end; + +function TTntDBRadioGroup.GetDataField: WideString; +begin + Result := FDataLink.FieldName; +end; + +procedure TTntDBRadioGroup.SetDataField(const Value: WideString); +begin + FDataLink.FieldName := Value; +end; + +function TTntDBRadioGroup.GetReadOnly: Boolean; +begin + Result := FDataLink.ReadOnly; +end; + +procedure TTntDBRadioGroup.SetReadOnly(Value: Boolean); +begin + FDataLink.ReadOnly := Value; +end; + +function TTntDBRadioGroup.GetField: TField; +begin + Result := FDataLink.Field; +end; + +function TTntDBRadioGroup.GetButtonValue(Index: Integer): WideString; +begin + if (Index < FValues.Count) and (FValues[Index] <> '') then + Result := FValues[Index] + else if Index < Items.Count then + Result := Items[Index] + else + Result := ''; +end; + +procedure TTntDBRadioGroup.SetValue(const Value: WideString); +var + WasFocused: Boolean; + I, Index: Integer; +begin + if FValue <> Value then + begin + FInSetValue := True; + try + WasFocused := (ItemIndex > -1) and (Buttons[ItemIndex].Focused); + Index := -1; + for I := 0 to Items.Count - 1 do + if Value = GetButtonValue(I) then + begin + Index := I; + Break; + end; + ItemIndex := Index; + // Move the focus rect along with the selected index + if WasFocused then + Buttons[ItemIndex].SetFocus; + finally + FInSetValue := False; + end; + FValue := Value; + Change; + end; +end; + +procedure TTntDBRadioGroup.CMExit(var Message: TCMExit); +begin + try + FDataLink.UpdateRecord; + except + if ItemIndex >= 0 then + (Controls[ItemIndex] as TTntRadioButton).SetFocus else + (Controls[0] as TTntRadioButton).SetFocus; + raise; + end; + inherited; +end; + +procedure TTntDBRadioGroup.CMGetDataLink(var Message: TMessage); +begin + Message.Result := Integer(FDataLink); +end; + +procedure TTntDBRadioGroup.Click; +begin + if not FInSetValue then + begin + inherited Click; + if ItemIndex >= 0 then Value := GetButtonValue(ItemIndex); + if FDataLink.Editing then FDataLink.Modified; + end; +end; + +procedure TTntDBRadioGroup.SetItems(Value: TTntStrings); +begin + Items.Assign(Value); + DataChange(Self); +end; + +procedure TTntDBRadioGroup.SetValues(Value: TTntStrings); +begin + FValues.Assign(Value); + DataChange(Self); +end; + +procedure TTntDBRadioGroup.Change; +begin + if Assigned(FOnChange) then FOnChange(Self); +end; + +procedure TTntDBRadioGroup.KeyPress(var Key: Char{TNT-ALLOW Char}); +begin + inherited KeyPress(Key); + case Key of + #8, ' ': FDataLink.Edit; + #27: FDataLink.Reset; + end; +end; + +function TTntDBRadioGroup.CanModify: Boolean; +begin + Result := FDataLink.Edit; +end; + +function TTntDBRadioGroup.ExecuteAction(Action: TBasicAction): Boolean; +begin + Result := inherited ExecuteAction(Action) or (DataLink <> nil) and + DataLink.ExecuteAction(Action); +end; + +function TTntDBRadioGroup.UpdateAction(Action: TBasicAction): Boolean; +begin + Result := inherited UpdateAction(Action) or (DataLink <> nil) and + DataLink.UpdateAction(Action); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas new file mode 100644 index 0000000000..2664bf7b5a --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas @@ -0,0 +1,1175 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBGrids; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, TntClasses, Controls, Windows, Grids, DBGrids, Messages, DBCtrls, DB, TntStdCtrls; + +type +{TNT-WARN TColumnTitle} + TTntColumnTitle = class(TColumnTitle{TNT-ALLOW TColumnTitle}) + private + FCaption: WideString; + procedure SetInheritedCaption(const Value: AnsiString); + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function IsCaptionStored: Boolean; + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + procedure RestoreDefaults; override; + function DefaultCaption: WideString; + published + property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored; + end; + +{TNT-WARN TColumn} +type + TTntColumn = class(TColumn{TNT-ALLOW TColumn}) + private + FWidePickList: TTntStrings; + function GetWidePickList: TTntStrings; + procedure SetWidePickList(const Value: TTntStrings); + procedure HandlePickListChange(Sender: TObject); + function GetTitle: TTntColumnTitle; + procedure SetTitle(const Value: TTntColumnTitle); + protected + procedure DefineProperties(Filer: TFiler); override; + function CreateTitle: TColumnTitle{TNT-ALLOW TColumnTitle}; override; + public + destructor Destroy; override; + property WidePickList: TTntStrings read GetWidePickList write SetWidePickList; + published +{TNT-WARN PickList} + property PickList{TNT-ALLOW PickList}: TTntStrings read GetWidePickList write SetWidePickList; + property Title: TTntColumnTitle read GetTitle write SetTitle; + end; + + { TDBGridInplaceEdit adds support for a button on the in-place editor, + which can be used to drop down a table-based lookup list, a stringlist-based + pick list, or (if button style is esEllipsis) fire the grid event + OnEditButtonClick. } + +type + TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit} = class(TInplaceEditList) + private + {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + FDataList: TDBLookupListBox; // 1st field - Delphi/BCB 6 TCustomDBGrid assumes this + FUseDataList: Boolean; // 2nd field - Delphi/BCB 6 TCustomDBGrid assumes this + {$ENDIF} + {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + FDataList: TDBLookupListBox; // 1st field - Delphi 7 TCustomDBGrid assumes this + FUseDataList: Boolean; // 2nd field - Delphi 7 TCustomDBGrid assumes this + {$ENDIF} + {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + FDataList: TDBLookupListBox; // 1st field - Delphi 9 TCustomDBGrid assumes this + FUseDataList: Boolean; // 2nd field - Delphi 9 TCustomDBGrid assumes this + {$ENDIF} + {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + FDataList: TDBLookupListBox; // 1st field - Delphi 10 TCustomDBGrid assumes this + FUseDataList: Boolean; // 2nd field - Delphi 10 TCustomDBGrid assumes this + {$ENDIF} + FLookupSource: TDatasource; + FWidePickListBox: TTntCustomListbox; + function GetWidePickListBox: TTntCustomListbox; + protected + procedure CloseUp(Accept: Boolean); override; + procedure DoEditButtonClick; override; + procedure DropDown; override; + procedure UpdateContents; override; + property UseDataList: Boolean read FUseDataList; + public + constructor Create(Owner: TComponent); override; + property DataList: TDBLookupListBox read FDataList; + property WidePickListBox: TTntCustomListbox read GetWidePickListBox; + end; + +type +{TNT-WARN TDBGridInplaceEdit} + TTntDBGridInplaceEdit = class(TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}) + private + FInDblClick: Boolean; + FBlockSetText: Boolean; + procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; + protected + function GetText: WideString; virtual; + procedure SetText(const Value: WideString); virtual; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure UpdateContents; override; + procedure DblClick; override; + public + property Text: WideString read GetText write SetText; + end; + +{TNT-WARN TDBGridColumns} + TTntDBGridColumns = class(TDBGridColumns{TNT-ALLOW TDBGridColumns}) + private + function GetColumn(Index: Integer): TTntColumn; + procedure SetColumn(Index: Integer; const Value: TTntColumn); + public + function Add: TTntColumn; + property Items[Index: Integer]: TTntColumn read GetColumn write SetColumn; default; + end; + + TTntGridDataLink = class(TGridDataLink) + private + OriginalSetText: TFieldSetTextEvent; + procedure GridUpdateFieldText(Sender: TField; const Text: AnsiString); + protected + procedure UpdateData; override; + procedure RecordChanged(Field: TField); override; + end; + +{TNT-WARN TCustomDBGrid} + TTntCustomDBGrid = class(TCustomDBGrid{TNT-ALLOW TCustomDBGrid}) + private + FEditText: WideString; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Msg: TWMChar); message WM_CHAR; + function GetColumns: TTntDBGridColumns; + procedure SetColumns(const Value: TTntDBGridColumns); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure ShowEditorChar(Ch: WideChar); dynamic; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function CreateColumns: TDBGridColumns{TNT-ALLOW TDBGridColumns}; override; + property Columns: TTntDBGridColumns read GetColumns write SetColumns; + function CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; override; + function CreateDataLink: TGridDataLink; override; + function GetEditText(ACol, ARow: Longint): WideString; reintroduce; + procedure DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState); override; + procedure SetEditText(ACol, ARow: Longint; const Value: AnsiString); override; + public + procedure DefaultDrawColumnCell(const Rect: TRect; DataCol: Integer; + Column: TTntColumn; State: TGridDrawState); dynamic; + procedure DefaultDrawDataCell(const Rect: TRect; Field: TField; + State: TGridDrawState); + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TDBGrid} + TTntDBGrid = class(TTntCustomDBGrid) + public + property Canvas; + property SelectedRows; + published + property Align; + property Anchors; + property BiDiMode; + property BorderStyle; + property Color; + property Columns stored False; //StoreColumns; + property Constraints; + property Ctl3D; + property DataSource; + property DefaultDrawing; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property FixedColor; + property Font; + property ImeMode; + property ImeName; + property Options; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly; + property ShowHint; + property TabOrder; + property TabStop; + property TitleFont; + property Visible; + property OnCellClick; + property OnColEnter; + property OnColExit; + property OnColumnMoved; + property OnDrawDataCell; { obsolete } + property OnDrawColumnCell; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditButtonClick; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnStartDock; + property OnStartDrag; + property OnTitleClick; + end; + +implementation + +uses + SysUtils, TntControls, Math, Variants, Forms, + TntGraphics, Graphics, TntDB, TntActnList, TntSysUtils, TntWindows; + +{ TTntColumnTitle } + +procedure TTntColumnTitle.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntColumnTitle.DefaultCaption: WideString; +var + Field: TField; +begin + Field := Column.Field; + if Assigned(Field) then + Result := Field.DisplayName + else + Result := Column.FieldName; +end; + +function TTntColumnTitle.IsCaptionStored: Boolean; +begin + Result := (cvTitleCaption in Column.AssignedValues) and + (FCaption <> DefaultCaption); +end; + +procedure TTntColumnTitle.SetInheritedCaption(const Value: AnsiString); +begin + inherited Caption := Value; +end; + +function TTntColumnTitle.GetCaption: WideString; +begin + if cvTitleCaption in Column.AssignedValues then + Result := GetSyncedWideString(FCaption, inherited Caption) + else + Result := DefaultCaption; +end; + +procedure TTntColumnTitle.SetCaption(const Value: WideString); +begin + if not (Column as TTntColumn).IsStored then + inherited Caption := Value + else begin + if (cvTitleCaption in Column.AssignedValues) and (Value = FCaption) then Exit; + SetSyncedWideString(Value, FCaption, inherited Caption, SetInheritedCaption); + end; +end; + +procedure TTntColumnTitle.Assign(Source: TPersistent); +begin + inherited Assign(Source); + if Source is TTntColumnTitle then + begin + if cvTitleCaption in TTntColumnTitle(Source).Column.AssignedValues then + Caption := TTntColumnTitle(Source).Caption; + end; +end; + +procedure TTntColumnTitle.RestoreDefaults; +begin + FCaption := ''; + inherited; +end; + +{ TTntColumn } + +procedure TTntColumn.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntColumn.CreateTitle: TColumnTitle{TNT-ALLOW TColumnTitle}; +begin + Result := TTntColumnTitle.Create(Self); +end; + +function TTntColumn.GetTitle: TTntColumnTitle; +begin + Result := (inherited Title) as TTntColumnTitle; +end; + +procedure TTntColumn.SetTitle(const Value: TTntColumnTitle); +begin + inherited Title := Value; +end; + +function TTntColumn.GetWidePickList: TTntStrings; +begin + if FWidePickList = nil then begin + FWidePickList := TTntStringList.Create; + TTntStringList(FWidePickList).OnChange := HandlePickListChange; + end; + Result := FWidePickList; +end; + +procedure TTntColumn.SetWidePickList(const Value: TTntStrings); +begin + if Value = nil then + begin + FWidePickList.Free; + FWidePickList := nil; + (inherited PickList{TNT-ALLOW PickList}).Clear; + Exit; + end; + WidePickList.Assign(Value); +end; + +procedure TTntColumn.HandlePickListChange(Sender: TObject); +begin + inherited PickList{TNT-ALLOW PickList}.Assign(WidePickList); +end; + +destructor TTntColumn.Destroy; +begin + inherited; + FWidePickList.Free; +end; + +{ TTntPopupListbox } +type + TTntPopupListbox = class(TTntCustomListbox) + private + FSearchText: WideString; + FSearchTickCount: Longint; + protected + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWnd; override; + procedure WMChar(var Message: TWMChar); message WM_CHAR; + procedure KeyPressW(var Key: WideChar); + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + end; + +procedure TTntPopupListbox.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + with Params do + begin + Style := Style or WS_BORDER; + ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST; + AddBiDiModeExStyle(ExStyle); + WindowClass.Style := CS_SAVEBITS; + end; +end; + +procedure TTntPopupListbox.CreateWnd; +begin + inherited CreateWnd; + Windows.SetParent(Handle, 0); + CallWindowProc(DefWndProc, Handle, wm_SetFocus, 0, 0); +end; + +procedure TTntPopupListbox.WMChar(var Message: TWMChar); +var + Key: WideChar; +begin + Key := GetWideCharFromWMCharMsg(Message); + KeyPressW(Key); + SetWideCharForWMCharMsg(Message, Key); + inherited; +end; + +procedure TTntPopupListbox.KeypressW(var Key: WideChar); +var + TickCount: Integer; +begin + case Key of + #8, #27: FSearchText := ''; + #32..High(WideChar): + begin + TickCount := GetTickCount; + if TickCount - FSearchTickCount > 2000 then FSearchText := ''; + FSearchTickCount := TickCount; + if Length(FSearchText) < 32 then FSearchText := FSearchText + Key; + if IsWindowUnicode(Handle) then + SendMessageW(Handle, LB_SelectString, WORD(-1), Longint(PWideChar(FSearchText))) + else + SendMessageA(Handle, LB_SelectString, WORD(-1), Longint(PAnsiChar(AnsiString(FSearchText)))); + Key := #0; + end; + end; +end; + +procedure TTntPopupListbox.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + inherited MouseUp(Button, Shift, X, Y); + (Owner as TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}).CloseUp((X >= 0) and (Y >= 0) and + (X < Width) and (Y < Height)); +end; + +{ TTntPopupDataList } +type + TTntPopupDataList = class(TPopupDataList) + protected + procedure Paint; override; + end; + +procedure TTntPopupDataList.Paint; +var + FRecordIndex: Integer; + FRecordCount: Integer; + FKeySelected: Boolean; + FKeyField: TField; + + procedure UpdateListVars; + begin + if ListActive then + begin + FRecordIndex := ListLink.ActiveRecord; + FRecordCount := ListLink.RecordCount; + FKeySelected := not VarIsNull(KeyValue) or + not ListLink.DataSet.BOF; + end else + begin + FRecordIndex := 0; + FRecordCount := 0; + FKeySelected := False; + end; + + FKeyField := nil; + if ListLink.Active and (KeyField <> '') then + FKeyField := GetFieldProperty(ListLink.DataSet, Self, KeyField); + end; + + function VarEquals(const V1, V2: Variant): Boolean; + begin + Result := False; + try + Result := V1 = V2; + except + end; + end; + +var + I, J, W, X, TxtWidth, TxtHeight, LastFieldIndex: Integer; + S: WideString; + R: TRect; + Selected: Boolean; + Field: TField; + AAlignment: TAlignment; +begin + UpdateListVars; + Canvas.Font := Font; + TxtWidth := WideCanvasTextWidth(Canvas, '0'); + TxtHeight := WideCanvasTextHeight(Canvas, '0'); + LastFieldIndex := ListFields.Count - 1; + if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then + Canvas.Pen.Color := clBtnFace else + Canvas.Pen.Color := clBtnShadow; + for I := 0 to RowCount - 1 do + begin + if Enabled then + Canvas.Font.Color := Font.Color else + Canvas.Font.Color := clGrayText; + Canvas.Brush.Color := Color; + Selected := not FKeySelected and (I = 0); + R.Top := I * TxtHeight; + R.Bottom := R.Top + TxtHeight; + if I < FRecordCount then + begin + ListLink.ActiveRecord := I; + if not VarIsNull(KeyValue) and + VarEquals(FKeyField.Value, KeyValue) then + begin + Canvas.Font.Color := clHighlightText; + Canvas.Brush.Color := clHighlight; + Selected := True; + end; + R.Right := 0; + for J := 0 to LastFieldIndex do + begin + Field := ListFields[J]; + if J < LastFieldIndex then + W := Field.DisplayWidth * TxtWidth + 4 else + W := ClientWidth - R.Right; + S := GetWideDisplayText(Field); + X := 2; + AAlignment := Field.Alignment; + if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment); + case AAlignment of + taRightJustify: X := W - WideCanvasTextWidth(Canvas, S) - 3; + taCenter: X := (W - WideCanvasTextWidth(Canvas, S)) div 2; + end; + R.Left := R.Right; + R.Right := R.Right + W; + if SysLocale.MiddleEast then TControlCanvas(Canvas).UpdateTextFlags; + WideCanvasTextRect(Canvas, R, R.Left + X, R.Top, S); + if J < LastFieldIndex then + begin + Canvas.MoveTo(R.Right, R.Top); + Canvas.LineTo(R.Right, R.Bottom); + Inc(R.Right); + if R.Right >= ClientWidth then Break; + end; + end; + end; + R.Left := 0; + R.Right := ClientWidth; + if I >= FRecordCount then Canvas.FillRect(R); + if Selected then + Canvas.DrawFocusRect(R); + end; + if FRecordCount <> 0 then ListLink.ActiveRecord := FRecordIndex; +end; + +//----------------------------------------------------------------------------------------- +// TDBGridInplaceEdit - Delphi 6 and higher +//----------------------------------------------------------------------------------------- + +constructor TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.Create(Owner: TComponent); +begin + inherited Create(Owner); + FLookupSource := TDataSource.Create(Self); +end; + +function TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.GetWidePickListBox: TTntCustomListBox; +var + PopupListbox: TTntPopupListbox; +begin + if not Assigned(FWidePickListBox) then + begin + PopupListbox := TTntPopupListbox.Create(Self); + PopupListbox.Visible := False; + PopupListbox.Parent := Self; + PopupListbox.OnMouseUp := ListMouseUp; + PopupListbox.IntegralHeight := True; + PopupListbox.ItemHeight := 11; + FWidePickListBox := PopupListBox; + end; + Result := FWidePickListBox; +end; + +procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.CloseUp(Accept: Boolean); +var + MasterField: TField; + ListValue: Variant; +begin + if ListVisible then + begin + if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0); + if ActiveList = DataList then + ListValue := DataList.KeyValue + else + if WidePickListBox.ItemIndex <> -1 then + ListValue := WidePickListBox.Items[WidePickListBox.ItemIndex]; + SetWindowPos(ActiveList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or + SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW); + ListVisible := False; + if Assigned(FDataList) then + FDataList.ListSource := nil; + FLookupSource.Dataset := nil; + Invalidate; + if Accept then + if ActiveList = DataList then + with Grid as TTntCustomDBGrid, Columns[SelectedIndex].Field do + begin + MasterField := DataSet.FieldByName(KeyFields); + if MasterField.CanModify and DataLink.Edit then + MasterField.Value := ListValue; + end + else + if (not VarIsNull(ListValue)) and EditCanModify then + with Grid as TTntCustomDBGrid do + SetWideText(Columns[SelectedIndex].Field, ListValue) + end; +end; + +procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.DoEditButtonClick; +begin + (Grid as TTntCustomDBGrid).EditButtonClick; +end; + +type TAccessTntCustomListbox = class(TTntCustomListbox); + +procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.DropDown; +var + Column: TTntColumn; + I, J, Y: Integer; +begin + if not ListVisible then + begin + with (Grid as TTntCustomDBGrid) do + Column := Columns[SelectedIndex] as TTntColumn; + if ActiveList = FDataList then + with Column.Field do + begin + FDataList.Color := Color; + FDataList.Font := Font; + FDataList.RowCount := Column.DropDownRows; + FLookupSource.DataSet := LookupDataSet; + FDataList.KeyField := LookupKeyFields; + FDataList.ListField := LookupResultField; + FDataList.ListSource := FLookupSource; + FDataList.KeyValue := DataSet.FieldByName(KeyFields).Value; + end + else if ActiveList = WidePickListBox then + begin + WidePickListBox.Items.Assign(Column.WidePickList); + DropDownRows := Column.DropDownRows; + // this is needed as inherited doesn't know about our WidePickListBox + if (DropDownRows > 0) and (WidePickListBox.Items.Count >= DropDownRows) then + WidePickListBox.Height := DropDownRows * TAccessTntCustomListbox(WidePickListBox as TTntCustomListbox).ItemHeight + 4 + else + WidePickListBox.Height := WidePickListBox.Items.Count * TAccessTntCustomListbox(WidePickListBox as TTntCustomListbox).ItemHeight + 4; + if Text = '' then + WidePickListBox.ItemIndex := -1 + else + WidePickListBox.ItemIndex := WidePickListBox.Items.IndexOf(Text); + J := WidePickListBox.ClientWidth; + for I := 0 to WidePickListBox.Items.Count - 1 do + begin + Y := WideCanvasTextWidth(WidePickListBox.Canvas, WidePickListBox.Items[I]); + if Y > J then J := Y; + end; + WidePickListBox.ClientWidth := J; + end; + end; + inherited DropDown; +end; + +procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.UpdateContents; +var + Column: TTntColumn; +begin + inherited UpdateContents; + if EditStyle = esPickList then + ActiveList := WidePickListBox; + if FUseDataList then + begin + if FDataList = nil then + begin + FDataList := TTntPopupDataList.Create(Self); + FDataList.Visible := False; + FDataList.Parent := Self; + FDataList.OnMouseUp := ListMouseUp; + end; + ActiveList := FDataList; + end; + with (Grid as TTntCustomDBGrid) do + Column := Columns[SelectedIndex] as TTntColumn; + Self.ReadOnly := Column.ReadOnly; + Font.Assign(Column.Font); + ImeMode := Column.ImeMode; + ImeName := Column.ImeName; +end; + +//----------------------------------------------------------------------------------------- + +{ TTntDBGridInplaceEdit } + +procedure TTntDBGridInplaceEdit.CreateWindowHandle(const Params: TCreateParams); +begin + TntCustomEdit_CreateWindowHandle(Self, Params); +end; + +function TTntDBGridInplaceEdit.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntDBGridInplaceEdit.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntDBGridInplaceEdit.WMSetText(var Message: TWMSetText); +begin + if (not FBlockSetText) then + inherited; +end; + +procedure TTntDBGridInplaceEdit.UpdateContents; +var + Grid: TTntCustomDBGrid; +begin + Grid := Self.Grid as TTntCustomDBGrid; + EditMask := Grid.GetEditMask(Grid.Col, Grid.Row); + Text := Grid.GetEditText(Grid.Col, Grid.Row); + MaxLength := Grid.GetEditLimit; + + FBlockSetText := True; + try + inherited; + finally + FBlockSetText := False; + end; +end; + +procedure TTntDBGridInplaceEdit.DblClick; +begin + FInDblClick := True; + try + inherited; + finally + FInDblClick := False; + end; +end; + +{ TTntGridDataLink } + +procedure TTntGridDataLink.GridUpdateFieldText(Sender: TField; const Text: AnsiString); +begin + Sender.OnSetText := OriginalSetText; + if Assigned(Sender) then + SetWideText(Sender, (Grid as TTntCustomDBGrid).FEditText); +end; + +procedure TTntGridDataLink.RecordChanged(Field: TField); +var + CField: TField; +begin + inherited; + if Grid.HandleAllocated then begin + CField := Grid.SelectedField; + if ((Field = nil) or (CField = Field)) and + (Assigned(CField) and (GetWideText(CField) <> (Grid as TTntCustomDBGrid).FEditText)) then + begin + with (Grid as TTntCustomDBGrid) do begin + InvalidateEditor; + if InplaceEditor <> nil then InplaceEditor.Deselect; + end; + end; + end; +end; + +procedure TTntGridDataLink.UpdateData; +var + Field: TField; +begin + Field := (Grid as TTntCustomDBGrid).SelectedField; + // remember "set text" + if Field <> nil then + OriginalSetText := Field.OnSetText; + try + // redirect "set text" to self + if Field <> nil then + Field.OnSetText := GridUpdateFieldText; + inherited; // clear modified ! + finally + // redirect "set text" to field + if Field <> nil then + Field.OnSetText := OriginalSetText; + // forget original "set text" + OriginalSetText := nil; + end; +end; + +{ TTntDBGridColumns } + +function TTntDBGridColumns.Add: TTntColumn; +begin + Result := inherited Add as TTntColumn; +end; + +function TTntDBGridColumns.GetColumn(Index: Integer): TTntColumn; +begin + Result := inherited Items[Index] as TTntColumn; +end; + +procedure TTntDBGridColumns.SetColumn(Index: Integer; const Value: TTntColumn); +begin + inherited Items[Index] := Value; +end; + +{ TTntCustomDBGrid } + +procedure TTntCustomDBGrid.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +type TAccessCustomGrid = class(TCustomGrid); + +procedure TTntCustomDBGrid.WMChar(var Msg: TWMChar); +begin + if (goEditing in TAccessCustomGrid(Self).Options) + and (AnsiChar(Msg.CharCode) in [^H, #32..#255]) then begin + RestoreWMCharMsg(TMessage(Msg)); + ShowEditorChar(WideChar(Msg.CharCode)); + end else + inherited; +end; + +procedure TTntCustomDBGrid.ShowEditorChar(Ch: WideChar); +begin + ShowEditor; + if InplaceEditor <> nil then begin + if Win32PlatformIsUnicode then + PostMessageW(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0) + else + PostMessageA(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0); + end; +end; + +procedure TTntCustomDBGrid.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomDBGrid.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomDBGrid.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomDBGrid.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntCustomDBGrid.CreateColumns: TDBGridColumns{TNT-ALLOW TDBGridColumns}; +begin + Result := TTntDBGridColumns.Create(Self, TTntColumn); +end; + +function TTntCustomDBGrid.GetColumns: TTntDBGridColumns; +begin + Result := inherited Columns as TTntDBGridColumns; +end; + +procedure TTntCustomDBGrid.SetColumns(const Value: TTntDBGridColumns); +begin + inherited Columns := Value; +end; + +function TTntCustomDBGrid.CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; +begin + Result := TTntDBGridInplaceEdit.Create(Self); +end; + +function TTntCustomDBGrid.CreateDataLink: TGridDataLink; +begin + Result := TTntGridDataLink.Create(Self); +end; + +function TTntCustomDBGrid.GetEditText(ACol, ARow: Integer): WideString; +var + Field: TField; +begin + Field := GetColField(RawToDataColumn(ACol)); + if Field = nil then + Result := '' + else + Result := GetWideText(Field); + FEditText := Result; +end; + +procedure TTntCustomDBGrid.SetEditText(ACol, ARow: Integer; const Value: AnsiString); +begin + if (InplaceEditor as TTntDBGridInplaceEdit).FInDblClick then + FEditText := Value + else + FEditText := (InplaceEditor as TTntDBGridInplaceEdit).Text; + inherited; +end; + +//----------------- DRAW CELL PROCS -------------------------------------------------- +var + DrawBitmap: TBitmap = nil; + +procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; + const Text: WideString; Alignment: TAlignment; ARightToLeft: Boolean); +const + AlignFlags : array [TAlignment] of Integer = + ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, + DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, + DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX ); + RTL: array [Boolean] of Integer = (0, DT_RTLREADING); +var + B, R: TRect; + Hold, Left: Integer; + I: TColorRef; +begin + I := ColorToRGB(ACanvas.Brush.Color); + if GetNearestColor(ACanvas.Handle, I) = I then + begin { Use ExtTextOutW for solid colors } + { In BiDi, because we changed the window origin, the text that does not + change alignment, actually gets its alignment changed. } + if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then + ChangeBiDiModeAlignment(Alignment); + case Alignment of + taLeftJustify: + Left := ARect.Left + DX; + taRightJustify: + Left := ARect.Right - WideCanvasTextWidth(ACanvas, Text) - 3; + else { taCenter } + Left := ARect.Left + (ARect.Right - ARect.Left) div 2 + - (WideCanvasTextWidth(ACanvas, Text) div 2); + end; + WideCanvasTextRect(ACanvas, ARect, Left, ARect.Top + DY, Text); + end + else begin { Use FillRect and Drawtext for dithered colors } + DrawBitmap.Canvas.Lock; + try + with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and } + begin { brush origin tics in painting / scrolling. } + Width := Max(Width, Right - Left); + Height := Max(Height, Bottom - Top); + R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1); + B := Rect(0, 0, Right - Left, Bottom - Top); + end; + with DrawBitmap.Canvas do + begin + Font := ACanvas.Font; + Font.Color := ACanvas.Font.Color; + Brush := ACanvas.Brush; + Brush.Style := bsSolid; + FillRect(B); + SetBkMode(Handle, TRANSPARENT); + if (ACanvas.CanvasOrientation = coRightToLeft) then + ChangeBiDiModeAlignment(Alignment); + Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), R, + AlignFlags[Alignment] or RTL[ARightToLeft]); + end; + if (ACanvas.CanvasOrientation = coRightToLeft) then + begin + Hold := ARect.Left; + ARect.Left := ARect.Right; + ARect.Right := Hold; + end; + ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B); + finally + DrawBitmap.Canvas.Unlock; + end; + end; +end; + +procedure TTntCustomDBGrid.DefaultDrawDataCell(const Rect: TRect; Field: TField; + State: TGridDrawState); +var + Alignment: TAlignment; + Value: WideString; +begin + Alignment := taLeftJustify; + Value := ''; + if Assigned(Field) then + begin + Alignment := Field.Alignment; + Value := GetWideDisplayText(Field); + end; + WriteText(Canvas, Rect, 2, 2, Value, Alignment, + UseRightToLeftAlignmentForField(Field, Alignment)); +end; + +procedure TTntCustomDBGrid.DefaultDrawColumnCell(const Rect: TRect; + DataCol: Integer; Column: TTntColumn; State: TGridDrawState); +var + Value: WideString; +begin + Value := ''; + if Assigned(Column.Field) then + Value := GetWideDisplayText(Column.Field); + WriteText(Canvas, Rect, 2, 2, Value, Column.Alignment, + UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)); +end; + +procedure TTntCustomDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); +var + FrameOffs: Byte; + + procedure DrawTitleCell(ACol, ARow: Integer; Column: TTntColumn; var AState: TGridDrawState); + const + ScrollArrows: array [Boolean, Boolean] of Integer = + ((DFCS_SCROLLRIGHT, DFCS_SCROLLLEFT), (DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT)); + var + MasterCol: TColumn{TNT-ALLOW TColumn}; + TitleRect, TxtRect, ButtonRect: TRect; + I: Integer; + InBiDiMode: Boolean; + begin + TitleRect := CalcTitleRect(Column, ARow, MasterCol); + + if MasterCol = nil then + begin + Canvas.FillRect(ARect); + Exit; + end; + + Canvas.Font := MasterCol.Title.Font; + Canvas.Brush.Color := MasterCol.Title.Color; + if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then + InflateRect(TitleRect, -1, -1); + TxtRect := TitleRect; + I := GetSystemMetrics(SM_CXHSCROLL); + if ((TxtRect.Right - TxtRect.Left) > I) and MasterCol.Expandable then + begin + Dec(TxtRect.Right, I); + ButtonRect := TitleRect; + ButtonRect.Left := TxtRect.Right; + I := SaveDC(Canvas.Handle); + try + Canvas.FillRect(ButtonRect); + InflateRect(ButtonRect, -1, -1); + IntersectClipRect(Canvas.Handle, ButtonRect.Left, + ButtonRect.Top, ButtonRect.Right, ButtonRect.Bottom); + InflateRect(ButtonRect, 1, 1); + { DrawFrameControl doesn't draw properly when orienatation has changed. + It draws as ExtTextOutW does. } + InBiDiMode := Canvas.CanvasOrientation = coRightToLeft; + if InBiDiMode then { stretch the arrows box } + Inc(ButtonRect.Right, GetSystemMetrics(SM_CXHSCROLL) + 4); + DrawFrameControl(Canvas.Handle, ButtonRect, DFC_SCROLL, + ScrollArrows[InBiDiMode, MasterCol.Expanded] or DFCS_FLAT); + finally + RestoreDC(Canvas.Handle, I); + end; + end; + with (MasterCol.Title as TTntColumnTitle) do + WriteText(Canvas, TxtRect, FrameOffs, FrameOffs, Caption, Alignment, IsRightToLeft); + if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then + begin + InflateRect(TitleRect, 1, 1); + DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_BOTTOMRIGHT); + DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_TOPLEFT); + end; + AState := AState - [gdFixed]; // prevent box drawing later + end; + +var + OldActive: Integer; + Highlight: Boolean; + Value: WideString; + DrawColumn: TTntColumn; +begin + if csLoading in ComponentState then + begin + Canvas.Brush.Color := Color; + Canvas.FillRect(ARect); + Exit; + end; + + if (gdFixed in AState) and (RawToDataColumn(ACol) < 0) then + begin + inherited; + exit; + end; + + Dec(ARow, FixedRows); + ACol := RawToDataColumn(ACol); + + if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = + [dgRowLines, dgColLines]) then + begin + InflateRect(ARect, -1, -1); + FrameOffs := 1; + end + else + FrameOffs := 2; + + with Canvas do + begin + DrawColumn := Columns[ACol] as TTntColumn; + if not DrawColumn.Showing then Exit; + if not (gdFixed in AState) then + begin + Font := DrawColumn.Font; + Brush.Color := DrawColumn.Color; + end; + if ARow < 0 then + DrawTitleCell(ACol, ARow + FixedRows, DrawColumn, AState) + else if (DataLink = nil) or not DataLink.Active then + FillRect(ARect) + else + begin + Value := ''; + OldActive := DataLink.ActiveRecord; + try + DataLink.ActiveRecord := ARow; + if Assigned(DrawColumn.Field) then + Value := GetWideDisplayText(DrawColumn.Field); + Highlight := HighlightCell(ACol, ARow, Value, AState); + if Highlight then + begin + Brush.Color := clHighlight; + Font.Color := clHighlightText; + end; + if not Enabled then + Font.Color := clGrayText; + if DefaultDrawing then + DefaultDrawColumnCell(ARect, ACol, DrawColumn, AState); + if Columns.State = csDefault then + DrawDataCell(ARect, DrawColumn.Field, AState); + DrawColumnCell(ARect, ACol, DrawColumn, AState); + finally + DataLink.ActiveRecord := OldActive; + end; + if DefaultDrawing and (gdSelected in AState) + and ((dgAlwaysShowSelection in Options) or Focused) + and not (csDesigning in ComponentState) + and not (dgRowSelect in Options) + and (UpdateLock = 0) + and (ValidParentForm(Self).ActiveControl = Self) then + Windows.DrawFocusRect(Handle, ARect); + end; + end; + if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = + [dgRowLines, dgColLines]) then + begin + InflateRect(ARect, 1, 1); + DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMRIGHT); + DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPLEFT); + end; +end; + +procedure TTntCustomDBGrid.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomDBGrid.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +initialization + DrawBitmap := TBitmap.Create; + +finalization + DrawBitmap.Free; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm new file mode 100644 index 0000000000..fd0a07196b --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm @@ -0,0 +1,108 @@ +object TntLoginDialog: TTntLoginDialog + Left = 307 + Top = 131 + ActiveControl = Password + BorderStyle = bsDialog + Caption = 'Database Login' + ClientHeight = 147 + ClientWidth = 273 + Color = clBtnFace + ParentFont = True + + Position = poScreenCenter + OnShow = FormShow + PixelsPerInch = 96 + TextHeight = 13 + object OKButton: TTntButton + Left = 109 + Top = 114 + Width = 75 + Height = 25 + Caption = '&OK' + Default = True + ModalResult = 1 + TabOrder = 0 + end + object CancelButton: TTntButton + Left = 190 + Top = 114 + Width = 75 + Height = 25 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 1 + end + object Panel: TTntPanel + Left = 8 + Top = 7 + Width = 257 + Height = 98 + BevelInner = bvRaised + BevelOuter = bvLowered + TabOrder = 2 + object Label3: TTntLabel + Left = 10 + Top = 6 + Width = 50 + Height = 13 + Caption = 'Database:' + end + object DatabaseName: TTntLabel + Left = 91 + Top = 6 + Width = 3 + Height = 13 + end + object Bevel: TTntBevel + Left = 1 + Top = 24 + Width = 254 + Height = 9 + Shape = bsTopLine + end + object Panel1: TTntPanel + Left = 2 + Top = 31 + Width = 253 + Height = 65 + Align = alBottom + BevelOuter = bvNone + TabOrder = 0 + object Label1: TTntLabel + Left = 8 + Top = 8 + Width = 56 + Height = 13 + Caption = '&User Name:' + FocusControl = UserName + end + object Label2: TTntLabel + Left = 8 + Top = 36 + Width = 50 + Height = 13 + Caption = '&Password:' + FocusControl = Password + end + object UserName: TTntEdit + Left = 86 + Top = 5 + Width = 153 + Height = 21 + MaxLength = 31 + TabOrder = 0 + end + object Password: TTntEdit + Left = 86 + Top = 33 + Width = 153 + Height = 21 + MaxLength = 31 + PasswordCharW = #9679 + TabOrder = 1 + PasswordChar_UTF7 = '+Jc8' + end + end + end +end diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas new file mode 100644 index 0000000000..c8747e2f2a --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas @@ -0,0 +1,133 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBLogDlg; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + SysUtils, Windows, Messages, Classes, Graphics, + TntForms, TntStdCtrls, TntExtCtrls, StdCtrls, ExtCtrls, Controls; + +type + TTntLoginDialog = class(TTntForm) + Panel: TTntPanel; + Bevel: TTntBevel; + DatabaseName: TTntLabel; + OKButton: TTntButton; + CancelButton: TTntButton; + Panel1: TTntPanel; + Label1: TTntLabel; + Label2: TTntLabel; + Label3: TTntLabel; + Password: TTntEdit; + UserName: TTntEdit; + procedure FormShow(Sender: TObject); + end; + +{TNT-WARN LoginDialog} +function TntLoginDialog(const ADatabaseName: WideString; + var AUserName, APassword: WideString): Boolean; + +{TNT-WARN LoginDialogEx} +function TntLoginDialogEx(const ADatabaseName: WideString; + var AUserName, APassword: WideString; NameReadOnly: Boolean): Boolean; + +{TNT-WARN RemoteLoginDialog} +function TntRemoteLoginDialog(var AUserName, APassword: WideString): Boolean; + +implementation + +{$R *.dfm} + +uses + Forms, VDBConsts; + +function TntLoginDialog(const ADatabaseName: WideString; + var AUserName, APassword: WideString): Boolean; +begin + with TTntLoginDialog.Create(Application) do + try + DatabaseName.Caption := ADatabaseName; + UserName.Text := AUserName; + Result := False; + if AUserName = '' then ActiveControl := UserName; + if ShowModal = mrOk then + begin + AUserName := UserName.Text; + APassword := Password.Text; + Result := True; + end; + finally + Free; + end; +end; + +function TntLoginDialogEx(const ADatabaseName: WideString; + var AUserName, APassword: WideString; NameReadOnly: Boolean): Boolean; +begin + with TTntLoginDialog.Create(Application) do + try + DatabaseName.Caption := ADatabaseName; + UserName.Text := AUserName; + Result := False; + if NameReadOnly then + UserName.Enabled := False + else + if AUserName = '' then ActiveControl := UserName; + if ShowModal = mrOk then + begin + AUserName := UserName.Text; + APassword := Password.Text; + Result := True; + end; + finally + Free; + end; +end; + +function TntRemoteLoginDialog(var AUserName, APassword: WideString): Boolean; +begin + with TTntLoginDialog.Create(Application) do + try + Caption := SRemoteLogin; + Bevel.Visible := False; + DatabaseName.Visible := False; + Label3.Visible := False; + Panel.Height := Panel.Height - Bevel.Top; + OKButton.Top := OKButton.Top - Bevel.Top; + CancelButton.Top := CancelButton.Top - Bevel.Top; + Height := Height - Bevel.Top; + UserName.Text := AUserName; + Result := False; + if AUserName = '' then ActiveControl := UserName; + if ShowModal = mrOk then + begin + AUserName := UserName.Text; + APassword := Password.Text; + Result := True; + end; + finally + Free; + end; +end; + +{ TTntLoginDialog } + +procedure TTntLoginDialog.FormShow(Sender: TObject); +begin + if (DatabaseName.Width + DatabaseName.Left) >= Panel.ClientWidth then + DatabaseName.Width := (Panel.ClientWidth - DatabaseName.Left) - 5; +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas new file mode 100644 index 0000000000..0c06d07f7d --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas @@ -0,0 +1,981 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDialogs; + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: TFindDialog and TReplaceDialog. } +{ TODO: Property editor for TTntOpenDialog.Filter } + +uses + Classes, Messages, CommDlg, Windows, Dialogs, + TntClasses, TntForms, TntSysUtils; + +type +{TNT-WARN TIncludeItemEvent} + TIncludeItemEventW = procedure (const OFN: TOFNotifyExW; var Include: Boolean) of object; + +{TNT-WARN TOpenDialog} + TTntOpenDialog = class(TOpenDialog{TNT-ALLOW TOpenDialog}) + private + FDefaultExt: WideString; + FFileName: TWideFileName; + FFilter: WideString; + FInitialDir: WideString; + FTitle: WideString; + FFiles: TTntStrings; + FOnIncludeItem: TIncludeItemEventW; + function GetDefaultExt: WideString; + procedure SetInheritedDefaultExt(const Value: AnsiString); + procedure SetDefaultExt(const Value: WideString); + function GetFileName: TWideFileName; + procedure SetFileName(const Value: TWideFileName); + function GetFilter: WideString; + procedure SetInheritedFilter(const Value: AnsiString); + procedure SetFilter(const Value: WideString); + function GetInitialDir: WideString; + procedure SetInheritedInitialDir(const Value: AnsiString); + procedure SetInitialDir(const Value: WideString); + function GetTitle: WideString; + procedure SetInheritedTitle(const Value: AnsiString); + procedure SetTitle(const Value: WideString); + function GetFiles: TTntStrings; + private + FProxiedOpenFilenameA: TOpenFilenameA; + protected + FAllowDoCanClose: Boolean; + procedure DefineProperties(Filer: TFiler); override; + function CanCloseW(var OpenFileName: TOpenFileNameW): Boolean; + function DoCanClose: Boolean; override; + procedure GetFileNamesW(var OpenFileName: TOpenFileNameW); + procedure DoIncludeItem(const OFN: TOFNotifyEx; var Include: Boolean); override; + procedure WndProc(var Message: TMessage); override; + function DoExecuteW(Func: Pointer; ParentWnd: HWND): Bool; overload; + function DoExecuteW(Func: Pointer): Bool; overload; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function Execute: Boolean; override; + {$IFDEF COMPILER_9_UP} + function Execute(ParentWnd: HWND): Boolean; override; + {$ENDIF} + property Files: TTntStrings read GetFiles; + published + property DefaultExt: WideString read GetDefaultExt write SetDefaultExt; + property FileName: TWideFileName read GetFileName write SetFileName; + property Filter: WideString read GetFilter write SetFilter; + property InitialDir: WideString read GetInitialDir write SetInitialDir; + property Title: WideString read GetTitle write SetTitle; + property OnIncludeItem: TIncludeItemEventW read FOnIncludeItem write FOnIncludeItem; + end; + +{TNT-WARN TSaveDialog} + TTntSaveDialog = class(TTntOpenDialog) + public + function Execute: Boolean; override; + {$IFDEF COMPILER_9_UP} + function Execute(ParentWnd: HWND): Boolean; override; + {$ENDIF} + end; + +{ Message dialog } + +{TNT-WARN CreateMessageDialog} +function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons): TTntForm;overload; +function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn): TTntForm; overload; + +{TNT-WARN MessageDlg} +function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; overload; +function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): Integer; overload; + +{TNT-WARN MessageDlgPos} +function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer; overload; +function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; DefaultButton: TMsgDlgBtn): Integer; overload; + +{TNT-WARN MessageDlgPosHelp} +function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString): Integer; overload; +function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString; DefaultButton: TMsgDlgBtn): Integer; overload; + +{TNT-WARN ShowMessage} +procedure WideShowMessage(const Msg: WideString); +{TNT-WARN ShowMessageFmt} +procedure WideShowMessageFmt(const Msg: WideString; Params: array of const); +{TNT-WARN ShowMessagePos} +procedure WideShowMessagePos(const Msg: WideString; X, Y: Integer); + +{ Input dialog } + +{TNT-WARN InputQuery} +function WideInputQuery(const ACaption, APrompt: WideString; + var Value: WideString): Boolean; +{TNT-WARN InputBox} +function WideInputBox(const ACaption, APrompt, ADefault: WideString): WideString; + +{TNT-WARN PromptForFileName} +function WidePromptForFileName(var AFileName: WideString; const AFilter: WideString = ''; + const ADefaultExt: WideString = ''; const ATitle: WideString = ''; + const AInitialDir: WideString = ''; SaveDialog: Boolean = False): Boolean; + +function GetModalParentWnd: HWND; + +implementation + +uses + Controls, Forms, Types, SysUtils, Graphics, Consts, Math, + TntWindows, TntStdCtrls, TntClipBrd, TntExtCtrls, + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; + +function GetModalParentWnd: HWND; +begin + {$IFDEF COMPILER_9} + Result := Application.ActiveFormHandle; + {$ELSE} + Result := 0; + {$ENDIF} + {$IFDEF COMPILER_10_UP} + if Application.ModalPopupMode <> pmNone then + begin + Result := Application.ActiveFormHandle; + end; + {$ENDIF} + if Result = 0 then begin + Result := Application.Handle; + end; +end; + +var + ProxyExecuteDialog: TTntOpenDialog; + +function ProxyGetOpenFileNameA(var OpenFile: TOpenFilename): Bool; stdcall; +begin + ProxyExecuteDialog.FProxiedOpenFilenameA := OpenFile; + Result := False; { as if user hit "Cancel". } +end; + +{ TTntOpenDialog } + +constructor TTntOpenDialog.Create(AOwner: TComponent); +begin + inherited; + FFiles := TTntStringList.Create; +end; + +destructor TTntOpenDialog.Destroy; +begin + FreeAndNil(FFiles); + inherited; +end; + +procedure TTntOpenDialog.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntOpenDialog.GetDefaultExt: WideString; +begin + Result := GetSyncedWideString(FDefaultExt, inherited DefaultExt); +end; + +procedure TTntOpenDialog.SetInheritedDefaultExt(const Value: AnsiString); +begin + inherited DefaultExt := Value; +end; + +procedure TTntOpenDialog.SetDefaultExt(const Value: WideString); +begin + SetSyncedWideString(Value, FDefaultExt, inherited DefaultExt, SetInheritedDefaultExt); +end; + +function TTntOpenDialog.GetFileName: TWideFileName; +var + Path: array[0..MAX_PATH] of WideChar; +begin + if Win32PlatformIsUnicode and NewStyleControls and (Handle <> 0) then begin + // get filename from handle + SendMessageW(GetParent(Handle), CDM_GETFILEPATH, SizeOf(Path), Integer(@Path)); + Result := Path; + end else + Result := GetSyncedWideString(WideString(FFileName), inherited FileName); +end; + +procedure TTntOpenDialog.SetFileName(const Value: TWideFileName); +begin + FFileName := Value; + inherited FileName := Value; +end; + +function TTntOpenDialog.GetFilter: WideString; +begin + Result := GetSyncedWideString(FFilter, inherited Filter); +end; + +procedure TTntOpenDialog.SetInheritedFilter(const Value: AnsiString); +begin + inherited Filter := Value; +end; + +procedure TTntOpenDialog.SetFilter(const Value: WideString); +begin + SetSyncedWideString(Value, FFilter, inherited Filter, SetInheritedFilter); +end; + +function TTntOpenDialog.GetInitialDir: WideString; +begin + Result := GetSyncedWideString(FInitialDir, inherited InitialDir); +end; + +procedure TTntOpenDialog.SetInheritedInitialDir(const Value: AnsiString); +begin + inherited InitialDir := Value; +end; + +procedure TTntOpenDialog.SetInitialDir(const Value: WideString); + + function RemoveTrailingPathDelimiter(const Value: WideString): WideString; + var + L: Integer; + begin + // remove trailing path delimiter (except 'C:\') + L := Length(Value); + if (L > 1) and WideIsPathDelimiter(Value, L) and not WideIsDelimiter(':', Value, L - 1) then + Dec(L); + Result := Copy(Value, 1, L); + end; + +begin + SetSyncedWideString(RemoveTrailingPathDelimiter(Value), FInitialDir, + inherited InitialDir, SetInheritedInitialDir); +end; + +function TTntOpenDialog.GetTitle: WideString; +begin + Result := GetSyncedWideString(FTitle, inherited Title) +end; + +procedure TTntOpenDialog.SetInheritedTitle(const Value: AnsiString); +begin + inherited Title := Value; +end; + +procedure TTntOpenDialog.SetTitle(const Value: WideString); +begin + SetSyncedWideString(Value, FTitle, inherited Title, SetInheritedTitle); +end; + +function TTntOpenDialog.GetFiles: TTntStrings; +begin + if (not Win32PlatformIsUnicode) then + FFiles.Assign(inherited Files); + Result := FFiles; +end; + +function TTntOpenDialog.DoCanClose: Boolean; +begin + if FAllowDoCanClose then + Result := inherited DoCanClose + else + Result := True; +end; + +function TTntOpenDialog.CanCloseW(var OpenFileName: TOpenFileNameW): Boolean; +begin + GetFileNamesW(OpenFileName); + FAllowDoCanClose := True; + try + Result := DoCanClose; + finally + FAllowDoCanClose := False; + end; + FFiles.Clear; + inherited Files.Clear; +end; + +procedure TTntOpenDialog.DoIncludeItem(const OFN: TOFNotifyEx; var Include: Boolean); +begin + // CDN_INCLUDEITEM -> DoIncludeItem() is only be available on Windows 2000 + + // Therefore, just cast OFN as a TOFNotifyExW, since that's what it really is. + if Win32PlatformIsUnicode and Assigned(FOnIncludeItem) then + FOnIncludeItem(TOFNotifyExW(OFN), Include) +end; + +procedure TTntOpenDialog.WndProc(var Message: TMessage); +begin + Message.Result := 0; + if (Message.Msg = WM_INITDIALOG) and not (ofOldStyleDialog in Options) then begin + { If not ofOldStyleDialog then DoShow on CDN_INITDONE, not WM_INITDIALOG } + Exit; + end; + if Win32PlatformIsUnicode + and (Message.Msg = WM_NOTIFY) then begin + case (POFNotify(Message.LParam)^.hdr.code) of + CDN_FILEOK: + if not CanCloseW(POFNotifyW(Message.LParam)^.lpOFN^) then + begin + Message.Result := 1; + SetWindowLong(Handle, DWL_MSGRESULT, Message.Result); + Exit; + end; + end; + end; + inherited WndProc(Message); +end; + +function TTntOpenDialog.DoExecuteW(Func: Pointer): Bool; +begin + Result := DoExecuteW(Func, GetModalParentWnd); +end; + +function TTntOpenDialog.DoExecuteW(Func: Pointer; ParentWnd: HWND): Bool; +var + OpenFilename: TOpenFilenameW; + + function GetResNamePtr(var ScopedStringStorage: WideString; lpszName: PAnsiChar): PWideChar; + // duplicated from TntTrxResourceUtils.pas + begin + if Tnt_Is_IntResource(PWideChar(lpszName)) then + Result := PWideChar(lpszName) + else begin + ScopedStringStorage := lpszName; + Result := PWideChar(ScopedStringStorage); + end; + end; + + function AllocFilterStr(const S: WideString): WideString; + var + P: PWideChar; + begin + Result := ''; + if S <> '' then + begin + Result := S + #0#0; // double null terminators (an additional zero added in case Description/Filter pair not even.) + P := WStrScan(PWideChar(Result), '|'); + while P <> nil do + begin + P^ := #0; + Inc(P); + P := WStrScan(P, '|'); + end; + end; + end; + +var + TempTemplate, TempFilter, TempFilename, TempExt: WideString; +begin + FFiles.Clear; + + // 1. Init inherited dialog defaults. + // 2. Populate OpenFileName record with ansi defaults + ProxyExecuteDialog := Self; + try + DoExecute(@ProxyGetOpenFileNameA); + finally + ProxyExecuteDialog := nil; + end; + OpenFileName := TOpenFilenameW(FProxiedOpenFilenameA); + + with OpenFilename do + begin + if not IsWindow(hWndOwner) then begin + hWndOwner := ParentWnd; + end; + // Filter (PChar -> PWideChar) + TempFilter := AllocFilterStr(Filter); + lpstrFilter := PWideChar(TempFilter); + // FileName (PChar -> PWideChar) + SetLength(TempFilename, nMaxFile + 2); + lpstrFile := PWideChar(TempFilename); + FillChar(lpstrFile^, (nMaxFile + 2) * SizeOf(WideChar), 0); + WStrLCopy(lpstrFile, PWideChar(FileName), nMaxFile); + // InitialDir (PChar -> PWideChar) + if (InitialDir = '') and ForceCurrentDirectory then + lpstrInitialDir := '.' + else + lpstrInitialDir := PWideChar(InitialDir); + // Title (PChar -> PWideChar) + lpstrTitle := PWideChar(Title); + // DefaultExt (PChar -> PWideChar) + TempExt := DefaultExt; + if (TempExt = '') and (Flags and OFN_EXPLORER = 0) then + begin + TempExt := WideExtractFileExt(Filename); + Delete(TempExt, 1, 1); + end; + if TempExt <> '' then + lpstrDefExt := PWideChar(TempExt); + // resource template (PChar -> PWideChar) + lpTemplateName := GetResNamePtr(TempTemplate, Template); + // start modal dialog + Result := TaskModalDialog(Func, OpenFileName); + if Result then + begin + GetFileNamesW(OpenFilename); + if (Flags and OFN_EXTENSIONDIFFERENT) <> 0 then + Options := Options + [ofExtensionDifferent] + else + Options := Options - [ofExtensionDifferent]; + if (Flags and OFN_READONLY) <> 0 then + Options := Options + [ofReadOnly] + else + Options := Options - [ofReadOnly]; + FilterIndex := nFilterIndex; + end; + end; +end; + +procedure TTntOpenDialog.GetFileNamesW(var OpenFileName: TOpenFileNameW); +var + Separator: WideChar; + + procedure ExtractFileNamesW(P: PWideChar); + var + DirName, FileName: TWideFileName; + FileList: TWideStringDynArray; + i: integer; + begin + FileList := ExtractStringsFromStringArray(P, Separator); + if Length(FileList) = 0 then + FFiles.Add('') + else begin + DirName := FileList[0]; + if Length(FileList) = 1 then + FFiles.Add(DirName) + else begin + // prepare DirName + if WideLastChar(DirName) <> WideString(PathDelim) then + DirName := DirName + PathDelim; + // add files + for i := 1 {second item} to High(FileList) do begin + FileName := FileList[i]; + // prepare FileName + if (FileName[1] <> PathDelim) + and ((Length(FileName) <= 3) or (FileName[2] <> DriveDelim) or (FileName[3] <> PathDelim)) + then + FileName := DirName + FileName; + // add to list + FFiles.Add(FileName); + end; + end; + end; + end; + +var + P: PWideChar; +begin + Separator := #0; + if (ofAllowMultiSelect in Options) and + ((ofOldStyleDialog in Options) or not NewStyleControls) then + Separator := ' '; + with OpenFileName do + begin + if ofAllowMultiSelect in Options then + begin + ExtractFileNamesW(lpstrFile); + FileName := FFiles[0]; + end else + begin + P := lpstrFile; + FileName := ExtractStringFromStringArray(P, Separator); + FFiles.Add(FileName); + end; + end; + + // Sync inherited Files + inherited Files.Assign(FFiles); +end; + +function TTntOpenDialog.Execute: Boolean; +begin + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetOpenFileNameA) + else + Result := DoExecuteW(@GetOpenFileNameW); +end; + +{$IFDEF COMPILER_9_UP} +function TTntOpenDialog.Execute(ParentWnd: HWND): Boolean; +begin + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetOpenFileNameA, ParentWnd) + else + Result := DoExecuteW(@GetOpenFileNameW, ParentWnd); +end; +{$ENDIF} + +{ TTntSaveDialog } + +function TTntSaveDialog.Execute: Boolean; +begin + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetSaveFileNameA) + else + Result := DoExecuteW(@GetSaveFileNameW); +end; + +{$IFDEF COMPILER_9_UP} +function TTntSaveDialog.Execute(ParentWnd: HWND): Boolean; +begin + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetSaveFileNameA, ParentWnd) + else + Result := DoExecuteW(@GetSaveFileNameW, ParentWnd); +end; +{$ENDIF} + +{ Message dialog } + +function GetAveCharSize(Canvas: TCanvas): TPoint; +var + I: Integer; + Buffer: array[0..51] of WideChar; + tm: TTextMetric; +begin + for I := 0 to 25 do Buffer[I] := WideChar(I + Ord('A')); + for I := 0 to 25 do Buffer[I + 26] := WideChar(I + Ord('a')); + GetTextMetrics(Canvas.Handle, tm); + GetTextExtentPointW(Canvas.Handle, Buffer, 52, TSize(Result)); + Result.X := (Result.X div 26 + 1) div 2; + Result.Y := tm.tmHeight; +end; + +type + TTntMessageForm = class(TTntForm) + private + Message: TTntLabel; + procedure HelpButtonClick(Sender: TObject); + protected + procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + function GetFormText: WideString; + public + constructor CreateNew(AOwner: TComponent); reintroduce; + end; + +constructor TTntMessageForm.CreateNew(AOwner: TComponent); +var + NonClientMetrics: TNonClientMetrics; +begin + inherited CreateNew(AOwner); + NonClientMetrics.cbSize := sizeof(NonClientMetrics); + if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then + Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont); +end; + +procedure TTntMessageForm.HelpButtonClick(Sender: TObject); +begin + Application.HelpContext(HelpContext); +end; + +procedure TTntMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if (Shift = [ssCtrl]) and (Key = Word('C')) then + begin + Beep; + TntClipboard.AsWideText := GetFormText; + end; +end; + +function TTntMessageForm.GetFormText: WideString; +var + DividerLine, ButtonCaptions: WideString; + I: integer; +begin + DividerLine := StringOfChar('-', 27) + sLineBreak; + for I := 0 to ComponentCount - 1 do + if Components[I] is TTntButton then + ButtonCaptions := ButtonCaptions + TTntButton(Components[I]).Caption + + StringOfChar(' ', 3); + ButtonCaptions := Tnt_WideStringReplace(ButtonCaptions,'&','', [rfReplaceAll]); + Result := DividerLine + Caption + sLineBreak + DividerLine + Message.Caption + sLineBreak + + DividerLine + ButtonCaptions + sLineBreak + DividerLine; +end; + +function GetMessageCaption(MsgType: TMsgDlgType): WideString; +begin + case MsgType of + mtWarning: Result := SMsgDlgWarning; + mtError: Result := SMsgDlgError; + mtInformation: Result := SMsgDlgInformation; + mtConfirmation: Result := SMsgDlgConfirm; + mtCustom: Result := ''; + else + raise ETntInternalError.Create('Unexpected MsgType in GetMessageCaption.'); + end; +end; + +function GetButtonCaption(MsgDlgBtn: TMsgDlgBtn): WideString; +begin + case MsgDlgBtn of + mbYes: Result := SMsgDlgYes; + mbNo: Result := SMsgDlgNo; + mbOK: Result := SMsgDlgOK; + mbCancel: Result := SMsgDlgCancel; + mbAbort: Result := SMsgDlgAbort; + mbRetry: Result := SMsgDlgRetry; + mbIgnore: Result := SMsgDlgIgnore; + mbAll: Result := SMsgDlgAll; + mbNoToAll: Result := SMsgDlgNoToAll; + mbYesToAll: Result := SMsgDlgYesToAll; + mbHelp: Result := SMsgDlgHelp; + else + raise ETntInternalError.Create('Unexpected MsgDlgBtn in GetButtonCaption.'); + end; +end; + +var + IconIDs: array[TMsgDlgType] of PAnsiChar = (IDI_EXCLAMATION, IDI_HAND, + IDI_ASTERISK, IDI_QUESTION, nil); + ButtonNames: array[TMsgDlgBtn] of WideString = ( + 'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll', + 'YesToAll', 'Help'); + ModalResults: array[TMsgDlgBtn] of Integer = ( + mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll, + mrYesToAll, 0); + +function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn): TTntForm; +const + mcHorzMargin = 8; + mcVertMargin = 8; + mcHorzSpacing = 10; + mcVertSpacing = 10; + mcButtonWidth = 50; + mcButtonHeight = 14; + mcButtonSpacing = 4; +var + DialogUnits: TPoint; + HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth, + ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth, + IconTextWidth, IconTextHeight, X, ALeft: Integer; + B, CancelButton: TMsgDlgBtn; + IconID: PAnsiChar; + ATextRect: TRect; + ThisButtonWidth: integer; + LButton: TTntButton; +begin + Result := TTntMessageForm.CreateNew(Application); + with Result do + begin + BorderStyle := bsDialog; // By doing this first, it will work on WINE. + BiDiMode := Application.BiDiMode; + Canvas.Font := Font; + KeyPreview := True; + Position := poDesigned; + OnKeyDown := TTntMessageForm(Result).CustomKeyDown; + DialogUnits := GetAveCharSize(Canvas); + HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4); + VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8); + HorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4); + VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8); + ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4); + for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do + begin + if B in Buttons then + begin + ATextRect := Rect(0,0,0,0); + Tnt_DrawTextW(Canvas.Handle, + PWideChar(GetButtonCaption(B)), -1, + ATextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or + DrawTextBiDiModeFlagsReadingOnly); + with ATextRect do ThisButtonWidth := Right - Left + 8; + if ThisButtonWidth > ButtonWidth then + ButtonWidth := ThisButtonWidth; + end; + end; + ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8); + ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4); + SetRect(ATextRect, 0, 0, Screen.Width div 2, 0); + Tnt_DrawTextW(Canvas.Handle, PWideChar(Msg), Length(Msg) + 1, ATextRect, + DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or + DrawTextBiDiModeFlagsReadingOnly); + IconID := IconIDs[DlgType]; + IconTextWidth := ATextRect.Right; + IconTextHeight := ATextRect.Bottom; + if IconID <> nil then + begin + Inc(IconTextWidth, 32 + HorzSpacing); + if IconTextHeight < 32 then IconTextHeight := 32; + end; + ButtonCount := 0; + for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do + if B in Buttons then Inc(ButtonCount); + ButtonGroupWidth := 0; + if ButtonCount <> 0 then + ButtonGroupWidth := ButtonWidth * ButtonCount + + ButtonSpacing * (ButtonCount - 1); + ClientWidth := Max(IconTextWidth, ButtonGroupWidth) + HorzMargin * 2; + ClientHeight := IconTextHeight + ButtonHeight + VertSpacing + + VertMargin * 2; + Left := (Screen.Width div 2) - (Width div 2); + Top := (Screen.Height div 2) - (Height div 2); + if DlgType <> mtCustom then + Caption := GetMessageCaption(DlgType) + else + Caption := TntApplication.Title; + if IconID <> nil then + with TTntImage.Create(Result) do + begin + Name := 'Image'; + Parent := Result; + Picture.Icon.Handle := LoadIcon(0, IconID); + SetBounds(HorzMargin, VertMargin, 32, 32); + end; + TTntMessageForm(Result).Message := TTntLabel.Create(Result); + with TTntMessageForm(Result).Message do + begin + Name := 'Message'; + Parent := Result; + WordWrap := True; + Caption := Msg; + BoundsRect := ATextRect; + BiDiMode := Result.BiDiMode; + ALeft := IconTextWidth - ATextRect.Right + HorzMargin; + if UseRightToLeftAlignment then + ALeft := Result.ClientWidth - ALeft - Width; + SetBounds(ALeft, VertMargin, + ATextRect.Right, ATextRect.Bottom); + end; + if mbCancel in Buttons then CancelButton := mbCancel else + if mbNo in Buttons then CancelButton := mbNo else + CancelButton := mbOk; + X := (ClientWidth - ButtonGroupWidth) div 2; + for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do + if B in Buttons then + begin + LButton := TTntButton.Create(Result); + with LButton do + begin + Name := ButtonNames[B]; + Parent := Result; + Caption := GetButtonCaption(B); + ModalResult := ModalResults[B]; + if B = DefaultButton then + begin + Default := True; + ActiveControl := LButton; + end; + if B = CancelButton then + Cancel := True; + SetBounds(X, IconTextHeight + VertMargin + VertSpacing, + ButtonWidth, ButtonHeight); + Inc(X, ButtonWidth + ButtonSpacing); + if B = mbHelp then + OnClick := TTntMessageForm(Result).HelpButtonClick; + end; + end; + end; +end; + +function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons): TTntForm; +var + DefaultButton: TMsgDlgBtn; +begin + if mbOk in Buttons then DefaultButton := mbOk else + if mbYes in Buttons then DefaultButton := mbYes else + DefaultButton := mbRetry; + Result := WideCreateMessageDialog(Msg, DlgType, Buttons, DefaultButton); +end; + +function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): Integer; +begin + Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, -1, -1, '', DefaultButton); +end; + +function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; +begin + Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, -1, -1, ''); +end; + +function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; DefaultButton: TMsgDlgBtn): Integer; +begin + Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, X, Y, '', DefaultButton); +end; + +function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer; +begin + Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, X, Y, ''); +end; + +function _Internal_WideMessageDlgPosHelp(Dlg: TTntForm; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString): Integer; +begin + with Dlg do + try + HelpContext := HelpCtx; + HelpFile := HelpFileName; + if X >= 0 then Left := X; + if Y >= 0 then Top := Y; + if (Y < 0) and (X < 0) then Position := poScreenCenter; + Result := ShowModal; + finally + Free; + end; +end; + +function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString; DefaultButton: TMsgDlgBtn): Integer; +begin + Result := _Internal_WideMessageDlgPosHelp( + WideCreateMessageDialog(Msg, DlgType, Buttons, DefaultButton), HelpCtx, X, Y, HelpFileName); +end; + +function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString): Integer; +begin + Result := _Internal_WideMessageDlgPosHelp( + WideCreateMessageDialog(Msg, DlgType, Buttons), HelpCtx, X, Y, HelpFileName); +end; + +procedure WideShowMessage(const Msg: WideString); +begin + WideShowMessagePos(Msg, -1, -1); +end; + +procedure WideShowMessageFmt(const Msg: WideString; Params: array of const); +begin + WideShowMessage(WideFormat(Msg, Params)); +end; + +procedure WideShowMessagePos(const Msg: WideString; X, Y: Integer); +begin + WideMessageDlgPos(Msg, mtCustom, [mbOK], 0, X, Y); +end; + +{ Input dialog } + +function WideInputQuery(const ACaption, APrompt: WideString; var Value: WideString): Boolean; +var + Form: TTntForm; + Prompt: TTntLabel; + Edit: TTntEdit; + DialogUnits: TPoint; + ButtonTop, ButtonWidth, ButtonHeight: Integer; +begin + Result := False; + Form := TTntForm.Create(Application); + with Form do begin + try + BorderStyle := bsDialog; // By doing this first, it will work on WINE. + Canvas.Font := Font; + DialogUnits := GetAveCharSize(Canvas); + Caption := ACaption; + ClientWidth := MulDiv(180, DialogUnits.X, 4); + Position := poScreenCenter; + Prompt := TTntLabel.Create(Form); + with Prompt do + begin + Parent := Form; + Caption := APrompt; + Left := MulDiv(8, DialogUnits.X, 4); + Top := MulDiv(8, DialogUnits.Y, 8); + Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4); + WordWrap := True; + end; + Edit := TTntEdit.Create(Form); + with Edit do + begin + Parent := Form; + Left := Prompt.Left; + Top := Prompt.Top + Prompt.Height + 5; + Width := MulDiv(164, DialogUnits.X, 4); + MaxLength := 255; + Text := Value; + SelectAll; + end; + ButtonTop := Edit.Top + Edit.Height + 15; + ButtonWidth := MulDiv(50, DialogUnits.X, 4); + ButtonHeight := MulDiv(14, DialogUnits.Y, 8); + with TTntButton.Create(Form) do + begin + Parent := Form; + Caption := SMsgDlgOK; + ModalResult := mrOk; + Default := True; + SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth, + ButtonHeight); + end; + with TTntButton.Create(Form) do + begin + Parent := Form; + Caption := SMsgDlgCancel; + ModalResult := mrCancel; + Cancel := True; + SetBounds(MulDiv(92, DialogUnits.X, 4), Edit.Top + Edit.Height + 15, ButtonWidth, + ButtonHeight); + Form.ClientHeight := Top + Height + 13; + end; + if ShowModal = mrOk then + begin + Value := Edit.Text; + Result := True; + end; + finally + Form.Free; + end; + end; +end; + +function WideInputBox(const ACaption, APrompt, ADefault: WideString): WideString; +begin + Result := ADefault; + WideInputQuery(ACaption, APrompt, Result); +end; + +function WidePromptForFileName(var AFileName: WideString; const AFilter: WideString = ''; + const ADefaultExt: WideString = ''; const ATitle: WideString = ''; + const AInitialDir: WideString = ''; SaveDialog: Boolean = False): Boolean; +var + Dialog: TTntOpenDialog; +begin + if SaveDialog then + begin + Dialog := TTntSaveDialog.Create(nil); + Dialog.Options := Dialog.Options + [ofOverwritePrompt]; + end + else + Dialog := TTntOpenDialog.Create(nil); + with Dialog do + try + Title := ATitle; + DefaultExt := ADefaultExt; + if AFilter = '' then + Filter := SDefaultFilter else + Filter := AFilter; + InitialDir := AInitialDir; + FileName := AFileName; + Result := Execute; + if Result then + AFileName := FileName; + finally + Free; + end; +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas new file mode 100644 index 0000000000..cf1f342142 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas @@ -0,0 +1,1400 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntExtActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, TntActnList, ExtActns; + +type +{TNT-WARN TCustomFileRun} + TTntCustomFileRun = class(TCustomFileRun{TNT-ALLOW TCustomFileRun}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileRun} + TTntFileRun = class(TFileRun{TNT-ALLOW TFileRun}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditAction} + TTntRichEditAction = class(TRichEditAction{TNT-ALLOW TRichEditAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditBold} + TTntRichEditBold = class(TRichEditBold{TNT-ALLOW TRichEditBold}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditItalic} + TTntRichEditItalic = class(TRichEditItalic{TNT-ALLOW TRichEditItalic}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditUnderline} + TTntRichEditUnderline = class(TRichEditUnderline{TNT-ALLOW TRichEditUnderline}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditStrikeOut} + TTntRichEditStrikeOut = class(TRichEditStrikeOut{TNT-ALLOW TRichEditStrikeOut}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditBullets} + TTntRichEditBullets = class(TRichEditBullets{TNT-ALLOW TRichEditBullets}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditAlignLeft} + TTntRichEditAlignLeft = class(TRichEditAlignLeft{TNT-ALLOW TRichEditAlignLeft}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditAlignRight} + TTntRichEditAlignRight = class(TRichEditAlignRight{TNT-ALLOW TRichEditAlignRight}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditAlignCenter} + TTntRichEditAlignCenter = class(TRichEditAlignCenter{TNT-ALLOW TRichEditAlignCenter}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TTabAction} + TTntTabAction = class(TTabAction{TNT-ALLOW TTabAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TPreviousTab} + TTntPreviousTab = class(TPreviousTab{TNT-ALLOW TPreviousTab}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TNextTab} + TTntNextTab = class(TNextTab{TNT-ALLOW TNextTab}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TOpenPicture} + TTntOpenPicture = class(TOpenPicture{TNT-ALLOW TOpenPicture}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSavePicture} + TTntSavePicture = class(TSavePicture{TNT-ALLOW TSavePicture}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TURLAction} + TTntURLAction = class(TURLAction{TNT-ALLOW TURLAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TBrowseURL} + TTntBrowseURL = class(TBrowseURL{TNT-ALLOW TBrowseURL}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDownLoadURL} + TTntDownLoadURL = class(TDownLoadURL{TNT-ALLOW TDownLoadURL}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSendMail} + TTntSendMail = class(TSendMail{TNT-ALLOW TSendMail}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlAction} + TTntListControlAction = class(TListControlAction{TNT-ALLOW TListControlAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlCopySelection} + TTntListControlCopySelection = class(TListControlCopySelection{TNT-ALLOW TListControlCopySelection}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlDeleteSelection} + TTntListControlDeleteSelection = class(TListControlDeleteSelection{TNT-ALLOW TListControlDeleteSelection}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlSelectAll} + TTntListControlSelectAll = class(TListControlSelectAll{TNT-ALLOW TListControlSelectAll}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlClearSelection} + TTntListControlClearSelection = class(TListControlClearSelection{TNT-ALLOW TListControlClearSelection}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlMoveSelection} + TTntListControlMoveSelection = class(TListControlMoveSelection{TNT-ALLOW TListControlMoveSelection}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +implementation + +uses + ActnList, TntStdActns, TntClasses; + +{TNT-IGNORE-UNIT} + +procedure TntExtActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntStdActn_AfterInherited_Assign(Action, Source); + // TCustomFileRun + if (Action is TCustomFileRun) and (Source is TCustomFileRun) then begin + TCustomFileRun(Action).Browse := TCustomFileRun(Source).Browse; + if TCustomFileRun(Source).BrowseDlg.Owner <> Source then + TCustomFileRun(Action).BrowseDlg := TCustomFileRun(Source).BrowseDlg + else begin + { Carry over dialog properties. Currently TOpenDialog doesn't support Assign. } + { TCustomFileRun(Action).BrowseDlg.Assign(TCustomFileRun(Source).BrowseDlg); } + end; + TCustomFileRun(Action).Directory := TCustomFileRun(Source).Directory; + TCustomFileRun(Action).FileName := TCustomFileRun(Source).FileName; + TCustomFileRun(Action).Operation := TCustomFileRun(Source).Operation; + TCustomFileRun(Action).ParentControl := TCustomFileRun(Source).ParentControl; + TCustomFileRun(Action).Parameters := TCustomFileRun(Source).Parameters; + TCustomFileRun(Action).ShowCmd := TCustomFileRun(Source).ShowCmd; + end; + // TTabAction + if (Action is TTabAction) and (Source is TTabAction) then begin + TTabAction(Action).SkipHiddenTabs := TTabAction(Source).SkipHiddenTabs; + TTabAction(Action).TabControl := TTabAction(Source).TabControl; + TTabAction(Action).Wrap := TTabAction(Source).Wrap; + TTabAction(Action).BeforeTabChange := TTabAction(Source).BeforeTabChange; + TTabAction(Action).AfterTabChange := TTabAction(Source).AfterTabChange; + TTabAction(Action).OnValidateTab := TTabAction(Source).OnValidateTab; + end; + // TNextTab + if (Action is TNextTab) and (Source is TNextTab) then begin + TNextTab(Action).LastTabCaption := TNextTab(Source).LastTabCaption; + TNextTab(Action).OnFinish := TNextTab(Source).OnFinish; + end; + // TURLAction + if (Action is TURLAction) and (Source is TURLAction) then begin + TURLAction(Action).URL := TURLAction(Source).URL; + end; + // TBrowseURL + if (Action is TBrowseURL) and (Source is TBrowseURL) then begin + {$IFDEF COMPILER_7_UP} + TBrowseURL(Action).BeforeBrowse := TBrowseURL(Source).BeforeBrowse; + TBrowseURL(Action).AfterBrowse := TBrowseURL(Source).AfterBrowse; + {$ENDIF} + end; + // TDownloadURL + if (Action is TDownloadURL) and (Source is TDownloadURL) then begin + TDownloadURL(Action).FileName := TDownloadURL(Source).FileName; + {$IFDEF COMPILER_7_UP} + TDownloadURL(Action).BeforeDownload := TDownloadURL(Source).BeforeDownload; + TDownloadURL(Action).AfterDownload := TDownloadURL(Source).AfterDownload; + {$ENDIF} + TDownloadURL(Action).OnDownloadProgress := TDownloadURL(Source).OnDownloadProgress; + end; + // TSendMail + if (Action is TSendMail) and (Source is TSendMail) then begin + TSendMail(Action).Text := TSendMail(Source).Text; + end; + // TListControlAction + if (Action is TListControlAction) and (Source is TListControlAction) then begin + TListControlAction(Action).ListControl := TListControlAction(Source).ListControl; + end; + // TListControlCopySelection + if (Action is TListControlCopySelection) and (Source is TListControlCopySelection) then begin + TListControlCopySelection(Action).Destination := TListControlCopySelection(Source).Destination; + end; +end; + +//------------------------- +// TNT EXT ACTNS +//------------------------- + +{ TTntCustomFileRun } + +procedure TTntCustomFileRun.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCustomFileRun.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomFileRun.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCustomFileRun.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCustomFileRun.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCustomFileRun.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntFileRun } + +procedure TTntFileRun.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileRun.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileRun.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileRun.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileRun.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileRun.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditAction } + +procedure TTntRichEditAction.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditBold } + +procedure TTntRichEditBold.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditBold.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditBold.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditBold.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditBold.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditBold.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditItalic } + +procedure TTntRichEditItalic.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditItalic.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditItalic.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditItalic.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditItalic.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditItalic.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditUnderline } + +procedure TTntRichEditUnderline.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditUnderline.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditUnderline.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditUnderline.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditUnderline.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditUnderline.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditStrikeOut } + +procedure TTntRichEditStrikeOut.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditStrikeOut.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditStrikeOut.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditStrikeOut.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditStrikeOut.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditStrikeOut.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditBullets } + +procedure TTntRichEditBullets.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditBullets.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditBullets.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditBullets.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditBullets.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditBullets.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditAlignLeft } + +procedure TTntRichEditAlignLeft.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditAlignLeft.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditAlignLeft.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditAlignLeft.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditAlignLeft.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditAlignLeft.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditAlignRight } + +procedure TTntRichEditAlignRight.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditAlignRight.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditAlignRight.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditAlignRight.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditAlignRight.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditAlignRight.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditAlignCenter } + +procedure TTntRichEditAlignCenter.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditAlignCenter.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditAlignCenter.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditAlignCenter.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditAlignCenter.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditAlignCenter.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntTabAction } + +procedure TTntTabAction.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntTabAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntTabAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntTabAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntTabAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntTabAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntPreviousTab } + +procedure TTntPreviousTab.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntPreviousTab.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPreviousTab.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntPreviousTab.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntPreviousTab.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntPreviousTab.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntNextTab } + +procedure TTntNextTab.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntNextTab.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntNextTab.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntNextTab.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntNextTab.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntNextTab.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntOpenPicture } + +procedure TTntOpenPicture.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntOpenPicture.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntOpenPicture.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntOpenPicture.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntOpenPicture.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntOpenPicture.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSavePicture } + +procedure TTntSavePicture.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSavePicture.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSavePicture.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSavePicture.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSavePicture.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSavePicture.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntURLAction } + +procedure TTntURLAction.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntURLAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntURLAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntURLAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntURLAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntURLAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntBrowseURL } + +procedure TTntBrowseURL.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntBrowseURL.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntBrowseURL.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntBrowseURL.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntBrowseURL.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntBrowseURL.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDownLoadURL } + +procedure TTntDownLoadURL.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDownLoadURL.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDownLoadURL.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDownLoadURL.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDownLoadURL.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDownLoadURL.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSendMail } + +procedure TTntSendMail.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSendMail.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSendMail.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSendMail.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSendMail.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSendMail.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlAction } + +procedure TTntListControlAction.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlCopySelection } + +procedure TTntListControlCopySelection.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlCopySelection.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlCopySelection.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlCopySelection.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlCopySelection.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlCopySelection.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlDeleteSelection } + +procedure TTntListControlDeleteSelection.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlDeleteSelection.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlDeleteSelection.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlDeleteSelection.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlDeleteSelection.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlDeleteSelection.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlSelectAll } + +procedure TTntListControlSelectAll.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlSelectAll.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlSelectAll.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlSelectAll.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlSelectAll.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlSelectAll.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlClearSelection } + +procedure TTntListControlClearSelection.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlClearSelection.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlClearSelection.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlClearSelection.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlClearSelection.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlClearSelection.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlMoveSelection } + +procedure TTntListControlMoveSelection.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlMoveSelection.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlMoveSelection.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlMoveSelection.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlMoveSelection.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlMoveSelection.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas new file mode 100644 index 0000000000..4789fa714a --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas @@ -0,0 +1,1062 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntExtCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Messages, Controls, ExtCtrls, TntClasses, TntControls, TntStdCtrls, TntGraphics; + +type +{TNT-WARN TShape} + TTntShape = class(TShape{TNT-ALLOW TShape}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TPaintBox} + TTntPaintBox = class(TPaintBox{TNT-ALLOW TPaintBox}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TImage} + TTntImage = class(TImage{TNT-ALLOW TImage}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + function GetPicture: TTntPicture; + procedure SetPicture(const Value: TTntPicture); + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property Picture: TTntPicture read GetPicture write SetPicture; + end; + +{TNT-WARN TBevel} + TTntBevel = class(TBevel{TNT-ALLOW TBevel}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomPanel} + TTntCustomPanel = class(TCustomPanel{TNT-ALLOW TCustomPanel}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + protected + procedure Paint; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TPanel} + TTntPanel = class(TTntCustomPanel) + public + property DockManager; + published + property Align; + property Alignment; + property Anchors; + property AutoSize; + property BevelEdges; + property BevelInner; + property BevelKind; + property BevelOuter; + property BevelWidth; + property BiDiMode; + property BorderWidth; + property BorderStyle; + property Caption; + property Color; + property Constraints; + property Ctl3D; + property UseDockManager default True; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property FullRepaint; + property Font; + property Locked; + {$IFDEF COMPILER_10_UP} + property Padding; + {$ENDIF} + property ParentBiDiMode; + {$IFDEF COMPILER_7_UP} + property ParentBackground; + {$ENDIF} + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + {$IFDEF COMPILER_9_UP} + property VerticalAlignment; + {$ENDIF} + property Visible; + {$IFDEF COMPILER_9_UP} + property OnAlignInsertBefore; + property OnAlignPosition; + {$ENDIF} + property OnCanResize; + property OnClick; + property OnConstrainedResize; + property OnContextPopup; + property OnDockDrop; + property OnDockOver; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnResize; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +{TNT-WARN TCustomControlBar} + TTntCustomControlBar = class(TCustomControlBar{TNT-ALLOW TCustomControlBar}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TControlBar} + TTntControlBar = class(TTntCustomControlBar) + public + property Canvas; + published + property Align; + property Anchors; + property AutoDock; + property AutoDrag; + property AutoSize; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; + property BorderWidth; + property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; + property Constraints; + {$IFDEF COMPILER_10_UP} + property CornerEdge; + {$ENDIF} + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + {$IFDEF COMPILER_10_UP} + property DrawingStyle; + {$ENDIF} + property Enabled; + {$IFDEF COMPILER_10_UP} + property GradientDirection; + property GradientEndColor; + property GradientStartColor; + {$ENDIF} + {$IFDEF COMPILER_7_UP} + property ParentBackground default True; + {$ENDIF} + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property Picture; + property PopupMenu; + property RowSize; + property RowSnap; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + {$IFDEF COMPILER_9_UP} + property OnAlignInsertBefore; + property OnAlignPosition; + {$ENDIF} + property OnBandDrag; + property OnBandInfo; + property OnBandMove; + property OnBandPaint; + {$IFDEF COMPILER_9_UP} + property OnBeginBandMove; + property OnEndBandMove; + {$ENDIF} + property OnCanResize; + property OnClick; + property OnConstrainedResize; + property OnContextPopup; + property OnDockDrop; + property OnDockOver; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnPaint; + property OnResize; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +{TNT-WARN TCustomRadioGroup} + TTntCustomRadioGroup = class(TTntCustomGroupBox) + private + FButtons: TList; + FItems: TTntStrings; + FItemIndex: Integer; + FColumns: Integer; + FReading: Boolean; + FUpdating: Boolean; + function GetButtons(Index: Integer): TTntRadioButton; + procedure ArrangeButtons; + procedure ButtonClick(Sender: TObject); + procedure ItemsChange(Sender: TObject); + procedure SetButtonCount(Value: Integer); + procedure SetColumns(Value: Integer); + procedure SetItemIndex(Value: Integer); + procedure SetItems(Value: TTntStrings); + procedure UpdateButtons; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + procedure WMSize(var Message: TWMSize); message WM_SIZE; + protected + procedure Loaded; override; + procedure ReadState(Reader: TReader); override; + function CanModify: Boolean; virtual; + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + property Columns: Integer read FColumns write SetColumns default 1; + property ItemIndex: Integer read FItemIndex write SetItemIndex default -1; + property Items: TTntStrings read FItems write SetItems; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure FlipChildren(AllLevels: Boolean); override; + property Buttons[Index: Integer]: TTntRadioButton read GetButtons; + end; + +{TNT-WARN TRadioGroup} + TTntRadioGroup = class(TTntCustomRadioGroup) + published + property Align; + property Anchors; + property BiDiMode; + property Caption; + property Color; + property Columns; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property ItemIndex; + property Items; + property Constraints; + property ParentBiDiMode; + {$IFDEF COMPILER_7_UP} + property ParentBackground default True; + {$ENDIF} + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnStartDock; + property OnStartDrag; + end; + +{TNT-WARN TSplitter} + TTntSplitter = class(TSplitter{TNT-ALLOW TSplitter}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +implementation + +uses + Windows, Graphics, Forms, {$IFDEF THEME_7_UP} Themes, {$ENDIF} + TntSysUtils, TntWindows, TntActnList; + +{ TTntShape } + +procedure TTntShape.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntShape.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntShape.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntShape.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntShape.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntShape.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntShape.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntPaintBox } + +procedure TTntPaintBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPaintBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntPaintBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntPaintBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntPaintBox.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntPaintBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntPaintBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +type +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackImage = class(TGraphicControl) + protected + FPicture: TPicture{TNT-ALLOW TPicture}; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackImage = class(TGraphicControl) + protected + FPicture: TPicture{TNT-ALLOW TPicture}; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackImage = class(TGraphicControl) + private + FPicture: TPicture{TNT-ALLOW TPicture}; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackImage = class(TGraphicControl) + private + FPicture: TPicture{TNT-ALLOW TPicture}; + end; +{$ENDIF} + +{ TTntImage } + +constructor TTntImage.Create(AOwner: TComponent); +var + OldPicture: TPicture{TNT-ALLOW TPicture}; +begin + inherited; + OldPicture := THackImage(Self).FPicture; + THackImage(Self).FPicture := TTntPicture.Create; + Picture.OnChange := OldPicture.OnChange; + Picture.OnProgress := OldPicture.OnProgress; + OldPicture.Free; +end; + +function TTntImage.GetPicture: TTntPicture; +begin + Result := inherited Picture as TTntPicture; +end; + +procedure TTntImage.SetPicture(const Value: TTntPicture); +begin + inherited Picture := Value; +end; + +procedure TTntImage.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntImage.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntImage.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntImage.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntImage.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntImage.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntImage.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntBevel } + +procedure TTntBevel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntBevel.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntBevel.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntBevel.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntBevel.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntBevel.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntBevel.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomPanel } + +procedure TTntCustomPanel.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomPanel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomPanel.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntCustomPanel.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomPanel.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomPanel.Paint; +const + Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER); +var + Rect: TRect; + TopColor, BottomColor: TColor; + FontHeight: Integer; + Flags: Longint; + + procedure AdjustColors(Bevel: TPanelBevel); + begin + TopColor := clBtnHighlight; + if Bevel = bvLowered then TopColor := clBtnShadow; + BottomColor := clBtnShadow; + if Bevel = bvLowered then BottomColor := clBtnHighlight; + end; + +begin + if (not Win32PlatformIsUnicode) then + inherited + else begin + Rect := GetClientRect; + if BevelOuter <> bvNone then + begin + AdjustColors(BevelOuter); + Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); + end; + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled {$IFDEF COMPILER_7_UP} and ParentBackground {$ENDIF} then + InflateRect(Rect, -BorderWidth, -BorderWidth) + else + {$ENDIF} + begin + Frame3D(Canvas, Rect, Color, Color, BorderWidth); + end; + if BevelInner <> bvNone then + begin + AdjustColors(BevelInner); + Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); + end; + with Canvas do + begin + {$IFDEF THEME_7_UP} + if not ThemeServices.ThemesEnabled {$IFDEF COMPILER_7_UP} or not ParentBackground {$ENDIF} then + {$ENDIF} + begin + Brush.Color := Color; + FillRect(Rect); + end; + Brush.Style := bsClear; + Font := Self.Font; + FontHeight := WideCanvasTextHeight(Canvas, 'W'); + with Rect do + begin + Top := ((Bottom + Top) - FontHeight) div 2; + Bottom := Top + FontHeight; + end; + Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[Alignment]; + Flags := DrawTextBiDiModeFlags(Flags); + Tnt_DrawTextW(Handle, PWideChar(Caption), -1, Rect, Flags); + end; + end; +end; + +function TTntCustomPanel.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomPanel.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomPanel.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomPanel.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomPanel.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomControlBar } + +procedure TTntCustomControlBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomControlBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomControlBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomControlBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomControlBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomControlBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomControlBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntGroupButton } + +type + TTntGroupButton = class(TTntRadioButton) + private + FInClick: Boolean; + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + protected + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; + public + constructor InternalCreate(RadioGroup: TTntCustomRadioGroup); + destructor Destroy; override; + end; + +constructor TTntGroupButton.InternalCreate(RadioGroup: TTntCustomRadioGroup); +begin + inherited Create(RadioGroup); + RadioGroup.FButtons.Add(Self); + Visible := False; + Enabled := RadioGroup.Enabled; + ParentShowHint := False; + OnClick := RadioGroup.ButtonClick; + Parent := RadioGroup; +end; + +destructor TTntGroupButton.Destroy; +begin + TTntCustomRadioGroup(Owner).FButtons.Remove(Self); + inherited Destroy; +end; + +procedure TTntGroupButton.CNCommand(var Message: TWMCommand); +begin + if not FInClick then + begin + FInClick := True; + try + if ((Message.NotifyCode = BN_CLICKED) or + (Message.NotifyCode = BN_DOUBLECLICKED)) and + TTntCustomRadioGroup(Parent).CanModify then + inherited; + except + Application.HandleException(Self); + end; + FInClick := False; + end; +end; + +procedure TTntGroupButton.KeyPress(var Key: Char{TNT-ALLOW Char}); +begin + inherited KeyPress(Key); + TTntCustomRadioGroup(Parent).KeyPress(Key); + if (Key = #8) or (Key = ' ') then + begin + if not TTntCustomRadioGroup(Parent).CanModify then Key := #0; + end; +end; + +procedure TTntGroupButton.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited KeyDown(Key, Shift); + TTntCustomRadioGroup(Parent).KeyDown(Key, Shift); +end; + +{ TTntCustomRadioGroup } + +constructor TTntCustomRadioGroup.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := [csSetCaption, csDoubleClicks {$IFDEF COMPILER_7_UP}, csParentBackground {$ENDIF}]; + FButtons := TList.Create; + FItems := TTntStringList.Create; + TTntStringList(FItems).OnChange := ItemsChange; + FItemIndex := -1; + FColumns := 1; +end; + +destructor TTntCustomRadioGroup.Destroy; +begin + SetButtonCount(0); + TTntStringList(FItems).OnChange := nil; + FItems.Free; + FButtons.Free; + inherited Destroy; +end; + +procedure TTntCustomRadioGroup.FlipChildren(AllLevels: Boolean); +begin + { The radio buttons are flipped using BiDiMode } +end; + +procedure TTntCustomRadioGroup.ArrangeButtons; +var + ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer; + DC: HDC; + SaveFont: HFont; + Metrics: TTextMetric; + DeferHandle: THandle; + ALeft: Integer; +begin + if (FButtons.Count <> 0) and not FReading then + begin + DC := GetDC(0); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns; + ButtonWidth := (Width - 10) div FColumns; + I := Height - Metrics.tmHeight - 5; + ButtonHeight := I div ButtonsPerCol; + TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2; + DeferHandle := BeginDeferWindowPos(FButtons.Count); + try + for I := 0 to FButtons.Count - 1 do + with TTntGroupButton(FButtons[I]) do + begin + BiDiMode := Self.BiDiMode; + ALeft := (I div ButtonsPerCol) * ButtonWidth + 8; + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - ButtonWidth; + DeferHandle := DeferWindowPos(DeferHandle, Handle, 0, + ALeft, + (I mod ButtonsPerCol) * ButtonHeight + TopMargin, + ButtonWidth, ButtonHeight, + SWP_NOZORDER or SWP_NOACTIVATE); + Visible := True; + end; + finally + EndDeferWindowPos(DeferHandle); + end; + end; +end; + +procedure TTntCustomRadioGroup.ButtonClick(Sender: TObject); +begin + if not FUpdating then + begin + FItemIndex := FButtons.IndexOf(Sender); + Changed; + Click; + end; +end; + +procedure TTntCustomRadioGroup.ItemsChange(Sender: TObject); +begin + if not FReading then + begin + if FItemIndex >= FItems.Count then FItemIndex := FItems.Count - 1; + UpdateButtons; + end; +end; + +procedure TTntCustomRadioGroup.Loaded; +begin + inherited Loaded; + ArrangeButtons; +end; + +procedure TTntCustomRadioGroup.ReadState(Reader: TReader); +begin + FReading := True; + inherited ReadState(Reader); + FReading := False; + UpdateButtons; +end; + +procedure TTntCustomRadioGroup.SetButtonCount(Value: Integer); +begin + while FButtons.Count < Value do TTntGroupButton.InternalCreate(Self); + while FButtons.Count > Value do TTntGroupButton(FButtons.Last).Free; +end; + +procedure TTntCustomRadioGroup.SetColumns(Value: Integer); +begin + if Value < 1 then Value := 1; + if Value > 16 then Value := 16; + if FColumns <> Value then + begin + FColumns := Value; + ArrangeButtons; + Invalidate; + end; +end; + +procedure TTntCustomRadioGroup.SetItemIndex(Value: Integer); +begin + if FReading then FItemIndex := Value else + begin + if Value < -1 then Value := -1; + if Value >= FButtons.Count then Value := FButtons.Count - 1; + if FItemIndex <> Value then + begin + if FItemIndex >= 0 then + TTntGroupButton(FButtons[FItemIndex]).Checked := False; + FItemIndex := Value; + if FItemIndex >= 0 then + TTntGroupButton(FButtons[FItemIndex]).Checked := True; + end; + end; +end; + +procedure TTntCustomRadioGroup.SetItems(Value: TTntStrings); +begin + FItems.Assign(Value); +end; + +procedure TTntCustomRadioGroup.UpdateButtons; +var + I: Integer; +begin + SetButtonCount(FItems.Count); + for I := 0 to FButtons.Count - 1 do + TTntGroupButton(FButtons[I]).Caption := FItems[I]; + if FItemIndex >= 0 then + begin + FUpdating := True; + TTntGroupButton(FButtons[FItemIndex]).Checked := True; + FUpdating := False; + end; + ArrangeButtons; + Invalidate; +end; + +procedure TTntCustomRadioGroup.CMEnabledChanged(var Message: TMessage); +var + I: Integer; +begin + inherited; + for I := 0 to FButtons.Count - 1 do + TTntGroupButton(FButtons[I]).Enabled := Enabled; +end; + +procedure TTntCustomRadioGroup.CMFontChanged(var Message: TMessage); +begin + inherited; + ArrangeButtons; +end; + +procedure TTntCustomRadioGroup.WMSize(var Message: TWMSize); +begin + inherited; + ArrangeButtons; +end; + +function TTntCustomRadioGroup.CanModify: Boolean; +begin + Result := True; +end; + +procedure TTntCustomRadioGroup.GetChildren(Proc: TGetChildProc; Root: TComponent); +begin +end; + +function TTntCustomRadioGroup.GetButtons(Index: Integer): TTntRadioButton; +begin + Result := TTntRadioButton(FButtons[Index]); +end; + +{ TTntSplitter } + +procedure TTntSplitter.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSplitter.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntSplitter.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntSplitter.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntSplitter.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntSplitter.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntSplitter.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas new file mode 100644 index 0000000000..528c4f9f8f --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas @@ -0,0 +1,317 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntExtDlgs; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Windows, TntDialogs, TntExtCtrls, TntStdCtrls, TntButtons; + +type +{TNT-WARN TOpenPictureDialog} + TTntOpenPictureDialog = class(TTntOpenDialog) + private + FPicturePanel: TTntPanel; + FPictureLabel: TTntLabel; + FPreviewButton: TTntSpeedButton; + FPaintPanel: TTntPanel; + FImageCtrl: TTntImage; + FSavedFilename: WideString; + function IsFilterStored: Boolean; + procedure PreviewKeyPress(Sender: TObject; var Key: Char{TNT-ALLOW Char}); + protected + procedure PreviewClick(Sender: TObject); virtual; + procedure DoClose; override; + procedure DoSelectionChange; override; + procedure DoShow; override; + property ImageCtrl: TTntImage read FImageCtrl; + property PictureLabel: TTntLabel read FPictureLabel; + published + property Filter stored IsFilterStored; + public + constructor Create(AOwner: TComponent); override; + function Execute: Boolean; override; + {$IFDEF COMPILER_9_UP} + function Execute(ParentWnd: HWND): Boolean; override; + {$ENDIF} + end; + +{TNT-WARN TSavePictureDialog} + TTntSavePictureDialog = class(TTntOpenPictureDialog) + public + function Execute: Boolean; override; + {$IFDEF COMPILER_9_UP} + function Execute(ParentWnd: HWND): Boolean; override; + {$ENDIF} + end; + +implementation + +uses + ExtDlgs, {ExtDlgs is needed for a linked resource} Dialogs, Consts, Messages, + Graphics, Math, Controls, Forms, SysUtils, CommDlg, TntSysUtils, TntForms; + +{ TTntSilentPaintPanel } + +type + TTntSilentPaintPanel = class(TTntPanel) + protected + procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; + end; + +procedure TTntSilentPaintPanel.WMPaint(var Msg: TWMPaint); +begin + try + inherited; + except + Caption := SInvalidImage; + end; +end; + +{ TTntOpenPictureDialog } + +constructor TTntOpenPictureDialog.Create(AOwner: TComponent); +begin + inherited; + Filter := GraphicFilter(TGraphic); + FPicturePanel := TTntPanel.Create(Self); + with FPicturePanel do + begin + Name := 'PicturePanel'; + Caption := ''; + SetBounds(204, 5, 169, 200); + BevelOuter := bvNone; + BorderWidth := 6; + TabOrder := 1; + FPictureLabel := TTntLabel.Create(Self); + with FPictureLabel do + begin + Name := 'PictureLabel'; + Caption := ''; + SetBounds(6, 6, 157, 23); + Align := alTop; + AutoSize := False; + Parent := FPicturePanel; + end; + FPreviewButton := TTntSpeedButton.Create(Self); + with FPreviewButton do + begin + Name := 'PreviewButton'; + SetBounds(77, 1, 23, 22); + Enabled := False; + Glyph.LoadFromResourceName(FindClassHInstance(TOpenPictureDialog{TNT-ALLOW TOpenPictureDialog}), 'PREVIEWGLYPH'); + Hint := SPreviewLabel; + ParentShowHint := False; + ShowHint := True; + OnClick := PreviewClick; + Parent := FPicturePanel; + end; + FPaintPanel := TTntSilentPaintPanel.Create(Self); + with FPaintPanel do + begin + Name := 'PaintPanel'; + Caption := ''; + SetBounds(6, 29, 157, 145); + Align := alClient; + BevelInner := bvRaised; + BevelOuter := bvLowered; + TabOrder := 0; + FImageCtrl := TTntImage.Create(Self); + Parent := FPicturePanel; + with FImageCtrl do + begin + Name := 'PaintBox'; + Align := alClient; + OnDblClick := PreviewClick; + Parent := FPaintPanel; + Proportional := True; + Stretch := True; + Center := True; + IncrementalDisplay := True; + end; + end; + end; +end; + +procedure TTntOpenPictureDialog.DoClose; +begin + inherited; + { Hide any hint windows left behind } + Application.HideHint; +end; + +procedure TTntOpenPictureDialog.DoSelectionChange; +var + FullName: WideString; + ValidPicture: Boolean; + + function ValidFile(const FileName: WideString): Boolean; + begin + Result := WideFileGetAttr(FileName) <> $FFFFFFFF; + end; + +begin + FullName := FileName; + if FullName <> FSavedFilename then + begin + FSavedFilename := FullName; + ValidPicture := WideFileExists(FullName) and ValidFile(FullName); + if ValidPicture then + try + FImageCtrl.Picture.LoadFromFile(FullName); + FPictureLabel.Caption := WideFormat(SPictureDesc, + [FImageCtrl.Picture.Width, FImageCtrl.Picture.Height]); + FPreviewButton.Enabled := True; + FPaintPanel.Caption := ''; + except + ValidPicture := False; + end; + if not ValidPicture then + begin + FPictureLabel.Caption := SPictureLabel; + FPreviewButton.Enabled := False; + FImageCtrl.Picture := nil; + FPaintPanel.Caption := srNone; + end; + end; + inherited; +end; + +procedure TTntOpenPictureDialog.DoShow; +var + PreviewRect, StaticRect: TRect; +begin + { Set preview area to entire dialog } + GetClientRect(Handle, PreviewRect); + StaticRect := GetStaticRect; + { Move preview area to right of static area } + PreviewRect.Left := StaticRect.Left + (StaticRect.Right - StaticRect.Left); + Inc(PreviewRect.Top, 4); + FPicturePanel.BoundsRect := PreviewRect; + FPreviewButton.Left := FPaintPanel.BoundsRect.Right - FPreviewButton.Width - 2; + FImageCtrl.Picture := nil; + FSavedFilename := ''; + FPaintPanel.Caption := srNone; + FPicturePanel.ParentWindow := Handle; + inherited; +end; + +function TTntOpenPictureDialog.Execute: Boolean; +begin + if NewStyleControls and not (ofOldStyleDialog in Options) then + Template := 'DLGTEMPLATE' else + Template := nil; + Result := inherited Execute; +end; + +{$IFDEF COMPILER_9_UP} +function TTntOpenPictureDialog.Execute(ParentWnd: HWND): Boolean; +begin + if NewStyleControls and not (ofOldStyleDialog in Options) then + Template := 'DLGTEMPLATE' else + Template := nil; + Result := inherited Execute(ParentWnd); +end; +{$ENDIF} + +function TTntOpenPictureDialog.IsFilterStored: Boolean; +begin + Result := not (Filter = GraphicFilter(TGraphic)); +end; + +procedure TTntOpenPictureDialog.PreviewClick(Sender: TObject); +var + PreviewForm: TTntForm; + Panel: TTntPanel; +begin + PreviewForm := TTntForm.Create(Self); + with PreviewForm do + try + Name := 'PreviewForm'; + BorderStyle := bsSizeToolWin; // By doing this first, it will work on WINE. + Visible := False; + Caption := SPreviewLabel; + KeyPreview := True; + Position := poScreenCenter; + OnKeyPress := PreviewKeyPress; + Panel := TTntPanel.Create(PreviewForm); + with Panel do + begin + Name := 'Panel'; + Caption := ''; + Align := alClient; + BevelOuter := bvNone; + BorderStyle := bsSingle; + BorderWidth := 5; + Color := clWindow; + Parent := PreviewForm; + DoubleBuffered := True; + with TTntImage.Create(PreviewForm) do + begin + Name := 'Image'; + Align := alClient; + Stretch := True; + Proportional := True; + Center := True; + Picture.Assign(FImageCtrl.Picture); + Parent := Panel; + end; + end; + if FImageCtrl.Picture.Width > 0 then + begin + ClientWidth := Min(Monitor.Width * 3 div 4, + FImageCtrl.Picture.Width + (ClientWidth - Panel.ClientWidth)+ 10); + ClientHeight := Min(Monitor.Height * 3 div 4, + FImageCtrl.Picture.Height + (ClientHeight - Panel.ClientHeight) + 10); + end; + ShowModal; + finally + Free; + end; +end; + +procedure TTntOpenPictureDialog.PreviewKeyPress(Sender: TObject; var Key: Char{TNT-ALLOW Char}); +begin + if Key = Char{TNT-ALLOW Char}(VK_ESCAPE) then + (Sender as TTntForm).Close; +end; + +{ TSavePictureDialog } +function TTntSavePictureDialog.Execute: Boolean; +begin + if NewStyleControls and not (ofOldStyleDialog in Options) then + Template := 'DLGTEMPLATE' else + Template := nil; + + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetSaveFileNameA) + else + Result := DoExecuteW(@GetSaveFileNameW); +end; + +{$IFDEF COMPILER_9_UP} +function TTntSavePictureDialog.Execute(ParentWnd: HWND): Boolean; +begin + if NewStyleControls and not (ofOldStyleDialog in Options) then + Template := 'DLGTEMPLATE' else + Template := nil; + + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetSaveFileNameA, ParentWnd) + else + Result := DoExecuteW(@GetSaveFileNameW, ParentWnd); +end; +{$ENDIF} + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas new file mode 100644 index 0000000000..892bd801ae --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas @@ -0,0 +1,118 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntFileCtrl; + +{$INCLUDE TntCompilers.inc} + +interface + +{$WARN UNIT_PLATFORM OFF} + +uses + Classes, Windows, FileCtrl; + +{TNT-WARN SelectDirectory} +function WideSelectDirectory(const Caption: WideString; const Root: WideString; + var Directory: WideString): Boolean; + +implementation + +uses + SysUtils, Forms, ActiveX, ShlObj, ShellApi, TntSysUtils, TntWindows; + +function SelectDirCB_W(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall; +begin + if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then + SendMessageW(Wnd, BFFM_SETSELECTIONW, Integer(True), lpdata); + result := 0; +end; + +function WideSelectDirectory(const Caption: WideString; const Root: WideString; + var Directory: WideString): Boolean; +{$IFNDEF COMPILER_7_UP} +const + BIF_NEWDIALOGSTYLE = $0040; + BIF_USENEWUI = BIF_NEWDIALOGSTYLE or BIF_EDITBOX; +{$ENDIF} +var + WindowList: Pointer; + BrowseInfo: TBrowseInfoW; + Buffer: PWideChar; + OldErrorMode: Cardinal; + RootItemIDList, ItemIDList: PItemIDList; + ShellMalloc: IMalloc; + IDesktopFolder: IShellFolder; + Eaten, Flags: LongWord; + AnsiDirectory: AnsiString; +begin + if (not Win32PlatformIsUnicode) then begin + AnsiDirectory := Directory; + Result := SelectDirectory{TNT-ALLOW SelectDirectory}(Caption, Root, AnsiDirectory); + Directory := AnsiDirectory; + end else begin + Result := False; + if not WideDirectoryExists(Directory) then + Directory := ''; + FillChar(BrowseInfo, SizeOf(BrowseInfo), 0); + if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then + begin + Buffer := ShellMalloc.Alloc(MAX_PATH * SizeOf(WideChar)); + try + RootItemIDList := nil; + if Root <> '' then + begin + SHGetDesktopFolder(IDesktopFolder); + IDesktopFolder.ParseDisplayName(Application.Handle, nil, + POleStr(Root), Eaten, RootItemIDList, Flags); + end; + with BrowseInfo do + begin + {$IFDEF COMPILER_9_UP} + hWndOwner := Application.ActiveFormHandle; + {$ELSE} + hWndOwner := Application.Handle; + {$ENDIF} + pidlRoot := RootItemIDList; + pszDisplayName := Buffer; + lpszTitle := PWideChar(Caption); + ulFlags := BIF_RETURNONLYFSDIRS; + if Win32MajorVersion >= 5 then + ulFlags := ulFlags or BIF_USENEWUI; + if Directory <> '' then + begin + lpfn := SelectDirCB_W; + lParam := Integer(PWideChar(Directory)); + end; + end; + WindowList := DisableTaskWindows(0); + OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS); + try + ItemIDList := Tnt_ShBrowseForFolderW(BrowseInfo); + finally + SetErrorMode(OldErrorMode); + EnableTaskWindows(WindowList); + end; + Result := ItemIDList <> nil; + if Result then + begin + Tnt_ShGetPathFromIDListW(ItemIDList, Buffer); + ShellMalloc.Free(ItemIDList); + Directory := Buffer; + end; + finally + ShellMalloc.Free(Buffer); + end; + end; + end; +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas new file mode 100644 index 0000000000..1149ec8f32 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas @@ -0,0 +1,503 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntFormatStrUtils; + +{$INCLUDE TntCompilers.inc} + +interface + +// this unit provides functions to work with format strings + +uses + TntSysUtils; + +function GetCanonicalFormatStr(const _FormatString: WideString): WideString; +{$IFNDEF COMPILER_9_UP} +function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; + const Args: array of const + {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; +{$ENDIF} +procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); +function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; + +type + EFormatSpecError = class(ETntGeneralError); + +implementation + +uses + SysUtils, Math, TntClasses; + +resourcestring + SInvalidFormatSpecifier = 'Invalid Format Specifier: %s'; + SMismatchedArgumentTypes = 'Argument types for index %d do not match. (%s <> %s)'; + SMismatchedArgumentCounts = 'Number of format specifiers do not match.'; + +type + TFormatSpecifierType = (fstInteger, fstFloating, fstPointer, fstString); + +function GetFormatSpecifierType(const FormatSpecifier: WideString): TFormatSpecifierType; +var + LastChar: WideChar; +begin + LastChar := TntWideLastChar(FormatSpecifier); + case LastChar of + 'd', 'D', 'u', 'U', 'x', 'X': + result := fstInteger; + 'e', 'E', 'f', 'F', 'g', 'G', 'n', 'N', 'm', 'M': + result := fstFloating; + 'p', 'P': + result := fstPointer; + 's', 'S': + result := fstString + else + raise ETntInternalError.CreateFmt('Internal Error: Unexpected format type (%s)', [LastChar]); + end; +end; + +type + TFormatStrParser = class(TObject) + private + ParsedString: TBufferedWideString; + PFormatString: PWideChar; + LastIndex: Integer; + ExplicitCount: Integer; + ImplicitCount: Integer; + procedure RaiseInvalidFormatSpecifier; + function ParseChar(c: WideChar): Boolean; + procedure ForceParseChar(c: WideChar); + function ParseDigit: Boolean; + function ParseInteger: Boolean; + procedure ForceParseType; + function PeekDigit: Boolean; + function PeekIndexSpecifier(out Index: Integer): Boolean; + public + constructor Create(const _FormatString: WideString); + destructor Destroy; override; + function ParseFormatSpecifier: Boolean; + end; + +constructor TFormatStrParser.Create(const _FormatString: WideString); +begin + inherited Create; + PFormatString := PWideChar(_FormatString); + ExplicitCount := 0; + ImplicitCount := 0; + LastIndex := -1; + ParsedString := TBufferedWideString.Create; +end; + +destructor TFormatStrParser.Destroy; +begin + FreeAndNil(ParsedString); + inherited; +end; + +procedure TFormatStrParser.RaiseInvalidFormatSpecifier; +begin + raise EFormatSpecError.CreateFmt(SInvalidFormatSpecifier, [ParsedString.Value + PFormatString]); +end; + +function TFormatStrParser.ParseChar(c: WideChar): Boolean; +begin + result := False; + if PFormatString^ = c then begin + result := True; + ParsedString.AddChar(c); + Inc(PFormatString); + end; +end; + +procedure TFormatStrParser.ForceParseChar(c: WideChar); +begin + if not ParseChar(c) then + RaiseInvalidFormatSpecifier; +end; + +function TFormatStrParser.PeekDigit: Boolean; +begin + result := False; + if (PFormatString^ <> #0) + and (PFormatString^ >= '0') + and (PFormatString^ <= '9') then + result := True; +end; + +function TFormatStrParser.ParseDigit: Boolean; +begin + result := False; + if PeekDigit then begin + result := True; + ForceParseChar(PFormatString^); + end; +end; + +function TFormatStrParser.ParseInteger: Boolean; +const + MAX_INT_DIGITS = 6; +var + digitcount: integer; +begin + digitcount := 0; + While ParseDigit do begin + inc(digitcount); + end; + result := (digitcount > 0); + if digitcount > MAX_INT_DIGITS then + RaiseInvalidFormatSpecifier; +end; + +procedure TFormatStrParser.ForceParseType; +begin + if PFormatString^ = #0 then + RaiseInvalidFormatSpecifier; + + case PFormatString^ of + 'd', 'u', 'x', 'e', 'f', 'g', 'n', 'm', 'p', 's', + 'D', 'U', 'X', 'E', 'F', 'G', 'N', 'M', 'P', 'S': + begin + // do nothing + end + else + RaiseInvalidFormatSpecifier; + end; + ForceParseChar(PFormatString^); +end; + +function TFormatStrParser.PeekIndexSpecifier(out Index: Integer): Boolean; +var + SaveParsedString: WideString; + SaveFormatString: PWideChar; +begin + SaveParsedString := ParsedString.Value; + SaveFormatString := PFormatString; + try + ParsedString.Clear; + Result := False; + Index := -1; + if ParseInteger then begin + Index := StrToInt(ParsedString.Value); + if ParseChar(':') then + Result := True; + end; + finally + ParsedString.Clear; + ParsedString.AddString(SaveParsedString); + PFormatString := SaveFormatString; + end; +end; + +function TFormatStrParser.ParseFormatSpecifier: Boolean; +var + ExplicitIndex: Integer; +begin + Result := False; + // Parse entire format specifier + ForceParseChar('%'); + if (PFormatString^ <> #0) + and (not ParseChar(' ')) + and (not ParseChar('%')) then begin + if PeekIndexSpecifier(ExplicitIndex) then begin + Inc(ExplicitCount); + LastIndex := Max(LastIndex, ExplicitIndex); + end else begin + Inc(ImplicitCount); + Inc(LastIndex); + ParsedString.AddString(IntToStr(LastIndex)); + ParsedString.AddChar(':'); + end; + if ParseChar('*') then + begin + Inc(ImplicitCount); + Inc(LastIndex); + ParseChar(':'); + end else if ParseInteger then + ParseChar(':'); + ParseChar('-'); + if ParseChar('*') then begin + Inc(ImplicitCount); + Inc(LastIndex); + end else + ParseInteger; + if ParseChar('.') then begin + if not ParseChar('*') then + ParseInteger; + end; + ForceParseType; + Result := True; + end; +end; + +//----------------------------------- + +function GetCanonicalFormatStr(const _FormatString: WideString): WideString; +var + PosSpec: Integer; +begin + with TFormatStrParser.Create(_FormatString) do + try + // loop until no more '%' + PosSpec := Pos('%', PFormatString); + While PosSpec <> 0 do begin + try + // delete everything up until '%' + ParsedString.AddBuffer(PFormatString, PosSpec - 1); + Inc(PFormatString, PosSpec - 1); + // parse format specifier + ParseFormatSpecifier; + finally + PosSpec := Pos('%', PFormatString); + end; + end; + if ((ExplicitCount = 0) and (ImplicitCount = 1)) {simple expression} + or ((ExplicitCount > 0) and (ImplicitCount = 0)) {nothing converted} then + result := _FormatString {original} + else + result := ParsedString.Value + PFormatString; + finally + Free; + end; +end; + +{$IFNDEF COMPILER_9_UP} +function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; + const Args: array of const + {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; +{ This function replaces floating point format specifiers with their actual formatted values. + It also adds index specifiers so that the other format specifiers don't lose their place. + The reason for this is that WideFormat doesn't correctly format floating point specifiers. + See QC#4254. } +var + Parser: TFormatStrParser; + PosSpec: Integer; + Output: TBufferedWideString; +begin + Output := TBufferedWideString.Create; + try + Parser := TFormatStrParser.Create(_FormatString); + with Parser do + try + // loop until no more '%' + PosSpec := Pos('%', PFormatString); + While PosSpec <> 0 do begin + try + // delete everything up until '%' + Output.AddBuffer(PFormatString, PosSpec - 1); + Inc(PFormatString, PosSpec - 1); + // parse format specifier + ParsedString.Clear; + if (not ParseFormatSpecifier) + or (GetFormatSpecifierType(ParsedString.Value) <> fstFloating) then + Output.AddBuffer(ParsedString.BuffPtr, MaxInt) + {$IFDEF COMPILER_7_UP} + else if Assigned(FormatSettings) then + Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args, FormatSettings^)) + {$ENDIF} + else + Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args)); + finally + PosSpec := Pos('%', PFormatString); + end; + end; + Output.AddString(PFormatString); + finally + Free; + end; + Result := Output.Value; + finally + Output.Free; + end; +end; +{$ENDIF} + +procedure GetFormatArgs(const _FormatString: WideString; FormatArgs: TTntStrings); +var + PosSpec: Integer; +begin + with TFormatStrParser.Create(_FormatString) do + try + FormatArgs.Clear; + // loop until no more '%' + PosSpec := Pos('%', PFormatString); + While PosSpec <> 0 do begin + try + // delete everything up until '%' + Inc(PFormatString, PosSpec - 1); + // add format specifier to list + ParsedString.Clear; + if ParseFormatSpecifier then + FormatArgs.Add(ParsedString.Value); + finally + PosSpec := Pos('%', PFormatString); + end; + end; + finally + Free; + end; +end; + +function GetExplicitIndex(const FormatSpecifier: WideString): Integer; +var + IndexStr: WideString; + PosColon: Integer; +begin + result := -1; + PosColon := Pos(':', FormatSpecifier); + if PosColon <> 0 then begin + IndexStr := Copy(FormatSpecifier, 2, PosColon - 2); + result := StrToInt(IndexStr); + end; +end; + +function GetMaxIndex(FormatArgs: TTntStrings): Integer; +var + i: integer; + RunningIndex: Integer; + ExplicitIndex: Integer; +begin + result := -1; + RunningIndex := -1; + for i := 0 to FormatArgs.Count - 1 do begin + ExplicitIndex := GetExplicitIndex(FormatArgs[i]); + if ExplicitIndex <> -1 then + RunningIndex := ExplicitIndex + else + inc(RunningIndex); + result := Max(result, RunningIndex); + end; +end; + +procedure UpdateTypeList(FormatArgs, TypeList: TTntStrings); +var + i: integer; + f: WideString; + SpecType: TFormatSpecifierType; + ExplicitIndex: Integer; + MaxIndex: Integer; + RunningIndex: Integer; +begin + // set count of TypeList to accomodate maximum index + MaxIndex := GetMaxIndex(FormatArgs); + TypeList.Clear; + for i := 0 to MaxIndex do + TypeList.Add(''); + + // for each arg... + RunningIndex := -1; + for i := 0 to FormatArgs.Count - 1 do begin + f := FormatArgs[i]; + ExplicitIndex := GetExplicitIndex(f); + SpecType := GetFormatSpecifierType(f); + + // determine running arg index + if ExplicitIndex <> -1 then + RunningIndex := ExplicitIndex + else + inc(RunningIndex); + + if TypeList[RunningIndex] <> '' then begin + // already exists in list, check for compatibility + if TypeList.Objects[RunningIndex] <> TObject(SpecType) then + raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, + [RunningIndex, TypeList[RunningIndex], f]); + end else begin + // not in list so update it + TypeList[RunningIndex] := f; + TypeList.Objects[RunningIndex] := TObject(SpecType); + end; + end; +end; + +procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); +var + ArgList1: TTntStringList; + ArgList2: TTntStringList; + TypeList1: TTntStringList; + TypeList2: TTntStringList; + i: integer; +begin + ArgList1 := nil; + ArgList2 := nil; + TypeList1 := nil; + TypeList2 := nil; + try + ArgList1 := TTntStringList.Create; + ArgList2 := TTntStringList.Create; + TypeList1 := TTntStringList.Create; + TypeList2 := TTntStringList.Create; + + GetFormatArgs(FormatStr1, ArgList1); + UpdateTypeList(ArgList1, TypeList1); + + GetFormatArgs(FormatStr2, ArgList2); + UpdateTypeList(ArgList2, TypeList2); + + if TypeList1.Count <> TypeList2.Count then + raise EFormatSpecError.Create(SMismatchedArgumentCounts + CRLF + CRLF + '> ' + FormatStr1 + CRLF + '> ' + FormatStr2); + + for i := 0 to TypeList1.Count - 1 do begin + if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin + raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, + [i, TypeList1[i], TypeList2[i]]); + end; + end; + + finally + ArgList1.Free; + ArgList2.Free; + TypeList1.Free; + TypeList2.Free; + end; +end; + +function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; +var + ArgList1: TTntStringList; + ArgList2: TTntStringList; + TypeList1: TTntStringList; + TypeList2: TTntStringList; + i: integer; +begin + ArgList1 := nil; + ArgList2 := nil; + TypeList1 := nil; + TypeList2 := nil; + try + ArgList1 := TTntStringList.Create; + ArgList2 := TTntStringList.Create; + TypeList1 := TTntStringList.Create; + TypeList2 := TTntStringList.Create; + + GetFormatArgs(FormatStr1, ArgList1); + UpdateTypeList(ArgList1, TypeList1); + + GetFormatArgs(FormatStr2, ArgList2); + UpdateTypeList(ArgList2, TypeList2); + + Result := (TypeList1.Count = TypeList2.Count); + if Result then begin + for i := 0 to TypeList1.Count - 1 do begin + if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin + Result := False; + break; + end; + end; + end; + finally + ArgList1.Free; + ArgList2.Free; + TypeList1.Free; + TypeList2.Free; + end; +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas new file mode 100644 index 0000000000..780005714e --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas @@ -0,0 +1,873 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntForms; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Windows, Messages, Controls, Forms, TntControls; + +type +{TNT-WARN TScrollBox} + TTntScrollBox = class(TScrollBox{TNT-ALLOW TScrollBox}) + private + FWMSizeCallCount: Integer; + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + procedure WMSize(var Message: TWMSize); message WM_SIZE; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomFrame} + TTntCustomFrame = class(TCustomFrame{TNT-ALLOW TCustomFrame}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TFrame} + TTntFrame = class(TTntCustomFrame) + published + property Align; + property Anchors; + property AutoScroll; + property AutoSize; + property BiDiMode; + property Constraints; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Color nodefault; + property Ctl3D; + property Font; + {$IFDEF COMPILER_10_UP} + property Padding; + {$ENDIF} + {$IFDEF COMPILER_7_UP} + property ParentBackground default True; + {$ENDIF} + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + {$IFDEF COMPILER_9_UP} + property OnAlignInsertBefore; + property OnAlignPosition; + {$ENDIF} + property OnCanResize; + property OnClick; + property OnConstrainedResize; + property OnContextPopup; + property OnDblClick; + property OnDockDrop; + property OnDockOver; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnResize; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +{TNT-WARN TForm} + TTntForm = class(TForm{TNT-ALLOW TForm}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT; + procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED; + procedure WMWindowPosChanging(var Message: TMessage); message WM_WINDOWPOSCHANGING; + protected + procedure UpdateActions; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DestroyWindowHandle; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function CreateDockManager: IDockManager; override; + public + constructor Create(AOwner: TComponent); override; + procedure DefaultHandler(var Message); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + + TTntApplication = class(TComponent) + private + FMainFormChecked: Boolean; + FHint: WideString; + FTntAppIdleEventControl: TControl; + FSettingChangeTime: Cardinal; + FTitle: WideString; + function GetHint: WideString; + procedure SetAnsiAppHint(const Value: AnsiString); + procedure SetHint(const Value: WideString); + function GetExeName: WideString; + function IsDlgMsg(var Msg: TMsg): Boolean; + procedure DoIdle; + function GetTitle: WideString; + procedure SetTitle(const Value: WideString); + procedure SetAnsiApplicationTitle(const Value: AnsiString); + function ApplicationMouseControlHint: WideString; + protected + function WndProc(var Message: TMessage): Boolean; + function ProcessMessage(var Msg: TMsg): Boolean; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Hint: WideString read GetHint write SetHint; + property ExeName: WideString read GetExeName; + property SettingChangeTime: Cardinal read FSettingChangeTime; + property Title: WideString read GetTitle write SetTitle; + end; + +{TNT-WARN IsAccel} +function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean; + +{TNT-WARN PeekMessage} +{TNT-WARN PeekMessageA} +{TNT-WARN PeekMessageW} +procedure EnableManualPeekMessageWithRemove; +procedure DisableManualPeekMessageWithRemove; + +type + TFormProc = procedure (Form: TForm{TNT-ALLOW TForm}); + +var + TntApplication: TTntApplication; + +procedure InitTntEnvironment; + +implementation + +uses + SysUtils, Consts, RTLConsts, Menus, FlatSB, StdActns, + Graphics, TntSystem, TntSysUtils, TntMenus, TntActnList, TntStdActns, TntClasses; + +function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean; +var + W: WideChar; +begin + W := KeyUnicode(CharCode); + Result := WideSameText(W, WideGetHotKey(Caption)); +end; + +{ TTntScrollBox } + +procedure TTntScrollBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntScrollBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntScrollBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntScrollBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntScrollBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntScrollBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntScrollBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntScrollBox.WMSize(var Message: TWMSize); +begin + Inc(FWMSizeCallCount); + try + if FWMSizeCallCount < 32 then { Infinite recursion was encountered on Win 9x. } + inherited; + finally + Dec(FWMSizeCallCount); + end; +end; + +{ TTntCustomFrame } + +procedure TTntCustomFrame.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomFrame.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomFrame.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomFrame.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomFrame.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomFrame.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomFrame.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntForm } + +constructor TTntForm.Create(AOwner: TComponent); +begin + // standard construction technique (look at TForm.Create) + GlobalNameSpace.BeginWrite; + try + CreateNew(AOwner); + if (ClassType <> TTntForm) and not (csDesigning in ComponentState) then + begin + Include(FFormState, fsCreating); + try + if not InitInheritedComponent(Self, TTntForm) then + raise EResNotFound.CreateFmt(SResNotFound, [ClassName]); + finally + Exclude(FFormState, fsCreating); + end; + if OldCreateOrder then DoCreate; + end; + finally + GlobalNameSpace.EndWrite; + end; +end; + +procedure TTntForm.CreateWindowHandle(const Params: TCreateParams); +var + NewParams: TCreateParams; + WideWinClassName: WideString; +begin + if (not Win32PlatformIsUnicode) then + inherited + else if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then + begin + if (Application.MainForm = nil) or + (Application.MainForm.ClientHandle = 0) then + raise EInvalidOperation.Create(SNoMDIForm); + RegisterUnicodeClass(Params, WideWinClassName); + DefWndProc := @DefMDIChildProcW; + WindowHandle := CreateMDIWindowW(PWideChar(WideWinClassName), + nil, Params.style, Params.X, Params.Y, Params.Width, Params.Height, + Application.MainForm.ClientHandle, hInstance, Longint(Params.Param)); + if WindowHandle = 0 then + RaiseLastOSError; + SubClassUnicodeControl(Self, Params.Caption); + Include(FFormState, fsCreatedMDIChild); + end else + begin + NewParams := Params; + NewParams.ExStyle := NewParams.ExStyle and not WS_EX_LAYERED; + CreateUnicodeHandle(Self, NewParams, ''); + Exclude(FFormState, fsCreatedMDIChild); + end; + if AlphaBlend then begin + // toggle AlphaBlend to force update + AlphaBlend := False; + AlphaBlend := True; + end else if TransparentColor then begin + // toggle TransparentColor to force update + TransparentColor := False; + TransparentColor := True; + end; +end; + +procedure TTntForm.DestroyWindowHandle; +begin + if Win32PlatformIsUnicode then + UninitializeFlatSB(Handle); { Bug in VCL: Without this there might be a resource leak. } + inherited; +end; + +procedure TTntForm.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntForm.DefaultHandler(var Message); +begin + if (ClientHandle <> 0) + and (Win32PlatformIsUnicode) then begin + with TMessage(Message) do begin + if (Msg = WM_SIZE) then + Result := DefWindowProcW(Handle, Msg, wParam, lParam) + else + Result := DefFrameProcW(Handle, ClientHandle, Msg, wParam, lParam); + if (Msg = WM_DESTROY) then + Perform(TNT_WM_DESTROY, 0, 0); { This ensures that the control is Unsubclassed. } + end; + end else + inherited DefaultHandler(Message); +end; + +function TTntForm.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntForm.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntForm.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value) +end; + +function TTntForm.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntForm.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntForm.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntForm.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntForm.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntForm.WMMenuSelect(var Message: TWMMenuSelect); +var + MenuItem: TMenuItem{TNT-ALLOW TMenuItem}; + ID: Integer; + FindKind: TFindItemKind; +begin + if Menu <> nil then + with Message do + begin + MenuItem := nil; + if (MenuFlag <> $FFFF) or (IDItem <> 0) then + begin + FindKind := fkCommand; + ID := IDItem; + if MenuFlag and MF_POPUP <> 0 then + begin + FindKind := fkHandle; + ID := Integer(GetSubMenu(Menu, ID)); + end; + MenuItem := Self.Menu.FindItem(ID, FindKind); + end; + if MenuItem <> nil then + TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem)) + else + TntApplication.Hint := ''; + end; +end; + +procedure TTntForm.UpdateActions; +begin + inherited; + TntApplication.DoIdle; +end; + +procedure TTntForm.CMBiDiModeChanged(var Message: TMessage); +var + Loop: Integer; +begin + inherited; + for Loop := 0 to ComponentCount - 1 do + if Components[Loop] is TMenu then + FixMenuBiDiProblem(TMenu(Components[Loop])); +end; + +procedure TTntForm.WMWindowPosChanging(var Message: TMessage); +begin + inherited; + // This message *sometimes* means that the Menu.BiDiMode changed. + FixMenuBiDiProblem(Menu); +end; + +function TTntForm.CreateDockManager: IDockManager; +begin + if (DockManager = nil) and DockSite and UseDockManager then + HandleNeeded; // force TNT subclassing to occur first + Result := inherited CreateDockManager; +end; + +{ TTntApplication } + +constructor TTntApplication.Create(AOwner: TComponent); +begin + inherited; + Application.HookMainWindow(WndProc); + FSettingChangeTime := GetTickCount; + TntSysUtils._SettingChangeTime := GetTickCount; +end; + +destructor TTntApplication.Destroy; +begin + FreeAndNil(FTntAppIdleEventControl); + Application.UnhookMainWindow(WndProc); + inherited; +end; + +function TTntApplication.GetHint: WideString; +begin + // check to see if the hint has already been set on application.idle + if Application.Hint = AnsiString(ApplicationMouseControlHint) then + FHint := ApplicationMouseControlHint; + // get the synced string + Result := GetSyncedWideString(FHint, Application.Hint) +end; + +procedure TTntApplication.SetAnsiAppHint(const Value: AnsiString); +begin + Application.Hint := Value; +end; + +procedure TTntApplication.SetHint(const Value: WideString); +begin + SetSyncedWideString(Value, FHint, Application.Hint, SetAnsiAppHint); +end; + +function TTntApplication.GetExeName: WideString; +begin + Result := WideParamStr(0); +end; + +function TTntApplication.GetTitle: WideString; +begin + if (Application.Handle <> 0) and Win32PlatformIsUnicode then begin + SetLength(Result, DefWindowProcW(Application.Handle, WM_GETTEXTLENGTH, 0, 0) + 1); + DefWindowProcW(Application.Handle, WM_GETTEXT, Length(Result), Integer(PWideChar(Result))); + SetLength(Result, Length(Result) - 1); + end else + Result := GetSyncedWideString(FTitle, Application.Title); +end; + +procedure TTntApplication.SetAnsiApplicationTitle(const Value: AnsiString); +begin + Application.Title := Value; +end; + +procedure TTntApplication.SetTitle(const Value: WideString); +begin + if (Application.Handle <> 0) and Win32PlatformIsUnicode then begin + if (GetTitle <> Value) or (FTitle <> '') then begin + DefWindowProcW(Application.Handle, WM_SETTEXT, 0, lParam(PWideChar(Value))); + FTitle := ''; + end + end else + SetSyncedWideString(Value, FTitle, Application.Title, SetAnsiApplicationTitle); +end; + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackApplication = class(TComponent) + protected + FxxxxxxxxxHandle: HWnd; + FxxxxxxxxxBiDiMode: TBiDiMode; + FxxxxxxxxxBiDiKeyboard: AnsiString; + FxxxxxxxxxNonBiDiKeyboard: AnsiString; + FxxxxxxxxxObjectInstance: Pointer; + FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; + FMouseControl: TControl; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackApplication = class(TComponent) + protected + FxxxxxxxxxHandle: HWnd; + FxxxxxxxxxBiDiMode: TBiDiMode; + FxxxxxxxxxBiDiKeyboard: AnsiString; + FxxxxxxxxxNonBiDiKeyboard: AnsiString; + FxxxxxxxxxObjectInstance: Pointer; + FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; + FMouseControl: TControl; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackApplication = class(TComponent) + protected + FxxxxxxxxxHandle: HWnd; + FxxxxxxxxxBiDiMode: TBiDiMode; + FxxxxxxxxxBiDiKeyboard: AnsiString; + FxxxxxxxxxNonBiDiKeyboard: AnsiString; + FxxxxxxxxxObjectInstance: Pointer; + FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; + FMouseControl: TControl; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackApplication = class(TComponent) + protected + FxxxxxxxxxHandle: HWnd; + FxxxxxxxxxBiDiMode: TBiDiMode; + FxxxxxxxxxBiDiKeyboard: AnsiString; + FxxxxxxxxxNonBiDiKeyboard: AnsiString; + FxxxxxxxxxObjectInstance: Pointer; + FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; + FMouseControl: TControl; + end; +{$ENDIF} + +function TTntApplication.ApplicationMouseControlHint: WideString; +var + MouseControl: TControl; +begin + MouseControl := THackApplication(Application).FMouseControl; + Result := WideGetLongHint(WideGetHint(MouseControl)); +end; + +procedure TTntApplication.DoIdle; +begin + // update TntApplication.Hint only when Ansi encodings are the same... (otherwise there are problems with action menus) + if Application.Hint = AnsiString(ApplicationMouseControlHint) then + Hint := ApplicationMouseControlHint; +end; + +function TTntApplication.IsDlgMsg(var Msg: TMsg): Boolean; +begin + Result := False; + if (Application.DialogHandle <> 0) then begin + if IsWindowUnicode(Application.DialogHandle) then + Result := IsDialogMessageW(Application.DialogHandle, Msg) + else + Result := IsDialogMessageA(Application.DialogHandle, Msg); + end; +end; + +type + TTntAppIdleEventControl = class(TControl) + protected + procedure OnIdle(Sender: TObject); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + +constructor TTntAppIdleEventControl.Create(AOwner: TComponent); +begin + inherited; + ParentFont := False; { This allows Parent (Application) to be in another module. } + Parent := Application.MainForm; + Visible := True; + Action := TTntAction.Create(Self); + Action.OnExecute := OnIdle; + Action.OnUpdate := OnIdle; + TntApplication.FTntAppIdleEventControl := Self; +end; + +destructor TTntAppIdleEventControl.Destroy; +begin + if TntApplication <> nil then + TntApplication.FTntAppIdleEventControl := nil; + inherited; +end; + +procedure TTntAppIdleEventControl.OnIdle(Sender: TObject); +begin + TntApplication.DoIdle; +end; + +function TTntApplication.ProcessMessage(var Msg: TMsg): Boolean; +var + Handled: Boolean; +begin + Result := False; + // Check Main Form + if (not FMainFormChecked) and (Application.MainForm <> nil) then begin + if not (Application.MainForm is TTntForm) then begin + // This control will help ensure that DoIdle is called + TTntAppIdleEventControl.Create(Application.MainForm); + end; + FMainFormChecked := True; + end; + // Check for Unicode char messages + if (Msg.message = WM_CHAR) + and (Msg.wParam > Integer(High(AnsiChar))) + and IsWindowUnicode(Msg.hwnd) + and ((Application.DialogHandle = 0) or IsWindowUnicode(Application.DialogHandle)) + then begin + Result := True; + // more than 8-bit WM_CHAR destined for Unicode window + Handled := False; + if Assigned(Application.OnMessage) then + Application.OnMessage(Msg, Handled); + Application.CancelHint; + // dispatch msg if not a dialog message + if (not Handled) and (not IsDlgMsg(Msg)) then + DispatchMessageW(Msg); + end; +end; + +function TTntApplication.WndProc(var Message: TMessage): Boolean; +var + BasicAction: TBasicAction; +begin + Result := False; { not handled } + if (Message.Msg = WM_SETTINGCHANGE) then begin + FSettingChangeTime := GetTickCount; + TntSysUtils._SettingChangeTime := FSettingChangeTime; + end; + if (Message.Msg = WM_CREATE) + and (FTitle <> '') then begin + SetTitle(FTitle); + FTitle := ''; + end; + if (Message.Msg = CM_ACTIONEXECUTE) then begin + BasicAction := TBasicAction(Message.LParam); + if (BasicAction.ClassType = THintAction{TNT-ALLOW THintAction}) + and (THintAction{TNT-ALLOW THintAction}(BasicAction).Hint = AnsiString(Hint)) + then begin + Result := True; + Message.Result := 1; + with TTntHintAction.Create(Self) do + begin + Hint := Self.Hint; + try + Execute; + finally + Free; + end; + end; + end; + end; +end; + +//=========================================================================== +// The NT GetMessage Hook is needed to support entering Unicode +// characters directly from the keyboard (bypassing the IME). +// Special thanks go to Francisco Leong for developing this solution. +// +// Example: +// 1. Install "Turkic" language support. +// 2. Add "Azeri (Latin)" as an input locale. +// 3. In an EDIT, enter Shift+I. (You should see a capital "I" with dot.) +// 4. In an EDIT, enter single quote (US Keyboard). (You should see an upturned "e".) +// +var + ManualPeekMessageWithRemove: Integer = 0; + +procedure EnableManualPeekMessageWithRemove; +begin + Inc(ManualPeekMessageWithRemove); +end; + +procedure DisableManualPeekMessageWithRemove; +begin + if (ManualPeekMessageWithRemove > 0) then + Dec(ManualPeekMessageWithRemove); +end; + +var + NTGetMessageHook: HHOOK; + +function GetMessageForNT(Code: Integer; wParam: Integer; lParam: Integer): LRESULT; stdcall; +var + ThisMsg: PMSG; +begin + if (Code >= 0) + and (wParam = PM_REMOVE) + and (ManualPeekMessageWithRemove = 0) then + begin + ThisMsg := PMSG(lParam); + if (TntApplication <> nil) + and TntApplication.ProcessMessage(ThisMsg^) then + ThisMsg.message := WM_NULL; { clear for further processing } + end; + Result := CallNextHookEx(NTGetMessageHook, Code, wParam, lParam); +end; + +procedure CreateGetMessageHookForNT; +begin + Assert(Win32Platform = VER_PLATFORM_WIN32_NT); + NTGetMessageHook := SetWindowsHookExW(WH_GETMESSAGE, GetMessageForNT, 0, GetCurrentThreadID); + if NTGetMessageHook = 0 then + RaiseLastOSError; +end; + +//--------------------------------------------------------------------------------------------- +// Tnt Environment Setup +//--------------------------------------------------------------------------------------------- + +procedure InitTntEnvironment; + + function GetDefaultFont: WideString; + + function RunningUnderIDE: Boolean; + begin + Result := ModuleIsPackage and + ( WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'bds.exe') + or WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'delphi32.exe') + or WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'bcb.exe')); + end; + + function GetProfileStr(const Section, Key, Default: AnsiString; MaxLen: Integer): AnsiString; + var + Len: Integer; + begin + SetLength(Result, MaxLen + 1); + Len := GetProfileString(PAnsiChar(Section), PAnsiChar(Key), PAnsiChar(Default), + PAnsiChar(Result), Length(Result)); + SetLength(Result, Len); + end; + + procedure SetProfileStr(const Section, Key, Value: AnsiString); + var + DummyResult: Cardinal; + begin + try + Win32Check(WriteProfileString(PAnsiChar(Section), PAnsiChar(Key), PAnsiChar(Value))); + if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then + WriteProfileString(nil, nil, nil); {this flushes the WIN.INI cache} + SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, Integer(PAnsiChar(Section)), + SMTO_NORMAL, 250, DummyResult); + except + on E: Exception do begin + E.Message := 'Couldn''t create font substitutes.' + CRLF + E.Message; + Application.HandleException(nil); + end; + end; + end; + + var + ShellDlgFontName_1: WideString; + ShellDlgFontName_2: WideString; + begin + ShellDlgFontName_1 := GetProfileStr('FontSubstitutes', 'MS Shell Dlg', '', LF_FACESIZE); + if ShellDlgFontName_1 = '' then begin + ShellDlgFontName_1 := 'MS Sans Serif'; + SetProfileStr('FontSubstitutes', 'MS Shell Dlg', ShellDlgFontName_1); + end; + ShellDlgFontName_2 := GetProfileStr('FontSubstitutes', 'MS Shell Dlg 2', '', LF_FACESIZE); + if ShellDlgFontName_2 = '' then begin + if Screen.Fonts.IndexOf('Tahoma') <> -1 then + ShellDlgFontName_2 := 'Tahoma' + else + ShellDlgFontName_2 := ShellDlgFontName_1; + SetProfileStr('FontSubstitutes', 'MS Shell Dlg 2', ShellDlgFontName_2); + end; + if RunningUnderIDE then begin + Result := 'MS Shell Dlg 2' {Delphi is running} + end else + Result := ShellDlgFontName_2; + end; + +begin + // Tnt Environment Setup + InstallTntSystemUpdates; + DefFontData.Name := GetDefaultFont; + Forms.HintWindowClass := TntControls.TTntHintWindow; +end; + +initialization + TntApplication := TTntApplication.Create(nil); + if Win32Platform = VER_PLATFORM_WIN32_NT then + CreateGetMessageHookForNT; + +finalization + if NTGetMessageHook <> 0 then begin + UnhookWindowsHookEx(NTGetMessageHook) // no Win32Check, fails in too many cases, and doesn't matter + end; + FreeAndNil(TntApplication); + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas new file mode 100644 index 0000000000..617b901f77 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas @@ -0,0 +1,142 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntGraphics; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Graphics, Windows; + +{TNT-WARN TextRect} +procedure WideCanvasTextRect(Canvas: TCanvas; Rect: TRect; X, Y: Integer; const Text: WideString); +{TNT-WARN TextOut} +procedure WideCanvasTextOut(Canvas: TCanvas; X, Y: Integer; const Text: WideString); +{TNT-WARN TextExtent} +function WideCanvasTextExtent(Canvas: TCanvas; const Text: WideString): TSize; +function WideDCTextExtent(hDC: THandle; const Text: WideString): TSize; +{TNT-WARN TextWidth} +function WideCanvasTextWidth(Canvas: TCanvas; const Text: WideString): Integer; +{TNT-WARN TextHeight} +function WideCanvasTextHeight(Canvas: TCanvas; const Text: WideString): Integer; + +type +{TNT-WARN TPicture} + TTntPicture = class(TPicture{TNT-ALLOW TPicture}) + public + procedure LoadFromFile(const Filename: WideString); + procedure SaveToFile(const Filename: WideString); + end; + +implementation + +uses + SysUtils, TntSysUtils; + +type + TAccessCanvas = class(TCanvas); + +procedure WideCanvasTextRect(Canvas: TCanvas; Rect: TRect; X, Y: Integer; const Text: WideString); +var + Options: Longint; +begin + with TAccessCanvas(Canvas) do begin + Changing; + RequiredState([csHandleValid, csFontValid, csBrushValid]); + Options := ETO_CLIPPED or TextFlags; + if Brush.Style <> bsClear then + Options := Options or ETO_OPAQUE; + if ((TextFlags and ETO_RTLREADING) <> 0) and + (CanvasOrientation = coRightToLeft) then Inc(X, WideCanvasTextWidth(Canvas, Text) + 1); + Windows.ExtTextOutW(Handle, X, Y, Options, @Rect, PWideChar(Text), + Length(Text), nil); + Changed; + end; +end; + +procedure WideCanvasTextOut(Canvas: TCanvas; X, Y: Integer; const Text: WideString); +begin + with TAccessCanvas(Canvas) do begin + Changing; + RequiredState([csHandleValid, csFontValid, csBrushValid]); + if CanvasOrientation = coRightToLeft then Inc(X, WideCanvasTextWidth(Canvas, Text) + 1); + Windows.ExtTextOutW(Handle, X, Y, TextFlags, nil, PWideChar(Text), + Length(Text), nil); + MoveTo(X + WideCanvasTextWidth(Canvas, Text), Y); + Changed; + end; +end; + +function WideDCTextExtent(hDC: THandle; const Text: WideString): TSize; +begin + Result.cx := 0; + Result.cy := 0; + Windows.GetTextExtentPoint32W(hDC, PWideChar(Text), Length(Text), Result); +end; + +function WideCanvasTextExtent(Canvas: TCanvas; const Text: WideString): TSize; +begin + with TAccessCanvas(Canvas) do begin + RequiredState([csHandleValid, csFontValid]); + Result := WideDCTextExtent(Handle, Text); + end; +end; + +function WideCanvasTextWidth(Canvas: TCanvas; const Text: WideString): Integer; +begin + Result := WideCanvasTextExtent(Canvas, Text).cX; +end; + +function WideCanvasTextHeight(Canvas: TCanvas; const Text: WideString): Integer; +begin + Result := WideCanvasTextExtent(Canvas, Text).cY; +end; + +{ TTntPicture } + +procedure TTntPicture.LoadFromFile(const Filename: WideString); +var + ShortName: WideString; +begin + ShortName := WideExtractShortPathName(Filename); + if WideSameText(WideExtractFileExt(FileName), '.jpeg') // the short name ends with ".JPE"! + or (ShortName = '') then // GetShortPathName failed + inherited LoadFromFile(FileName) + else + inherited LoadFromFile(WideExtractShortPathName(Filename)); +end; + +procedure TTntPicture.SaveToFile(const Filename: WideString); +var + TempFile: WideString; +begin + if Graphic <> nil then begin + // create to temp file (ansi safe file name) + repeat + TempFile := WideExtractFilePath(Filename) + IntToStr(Random(MaxInt)) + WideExtractFileExt(Filename); + until not WideFileExists(TempFile); + CloseHandle(WideFileCreate(TempFile)); // make it a real file so that it has a temp + try + // save + Graphic.SaveToFile(WideExtractShortPathName(TempFile)); + // rename + WideDeleteFile(Filename); + if not WideRenameFile(TempFile, FileName) then + RaiseLastOSError; + finally + WideDeleteFile(TempFile); + end; + end; +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas new file mode 100644 index 0000000000..8096cd445b --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas @@ -0,0 +1,675 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntGrids; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, TntClasses, Grids, Windows, Controls, Messages; + +type +{TNT-WARN TInplaceEdit} + TTntInplaceEdit = class(TInplaceEdit{TNT-ALLOW TInplaceEdit}) + private + function GetText: WideString; + procedure SetText(const Value: WideString); + protected + procedure UpdateContents; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + public + property Text: WideString read GetText write SetText; + end; + + TTntGetEditEvent = procedure (Sender: TObject; ACol, ARow: Longint; var Value: WideString) of object; + TTntSetEditEvent = procedure (Sender: TObject; ACol, ARow: Longint; const Value: WideString) of object; + +{TNT-WARN TCustomDrawGrid} + _TTntInternalCustomDrawGrid = class(TCustomDrawGrid{TNT-ALLOW TCustomDrawGrid}) + private + FSettingEditText: Boolean; + procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); dynamic; abstract; + protected + procedure SetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; + end; + + TTntCustomDrawGrid = class(_TTntInternalCustomDrawGrid) + private + FOnGetEditText: TTntGetEditEvent; + FOnSetEditText: TTntSetEditEvent; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Msg: TWMChar); message WM_CHAR; + protected + function CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; override; + procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; + function GetEditText(ACol, ARow: Longint): WideString; reintroduce; virtual; + procedure SetEditText(ACol, ARow: Longint; const Value: WideString); reintroduce; virtual; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure ShowEditorChar(Ch: WideChar); dynamic; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + property OnGetEditText: TTntGetEditEvent read FOnGetEditText write FOnGetEditText; + property OnSetEditText: TTntSetEditEvent read FOnSetEditText write FOnSetEditText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TDrawGrid} + TTntDrawGrid = class(TTntCustomDrawGrid) + published + property Align; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelKind; + property BevelOuter; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property Color; + property ColCount; + property Constraints; + property Ctl3D; + property DefaultColWidth; + property DefaultRowHeight; + property DefaultDrawing; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property FixedColor; + property FixedCols; + property RowCount; + property FixedRows; + property Font; + property GridLineWidth; + property Options; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ScrollBars; + property ShowHint; + property TabOrder; + property Visible; + property VisibleColCount; + property VisibleRowCount; + property OnClick; + property OnColumnMoved; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawCell; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetEditMask; + property OnGetEditText; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnRowMoved; + property OnSelectCell; + property OnSetEditText; + property OnStartDock; + property OnStartDrag; + property OnTopLeftChanged; + end; + + TTntStringGrid = class; + +{TNT-WARN TStringGridStrings} + TTntStringGridStrings = class(TTntStrings) + private + FIsCol: Boolean; + FColRowIndex: Integer; + FGrid: TTntStringGrid; + function GridAnsiStrings: TStrings{TNT-ALLOW TStrings}; + protected + function Get(Index: Integer): WideString; override; + procedure Put(Index: Integer; const S: WideString); override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + constructor Create(AGrid: TTntStringGrid; AIndex: Longint); + function Add(const S: WideString): Integer; override; + procedure Assign(Source: TPersistent); override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: WideString); override; + end; + +{TNT-WARN TStringGrid} + _TTntInternalStringGrid = class(TStringGrid{TNT-ALLOW TStringGrid}) + private + FSettingEditText: Boolean; + procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); dynamic; abstract; + protected + procedure SetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; + end; + + TTntStringGrid = class(_TTntInternalStringGrid) + private + FCreatedRowStrings: TStringList{TNT-ALLOW TStringList}; + FCreatedColStrings: TStringList{TNT-ALLOW TStringList}; + FOnGetEditText: TTntGetEditEvent; + FOnSetEditText: TTntSetEditEvent; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Msg: TWMChar); message WM_CHAR; + function GetCells(ACol, ARow: Integer): WideString; + procedure SetCells(ACol, ARow: Integer; const Value: WideString); + function FindGridStrings(const IsCol: Boolean; const ListIndex: Integer): TTntStrings; + function GetCols(Index: Integer): TTntStrings; + function GetRows(Index: Integer): TTntStrings; + procedure SetCols(Index: Integer; const Value: TTntStrings); + procedure SetRows(Index: Integer; const Value: TTntStrings); + protected + function CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; override; + procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override; + procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; + function GetEditText(ACol, ARow: Longint): WideString; reintroduce; virtual; + procedure SetEditText(ACol, ARow: Longint; const Value: WideString); reintroduce; virtual; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure ShowEditorChar(Ch: WideChar); dynamic; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Cells[ACol, ARow: Integer]: WideString read GetCells write SetCells; + property Cols[Index: Integer]: TTntStrings read GetCols write SetCols; + property Rows[Index: Integer]: TTntStrings read GetRows write SetRows; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property OnGetEditText: TTntGetEditEvent read FOnGetEditText write FOnGetEditText; + property OnSetEditText: TTntSetEditEvent read FOnSetEditText write FOnSetEditText; + end; + +implementation + +uses + SysUtils, TntSystem, TntGraphics, TntControls, TntStdCtrls, TntActnList, TntSysUtils; + +{ TBinaryCompareAnsiStringList } +type + TBinaryCompareAnsiStringList = class(TStringList{TNT-ALLOW TStringList}) + protected + function CompareStrings(const S1, S2: string{TNT-ALLOW string}): Integer; override; + end; + +function TBinaryCompareAnsiStringList.CompareStrings(const S1, S2: string{TNT-ALLOW string}): Integer; +begin + // must compare strings via binary for speed + if S1 = S2 then + result := 0 + else if S1 < S2 then + result := -1 + else + result := 1; +end; + +{ TTntInplaceEdit } + +procedure TTntInplaceEdit.CreateWindowHandle(const Params: TCreateParams); +begin + TntCustomEdit_CreateWindowHandle(Self, Params); +end; + +function TTntInplaceEdit.GetText: WideString; +begin + if IsMasked then + Result := inherited Text + else + Result := TntControl_GetText(Self); +end; + +procedure TTntInplaceEdit.SetText(const Value: WideString); +begin + if IsMasked then + inherited Text := Value + else + TntControl_SetText(Self, Value); +end; + +type TAccessCustomGrid = class(TCustomGrid); + +procedure TTntInplaceEdit.UpdateContents; +begin + Text := ''; + with TAccessCustomGrid(Grid) do + Self.EditMask := GetEditMask(Col, Row); + if (Grid is TTntStringGrid) then + with (Grid as TTntStringGrid) do + Self.Text := GetEditText(Col, Row) + else if (Grid is TTntCustomDrawGrid) then + with (Grid as TTntCustomDrawGrid) do + Self.Text := GetEditText(Col, Row) + else + with TAccessCustomGrid(Grid) do + Self.Text := GetEditText(Col, Row); + with TAccessCustomGrid(Grid) do + Self.MaxLength := GetEditLimit; +end; + +{ _TTntInternalCustomDrawGrid } + +procedure _TTntInternalCustomDrawGrid.SetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); +begin + if FSettingEditText then + inherited + else + InternalSetEditText(ACol, ARow, Value); +end; + + +{ TTntCustomDrawGrid } + +function TTntCustomDrawGrid.CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; +begin + Result := TTntInplaceEdit.Create(Self); +end; + +procedure TTntCustomDrawGrid.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomDrawGrid.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomDrawGrid.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomDrawGrid.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomDrawGrid.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntCustomDrawGrid.GetEditText(ACol, ARow: Integer): WideString; +begin + Result := ''; + if Assigned(FOnGetEditText) then FOnGetEditText(Self, ACol, ARow, Result); +end; + +procedure TTntCustomDrawGrid.InternalSetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); +begin + if not FSettingEditText then + SetEditText(ACol, ARow, TntControl_GetText(InplaceEditor)); +end; + +procedure TTntCustomDrawGrid.SetEditText(ACol, ARow: Integer; const Value: WideString); +begin + if Assigned(FOnSetEditText) then FOnSetEditText(Self, ACol, ARow, Value); +end; + +procedure TTntCustomDrawGrid.WMChar(var Msg: TWMChar); +begin + if (goEditing in Options) + and (AnsiChar(Msg.CharCode) in [^H, #32..#255]) then begin + RestoreWMCharMsg(TMessage(Msg)); + ShowEditorChar(WideChar(Msg.CharCode)); + end else + inherited; +end; + +procedure TTntCustomDrawGrid.ShowEditorChar(Ch: WideChar); +begin + ShowEditor; + if InplaceEditor <> nil then begin + if Win32PlatformIsUnicode then + PostMessageW(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0) + else + PostMessageA(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0); + end; +end; + +procedure TTntCustomDrawGrid.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomDrawGrid.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntStringGridStrings } + +procedure TTntStringGridStrings.Assign(Source: TPersistent); +var + UTF8Strings: TStringList{TNT-ALLOW TStringList}; + i: integer; +begin + UTF8Strings := TStringList{TNT-ALLOW TStringList}.Create; + try + if Source is TStrings{TNT-ALLOW TStrings} then begin + for i := 0 to TStrings{TNT-ALLOW TStrings}(Source).Count - 1 do + UTF8Strings.AddObject(WideStringToUTF8(WideString(TStrings{TNT-ALLOW TStrings}(Source).Strings[i])), + TStrings{TNT-ALLOW TStrings}(Source).Objects[i]); + GridAnsiStrings.Assign(UTF8Strings); + end else if Source is TTntStrings then begin + for i := 0 to TTntStrings(Source).Count - 1 do + UTF8Strings.AddObject(WideStringToUTF8(TTntStrings(Source).Strings[i]), + TTntStrings(Source).Objects[i]); + GridAnsiStrings.Assign(UTF8Strings); + end else + GridAnsiStrings.Assign(Source); + finally + UTF8Strings.Free; + end; +end; + +function TTntStringGridStrings.GridAnsiStrings: TStrings{TNT-ALLOW TStrings}; +begin + Assert(Assigned(FGrid)); + if FIsCol then + Result := TStringGrid{TNT-ALLOW TStringGrid}(FGrid).Cols[FColRowIndex] + else + Result := TStringGrid{TNT-ALLOW TStringGrid}(FGrid).Rows[FColRowIndex]; +end; + +procedure TTntStringGridStrings.Clear; +begin + GridAnsiStrings.Clear; +end; + +procedure TTntStringGridStrings.Delete(Index: Integer); +begin + GridAnsiStrings.Delete(Index); +end; + +function TTntStringGridStrings.GetCount: Integer; +begin + Result := GridAnsiStrings.Count; +end; + +function TTntStringGridStrings.Get(Index: Integer): WideString; +begin + Result := UTF8ToWideString(GridAnsiStrings[Index]); +end; + +procedure TTntStringGridStrings.Put(Index: Integer; const S: WideString); +begin + GridAnsiStrings[Index] := WideStringToUTF8(S); +end; + +procedure TTntStringGridStrings.Insert(Index: Integer; const S: WideString); +begin + GridAnsiStrings.Insert(Index, WideStringToUTF8(S)); +end; + +function TTntStringGridStrings.Add(const S: WideString): Integer; +begin + Result := GridAnsiStrings.Add(WideStringToUTF8(S)); +end; + +function TTntStringGridStrings.GetObject(Index: Integer): TObject; +begin + Result := GridAnsiStrings.Objects[Index]; +end; + +procedure TTntStringGridStrings.PutObject(Index: Integer; AObject: TObject); +begin + GridAnsiStrings.Objects[Index] := AObject; +end; + +type TAccessStrings = class(TStrings{TNT-ALLOW TStrings}); + +procedure TTntStringGridStrings.SetUpdateState(Updating: Boolean); +begin + TAccessStrings(GridAnsiStrings).SetUpdateState(Updating); +end; + +constructor TTntStringGridStrings.Create(AGrid: TTntStringGrid; AIndex: Integer); +begin + inherited Create; + FGrid := AGrid; + if AIndex > 0 then begin + FIsCol := False; + FColRowIndex := AIndex - 1; + end else begin + FIsCol := True; + FColRowIndex := -AIndex - 1; + end; +end; + +{ _TTntInternalStringGrid } + +procedure _TTntInternalStringGrid.SetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); +begin + if FSettingEditText then + inherited + else + InternalSetEditText(ACol, ARow, Value); +end; + +{ TTntStringGrid } + +constructor TTntStringGrid.Create(AOwner: TComponent); +begin + inherited; + FCreatedRowStrings := TBinaryCompareAnsiStringList.Create; + FCreatedRowStrings.Sorted := True; + FCreatedRowStrings.Duplicates := dupError; + FCreatedColStrings := TBinaryCompareAnsiStringList.Create; + FCreatedColStrings.Sorted := True; + FCreatedColStrings.Duplicates := dupError; +end; + +destructor TTntStringGrid.Destroy; +var + i: integer; +begin + for i := FCreatedColStrings.Count - 1 downto 0 do + FCreatedColStrings.Objects[i].Free; + for i := FCreatedRowStrings.Count - 1 downto 0 do + FCreatedRowStrings.Objects[i].Free; + FreeAndNil(FCreatedColStrings); + FreeAndNil(FCreatedRowStrings); + inherited; +end; + +function TTntStringGrid.CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; +begin + Result := TTntInplaceEdit.Create(Self); +end; + +procedure TTntStringGrid.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntStringGrid.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntStringGrid.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntStringGrid.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntStringGrid.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntStringGrid.GetCells(ACol, ARow: Integer): WideString; +begin + Result := UTF8ToWideString(inherited Cells[ACol, ARow]) +end; + +procedure TTntStringGrid.SetCells(ACol, ARow: Integer; const Value: WideString); +var + UTF8Str: AnsiString; +begin + UTF8Str := WideStringToUTF8(Value); + if inherited Cells[ACol, ARow] <> UTF8Str then + inherited Cells[ACol, ARow] := UTF8Str; +end; + +function TTntStringGrid.FindGridStrings(const IsCol: Boolean; const ListIndex: Integer): TTntStrings; +var + idx: integer; + SrcStrings: TStrings{TNT-ALLOW TStrings}; + RCIndex: Integer; +begin + if IsCol then + SrcStrings := FCreatedColStrings + else + SrcStrings := FCreatedRowStrings; + Assert(Assigned(SrcStrings)); + idx := SrcStrings.IndexOf(IntToStr(ListIndex)); + if idx <> -1 then + Result := SrcStrings.Objects[idx] as TTntStrings + else begin + if IsCol then RCIndex := -ListIndex - 1 else RCIndex := ListIndex + 1; + Result := TTntStringGridStrings.Create(Self, RCIndex); + SrcStrings.AddObject(IntToStr(ListIndex), Result); + end; +end; + +function TTntStringGrid.GetCols(Index: Integer): TTntStrings; +begin + Result := FindGridStrings(True, Index); +end; + +function TTntStringGrid.GetRows(Index: Integer): TTntStrings; +begin + Result := FindGridStrings(False, Index); +end; + +procedure TTntStringGrid.SetCols(Index: Integer; const Value: TTntStrings); +begin + FindGridStrings(True, Index).Assign(Value); +end; + +procedure TTntStringGrid.SetRows(Index: Integer; const Value: TTntStrings); +begin + FindGridStrings(False, Index).Assign(Value); +end; + +procedure TTntStringGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState); +var + SaveDefaultDrawing: Boolean; +begin + if DefaultDrawing then + WideCanvasTextRect(Canvas, ARect, ARect.Left+2, ARect.Top+2, Cells[ACol, ARow]); + SaveDefaultDrawing := DefaultDrawing; + try + DefaultDrawing := False; + inherited DrawCell(ACol, ARow, ARect, AState); + finally + DefaultDrawing := SaveDefaultDrawing; + end; +end; + +function TTntStringGrid.GetEditText(ACol, ARow: Integer): WideString; +begin + Result := Cells[ACol, ARow]; + if Assigned(FOnGetEditText) then FOnGetEditText(Self, ACol, ARow, Result); +end; + +procedure TTntStringGrid.InternalSetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); +begin + if not FSettingEditText then + SetEditText(ACol, ARow, TntControl_GetText(InplaceEditor)); +end; + +procedure TTntStringGrid.SetEditText(ACol, ARow: Integer; const Value: WideString); +begin + FSettingEditText := True; + try + inherited SetEditText(ACol, ARow, WideStringToUTF8(Value)); + finally + FSettingEditText := False; + end; + if Assigned(FOnSetEditText) then FOnSetEditText(Self, ACol, ARow, Value); +end; + +procedure TTntStringGrid.WMChar(var Msg: TWMChar); +begin + if (goEditing in Options) + and (AnsiChar(Msg.CharCode) in [^H, #32..#255]) then begin + RestoreWMCharMsg(TMessage(Msg)); + ShowEditorChar(WideChar(Msg.CharCode)); + end else + inherited; +end; + +procedure TTntStringGrid.ShowEditorChar(Ch: WideChar); +begin + ShowEditor; + if InplaceEditor <> nil then begin + if Win32PlatformIsUnicode then + PostMessageW(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0) + else + PostMessageA(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0); + end; +end; + +procedure TTntStringGrid.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntStringGrid.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas new file mode 100644 index 0000000000..7219950865 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas @@ -0,0 +1,1011 @@ +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ } +{ Portions created by Wild Hunter are } +{ Copyright (c) 2003 Wild Hunter (raguotis@freemail.lt) } +{ } +{ Portions created by Stanley Xu are } +{ Copyright (c) 1999-2006 Stanley Xu } +{ (http://gosurfbrowser.com/?go=supportFeedback&ln=en) } +{ } +{ Portions created by Borland Software Corporation are } +{ Copyright (c) 1995-2001 Borland Software Corporation } +{ } +{*****************************************************************************} + +unit TntIniFiles; + +{$R-,T-,H+,X+} +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, IniFiles, + TntClasses; + +type + + TTntCustomIniFile = class({TCustomIniFile}TObject{TNT-ALLOW TObject}) + private + FFileName: WideString; + public + constructor Create(const FileName: WideString); + function SectionExists(const Section: WideString): Boolean; + function ReadString(const Section, Ident, Default: WideString): WideString; virtual; abstract; + procedure WriteString(const Section, Ident, Value: WideString); virtual; abstract; + function ReadInteger(const Section, Ident: WideString; Default: Longint): Longint; virtual; + procedure WriteInteger(const Section, Ident: WideString; Value: Longint); virtual; + function ReadBool(const Section, Ident: WideString; Default: Boolean): Boolean; virtual; + procedure WriteBool(const Section, Ident: WideString; Value: Boolean); virtual; + function ReadBinaryStream(const Section, Name: WideString; Value: TStream): Integer; virtual; + function ReadDate(const Section, Name: WideString; Default: TDateTime): TDateTime; virtual; + function ReadDateTime(const Section, Name: WideString; Default: TDateTime): TDateTime; virtual; + function ReadFloat(const Section, Name: WideString; Default: Double): Double; virtual; + function ReadTime(const Section, Name: WideString; Default: TDateTime): TDateTime; virtual; + procedure WriteBinaryStream(const Section, Name: WideString; Value: TStream); virtual; + procedure WriteDate(const Section, Name: WideString; Value: TDateTime); virtual; + procedure WriteDateTime(const Section, Name: WideString; Value: TDateTime); virtual; + procedure WriteFloat(const Section, Name: WideString; Value: Double); virtual; + procedure WriteTime(const Section, Name: WideString; Value: TDateTime); virtual; + procedure ReadSection(const Section: WideString; Strings: TTntStrings); virtual; abstract; + procedure ReadSections(Strings: TTntStrings); virtual; abstract; + procedure ReadSectionValues(const Section: WideString; Strings: TTntStrings); virtual; abstract; + procedure EraseSection(const Section: WideString); virtual; abstract; + procedure DeleteKey(const Section, Ident: WideString); virtual; abstract; + procedure UpdateFile; virtual; abstract; + function ValueExists(const Section, Ident: WideString): Boolean; + property FileName: WideString read FFileName; + end; + + { TTntStringHash - used internally by TTntMemIniFile to optimize searches. } + + PPTntHashItem = ^PTntHashItem; + PTntHashItem = ^TTntHashItem; + TTntHashItem = record + Next: PTntHashItem; + Key: WideString; + Value: Integer; + end; + + TTntStringHash = class + private + Buckets: array of PTntHashItem; + protected + function Find(const Key: WideString): PPTntHashItem; + function HashOf(const Key: WideString): Cardinal; virtual; + public + constructor Create(Size: Integer = 256); + destructor Destroy; override; + procedure Add(const Key: WideString; Value: Integer); + procedure Clear; + procedure Remove(const Key: WideString); + function Modify(const Key: WideString; Value: Integer): Boolean; + function ValueOf(const Key: WideString): Integer; + end; + + { TTntHashedStringList - A TTntStringList that uses TTntStringHash to improve the + speed of Find } + + TTntHashedStringList = class(TTntStringList) + private + FValueHash: TTntStringHash; + FNameHash: TTntStringHash; + FValueHashValid: Boolean; + FNameHashValid: Boolean; + procedure UpdateValueHash; + procedure UpdateNameHash; + protected + procedure Changed; override; + public + destructor Destroy; override; + function IndexOf(const S: WideString): Integer; override; + function IndexOfName(const Name: WideString): Integer; override; + end; + + { TTntMemIniFile - loads and entire ini file into memory and allows all + operations to be performed on the memory image. The image can then + be written out to the disk file } + + TTntMemIniFile = class(TTntCustomIniFile) + private + FSections: TTntStringList; + function AddSection(const Section: WideString): TTntStrings; + function GetCaseSensitive: Boolean; + procedure SetCaseSensitive(Value: Boolean); + procedure LoadValues; + public + constructor Create(const FileName: WideString); virtual; + destructor Destroy; override; + procedure Clear; + procedure DeleteKey(const Section, Ident: WideString); override; + procedure EraseSection(const Section: WideString); override; + procedure GetStrings(List: TTntStrings); + procedure ReadSection(const Section: WideString; Strings: TTntStrings); override; + procedure ReadSections(Strings: TTntStrings); override; + procedure ReadSectionValues(const Section: WideString; Strings: TTntStrings); override; + function ReadString(const Section, Ident, Default: WideString): WideString; override; + procedure Rename(const FileName: WideString; Reload: Boolean); + procedure SetStrings(List: TTntStrings); + procedure UpdateFile; override; + procedure WriteString(const Section, Ident, Value: WideString); override; + property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; + end; + +{$IFDEF MSWINDOWS} + { TTntIniFile - Encapsulates the Windows INI file interface + (Get/SetPrivateProfileXXX functions) } + + TTntIniFile = class(TTntCustomIniFile) + private + FAnsiIniFile: TIniFile; // For compatibility with Windows 95/98/Me + public + constructor Create(const FileName: WideString); virtual; + destructor Destroy; override; + function ReadString(const Section, Ident, Default: WideString): WideString; override; + procedure WriteString(const Section, Ident, Value: WideString); override; + procedure ReadSection(const Section: WideString; Strings: TTntStrings); override; + procedure ReadSections(Strings: TTntStrings); override; + procedure ReadSectionValues(const Section: WideString; Strings: TTntStrings); override; + procedure EraseSection(const Section: WideString); override; + procedure DeleteKey(const Section, Ident: WideString); override; + procedure UpdateFile; override; + end; +{$ELSE} + TTntIniFile = class(TTntMemIniFile) + public + destructor Destroy; override; + end; +{$ENDIF} + + +implementation + +uses + RTLConsts, SysUtils, TntSysUtils +{$IFDEF COMPILER_9_UP} , WideStrUtils {$ELSE} , TntWideStrUtils {$ENDIF} +{$IFDEF MSWINDOWS} , Windows {$ENDIF}; + +{ TTntCustomIniFile } + +constructor TTntCustomIniFile.Create(const FileName: WideString); +begin + FFileName := FileName; +end; + +function TTntCustomIniFile.SectionExists(const Section: WideString): Boolean; +var + S: TTntStrings; +begin + S := TTntStringList.Create; + try + ReadSection(Section, S); + Result := S.Count > 0; + finally + S.Free; + end; +end; + +function TTntCustomIniFile.ReadInteger(const Section, Ident: WideString; + Default: Longint): Longint; +var + IntStr: WideString; +begin + IntStr := ReadString(Section, Ident, ''); + if (Length(IntStr) > 2) and (IntStr[1] = WideChar('0')) and + ((IntStr[2] = WideChar('X')) or (IntStr[2] = WideChar('x'))) then + IntStr := WideString('$') + Copy(IntStr, 3, Maxint); + Result := StrToIntDef(IntStr, Default); +end; + +procedure TTntCustomIniFile.WriteInteger(const Section, Ident: WideString; Value: Longint); +begin + WriteString(Section, Ident, IntToStr(Value)); +end; + +function TTntCustomIniFile.ReadBool(const Section, Ident: WideString; + Default: Boolean): Boolean; +begin + Result := ReadInteger(Section, Ident, Ord(Default)) <> 0; +end; + +function TTntCustomIniFile.ReadDate(const Section, Name: WideString; Default: TDateTime): TDateTime; +var + DateStr: WideString; +begin + DateStr := ReadString(Section, Name, ''); + Result := Default; + if DateStr <> '' then + try + Result := StrToDate(DateStr); + except + on EConvertError do + else raise; + end; +end; + +function TTntCustomIniFile.ReadDateTime(const Section, Name: WideString; Default: TDateTime): TDateTime; +var + DateStr: WideString; +begin + DateStr := ReadString(Section, Name, ''); + Result := Default; + if DateStr <> '' then + try + Result := StrToDateTime(DateStr); + except + on EConvertError do + else raise; + end; +end; + +function TTntCustomIniFile.ReadFloat(const Section, Name: WideString; Default: Double): Double; +var + FloatStr: WideString; +begin + FloatStr := ReadString(Section, Name, ''); + Result := Default; + if FloatStr <> '' then + try + Result := StrToFloat(FloatStr); + except + on EConvertError do + else raise; + end; +end; + +function TTntCustomIniFile.ReadTime(const Section, Name: WideString; Default: TDateTime): TDateTime; +var + TimeStr: WideString; +begin + TimeStr := ReadString(Section, Name, ''); + Result := Default; + if TimeStr <> '' then + try + Result := StrToTime(TimeStr); + except + on EConvertError do + else raise; + end; +end; + +procedure TTntCustomIniFile.WriteDate(const Section, Name: WideString; Value: TDateTime); +begin + WriteString(Section, Name, DateToStr(Value)); +end; + +procedure TTntCustomIniFile.WriteDateTime(const Section, Name: WideString; Value: TDateTime); +begin + WriteString(Section, Name, DateTimeToStr(Value)); +end; + +procedure TTntCustomIniFile.WriteFloat(const Section, Name: WideString; Value: Double); +begin + WriteString(Section, Name, FloatToStr(Value)); +end; + +procedure TTntCustomIniFile.WriteTime(const Section, Name: WideString; Value: TDateTime); +begin + WriteString(Section, Name, TimeToStr(Value)); +end; + +procedure TTntCustomIniFile.WriteBool(const Section, Ident: WideString; Value: Boolean); +const + Values: array[Boolean] of WideString = ('0', '1'); +begin + WriteString(Section, Ident, Values[Value]); +end; + +function TTntCustomIniFile.ValueExists(const Section, Ident: WideString): Boolean; +var + S: TTntStrings; +begin + S := TTntStringList.Create; + try + ReadSection(Section, S); + Result := S.IndexOf(Ident) > -1; + finally + S.Free; + end; +end; + +function TTntCustomIniFile.ReadBinaryStream(const Section, Name: WideString; + Value: TStream): Integer; +var + Text: String; // Not Unicode: Due to HexToBin is not Unicode + Stream: TMemoryStream; + Pos: Integer; +begin + Text := ReadString(Section, Name, ''); + if Text <> '' then + begin + if Value is TMemoryStream then + Stream := TMemoryStream(Value) + else Stream := TMemoryStream.Create; + try + Pos := Stream.Position; + Stream.SetSize(Stream.Size + Length(Text) div 2); + HexToBin(PChar(Text), PChar(Integer(Stream.Memory) + Stream.Position), Length(Text) div 2); + Stream.Position := Pos; + if Value <> Stream then Value.CopyFrom(Stream, Length(Text) div 2); + Result := Stream.Size - Pos; + finally + if Value <> Stream then Stream.Free; + end; + end else Result := 0; +end; + +procedure TTntCustomIniFile.WriteBinaryStream(const Section, Name: WideString; + Value: TStream); +var + Text: string; // Not Unicode: Due to BinToHex is not Unicode + Stream: TMemoryStream; +begin + SetLength(Text, (Value.Size - Value.Position) * 2); + if Length(Text) > 0 then + begin + if Value is TMemoryStream then + Stream := TMemoryStream(Value) + else Stream := TMemoryStream.Create; + try + if Stream <> Value then + begin + Stream.CopyFrom(Value, Value.Size - Value.Position); + Stream.Position := 0; + end; + BinToHex(PChar(Integer(Stream.Memory) + Stream.Position), PChar(Text), + Stream.Size - Stream.Position); + finally + if Value <> Stream then Stream.Free; + end; + end; + WriteString(Section, Name, Text); +end; + +{ TTntStringHash } + +procedure TTntStringHash.Add(const Key: WideString; Value: Integer); +var + Hash: Integer; + Bucket: PTntHashItem; +begin + Hash := HashOf(Key) mod Cardinal(Length(Buckets)); + New(Bucket); + Bucket^.Key := Key; + Bucket^.Value := Value; + Bucket^.Next := Buckets[Hash]; + Buckets[Hash] := Bucket; +end; + +procedure TTntStringHash.Clear; +var + I: Integer; + P, N: PTntHashItem; +begin + for I := 0 to Length(Buckets) - 1 do + begin + P := Buckets[I]; + while P <> nil do + begin + N := P^.Next; + Dispose(P); + P := N; + end; + Buckets[I] := nil; + end; +end; + +constructor TTntStringHash.Create(Size: Integer); +begin + inherited Create; + SetLength(Buckets, Size); +end; + +destructor TTntStringHash.Destroy; +begin + Clear; + inherited; +end; + +function TTntStringHash.Find(const Key: WideString): PPTntHashItem; +var + Hash: Integer; +begin + Hash := HashOf(Key) mod Cardinal(Length(Buckets)); + Result := @Buckets[Hash]; + while Result^ <> nil do + begin + if Result^.Key = Key then + Exit + else + Result := @Result^.Next; + end; +end; + +function TTntStringHash.HashOf(const Key: WideString): Cardinal; +var + I: Integer; +begin + Result := 0; + for I := 1 to Length(Key) do + Result := ((Result shl 2) or (Result shr (SizeOf(Result) * 8 - 2))) xor + Ord(Key[I]); // Is it OK for WideChar? +end; + +function TTntStringHash.Modify(const Key: WideString; Value: Integer): Boolean; +var + P: PTntHashItem; +begin + P := Find(Key)^; + if P <> nil then + begin + Result := True; + P^.Value := Value; + end + else + Result := False; +end; + +procedure TTntStringHash.Remove(const Key: WideString); +var + P: PTntHashItem; + Prev: PPTntHashItem; +begin + Prev := Find(Key); + P := Prev^; + if P <> nil then + begin + Prev^ := P^.Next; + Dispose(P); + end; +end; + +function TTntStringHash.ValueOf(const Key: WideString): Integer; +var + P: PTntHashItem; +begin + P := Find(Key)^; + if P <> nil then + Result := P^.Value else + Result := -1; +end; + +{ TTntHashedStringList } + +procedure TTntHashedStringList.Changed; +begin + inherited; + FValueHashValid := False; + FNameHashValid := False; +end; + +destructor TTntHashedStringList.Destroy; +begin + FValueHash.Free; + FNameHash.Free; + inherited; +end; + +function TTntHashedStringList.IndexOf(const S: WideString): Integer; +begin + UpdateValueHash; + if not CaseSensitive then + Result := FValueHash.ValueOf(WideUpperCase(S)) + else + Result := FValueHash.ValueOf(S); +end; + +function TTntHashedStringList.IndexOfName(const Name: WideString): Integer; +begin + UpdateNameHash; + if not CaseSensitive then + Result := FNameHash.ValueOf(WideUpperCase(Name)) + else + Result := FNameHash.ValueOf(Name); +end; + +procedure TTntHashedStringList.UpdateNameHash; +var + I: Integer; + P: Integer; + Key: WideString; +begin + if FNameHashValid then Exit; + if FNameHash = nil then + FNameHash := TTntStringHash.Create + else + FNameHash.Clear; + for I := 0 to Count - 1 do + begin + Key := Get(I); + P := Pos(NameValueSeparator, Key); + if P <> 0 then + begin + if not CaseSensitive then + Key := WideUpperCase(Copy(Key, 1, P - 1)) + else + Key := Copy(Key, 1, P - 1); + FNameHash.Add(Key, I); + end; + end; + FNameHashValid := True; +end; + +procedure TTntHashedStringList.UpdateValueHash; +var + I: Integer; +begin + if FValueHashValid then Exit; + if FValueHash = nil then + FValueHash := TTntStringHash.Create + else + FValueHash.Clear; + for I := 0 to Count - 1 do + if not CaseSensitive then + FValueHash.Add(WideUpperCase(Self[I]), I) + else + FValueHash.Add(Self[I], I); + FValueHashValid := True; +end; + +{ TTntMemIniFile } + +constructor TTntMemIniFile.Create(const FileName: WideString); +begin + inherited Create(FileName); + FSections := TTntHashedStringList.Create; + FSections.NameValueSeparator := '='; +{$IFDEF LINUX} + FSections.CaseSensitive := True; +{$ELSE} + FSections.CaseSensitive := False; +{$ENDIF} + LoadValues; +end; + +destructor TTntMemIniFile.Destroy; +begin + if FSections <> nil then Clear; + FSections.Free; + inherited; +end; + +function TTntMemIniFile.AddSection(const Section: WideString): TTntStrings; +begin + Result := TTntHashedStringList.Create; + try + TTntHashedStringList(Result).CaseSensitive := CaseSensitive; + FSections.AddObject(Section, Result); + except + Result.Free; + raise; + end; +end; + +procedure TTntMemIniFile.Clear; +var + I: Integer; +begin + for I := 0 to FSections.Count - 1 do + TObject(FSections.Objects[I]).Free; + FSections.Clear; +end; + +procedure TTntMemIniFile.DeleteKey(const Section, Ident: WideString); +var + I, J: Integer; + Strings: TTntStrings; +begin + I := FSections.IndexOf(Section); + if I >= 0 then + begin + Strings := TTntStrings(FSections.Objects[I]); + J := Strings.IndexOfName(Ident); + if J >= 0 then Strings.Delete(J); + end; +end; + +procedure TTntMemIniFile.EraseSection(const Section: WideString); +var + I: Integer; +begin + I := FSections.IndexOf(Section); + if I >= 0 then + begin + TStrings(FSections.Objects[I]).Free; + FSections.Delete(I); + end; +end; + +function TTntMemIniFile.GetCaseSensitive: Boolean; +begin + Result := FSections.CaseSensitive; +end; + +procedure TTntMemIniFile.GetStrings(List: TTntStrings); +var + I, J: Integer; + Strings: TTntStrings; +begin + List.BeginUpdate; + try + for I := 0 to FSections.Count - 1 do + begin + List.Add('[' + FSections[I] + ']'); + Strings := TTntStrings(FSections.Objects[I]); + for J := 0 to Strings.Count - 1 do + List.Add(Strings[J]); + List.Add(''); + end; + finally + List.EndUpdate; + end; +end; + +procedure TTntMemIniFile.LoadValues; +var + List: TTntStringList; +begin + if (FileName <> '') and WideFileExists(FileName) then + begin + List := TTntStringList.Create; + try + List.LoadFromFile(FileName); + SetStrings(List); + finally + List.Free; + end; + end else + Clear; +end; + +procedure TTntMemIniFile.ReadSection(const Section: WideString; + Strings: TTntStrings); +var + I, J: Integer; + SectionStrings: TTntStrings; +begin + Strings.BeginUpdate; + try + Strings.Clear; + I := FSections.IndexOf(Section); + if I >= 0 then + begin + SectionStrings := TTntStrings(FSections.Objects[I]); + for J := 0 to SectionStrings.Count - 1 do + Strings.Add(SectionStrings.Names[J]); + end; + finally + Strings.EndUpdate; + end; +end; + +procedure TTntMemIniFile.ReadSections(Strings: TTntStrings); +begin + Strings.Assign(FSections); +end; + +procedure TTntMemIniFile.ReadSectionValues(const Section: WideString; + Strings: TTntStrings); +var + I: Integer; +begin + Strings.BeginUpdate; + try + Strings.Clear; + I := FSections.IndexOf(Section); + if I >= 0 then Strings.Assign(TTntStrings(FSections.Objects[I])); + finally + Strings.EndUpdate; + end; +end; + +function TTntMemIniFile.ReadString(const Section, Ident, + Default: WideString): WideString; +var + I: Integer; + Strings: TTntStrings; +begin + I := FSections.IndexOf(Section); + if I >= 0 then + begin + Strings := TTntStrings(FSections.Objects[I]); + I := Strings.IndexOfName(Ident); + if I >= 0 then + begin + Result := Copy(Strings[I], Length(Ident) + 2, Maxint); + Exit; + end; + end; + Result := Default; +end; + +procedure TTntMemIniFile.Rename(const FileName: WideString; Reload: Boolean); +begin + FFileName := FileName; + if Reload then LoadValues; +end; + +procedure TTntMemIniFile.SetCaseSensitive(Value: Boolean); +var + I: Integer; +begin + if Value <> FSections.CaseSensitive then + begin + FSections.CaseSensitive := Value; + for I := 0 to FSections.Count - 1 do + with TTntHashedStringList(FSections.Objects[I]) do + begin + CaseSensitive := Value; + Changed; + end; + TTntHashedStringList(FSections).Changed; + end; +end; + +procedure TTntMemIniFile.SetStrings(List: TTntStrings); +var + I, J: Integer; + S: WideString; + Strings: TTntStrings; +begin + Clear; + Strings := nil; + for I := 0 to List.Count - 1 do + begin + S := Trim(List[I]); + if (S <> '') and (S[1] <> ';') then + if (S[1] = '[') and (S[Length(S)] = ']') then + begin + Delete(S, 1, 1); + SetLength(S, Length(S)-1); + Strings := AddSection(Trim(S)); + end + else + if Strings <> nil then + begin + J := Pos(FSections.NameValueSeparator, S); + if J > 0 then // remove spaces before and after NameValueSeparator + Strings.Add(Trim(Copy(S, 1, J-1)) + FSections.NameValueSeparator + TrimRight(Copy(S, J+1, MaxInt)) ) + else + Strings.Add(S); + end; + end; +end; + +procedure TTntMemIniFile.UpdateFile; +var + List: TTntStringList; +begin + List := TTntStringList.Create; + try + GetStrings(List); + List.SaveToFile(FFileName); + finally + List.Free; + end; +end; + +procedure TTntMemIniFile.WriteString(const Section, Ident, Value: WideString); +var + I: Integer; + S: WideString; + Strings: TTntStrings; +begin + I := FSections.IndexOf(Section); + if I >= 0 then + Strings := TTntStrings(FSections.Objects[I]) else + Strings := AddSection(Section); + S := Ident + FSections.NameValueSeparator + Value; + I := Strings.IndexOfName(Ident); + if I >= 0 then Strings[I] := S else Strings.Add(S); +end; + + + +{$IFDEF MSWINDOWS} +{ TTntIniFile } + +constructor TTntIniFile.Create(const FileName: WideString); +begin + inherited Create(FileName); + if (not Win32PlatformIsUnicode) then + FAnsiIniFile := TIniFile.Create(FileName); +end; + +destructor TTntIniFile.Destroy; +begin + UpdateFile; // flush changes to disk + if (not Win32PlatformIsUnicode) then + FAnsiIniFile.Free; + inherited Destroy; +end; + +function TTntIniFile.ReadString(const Section, Ident, Default: WideString): WideString; +var + Buffer: array[0..2047] of WideChar; +begin + if (not Win32PlatformIsUnicode) then + { Windows 95/98/Me } + Result := FAnsiIniFile.ReadString(Section, Ident, Default) + else begin + { Windows NT/2000/XP and later } + GetPrivateProfileStringW(PWideChar(Section), + PWideChar(Ident), PWideChar(Default), Buffer, Length(Buffer), PWideChar(FFileName)); + Result := WideString(Buffer); + end; +end; + +procedure TTntIniFile.WriteString(const Section, Ident, Value: WideString); +begin + if (not Win32PlatformIsUnicode) then + { Windows 95/98/Me } + FAnsiIniFile.WriteString(Section, Ident, Value) + else begin + { Windows NT/2000/XP and later } + if not WritePrivateProfileStringW(PWideChar(Section), PWideChar(Ident), + PWideChar(Value), PWideChar(FFileName)) then + raise EIniFileException.CreateResFmt(@SIniFileWriteError, [FileName]); + end; +end; + +procedure TTntIniFile.ReadSections(Strings: TTntStrings); +const + BufSize = 16384 * SizeOf(WideChar); +var + Buffer, P: PWideChar; +begin + if (not Win32PlatformIsUnicode) then + begin + { Windows 95/98/Me } + FAnsiIniFile.ReadSections(Strings.AnsiStrings); + end else + begin + { Windows NT/2000/XP and later } + GetMem(Buffer, BufSize); + try + Strings.BeginUpdate; + try + Strings.Clear; + if GetPrivateProfileStringW(nil, nil, nil, Buffer, BufSize, + PWideChar(FFileName)) <> 0 then + begin + P := Buffer; + while P^ <> WideChar(#0) do + begin + Strings.Add(P); + Inc(P, WStrLen(P) + 1); + end; + end; + finally + Strings.EndUpdate; + end; + finally + FreeMem(Buffer, BufSize); + end; + end; {else} +end; + +procedure TTntIniFile.ReadSection(const Section: WideString; Strings: TTntStrings); +const + BufSize = 16384 * SizeOf(WideChar); +var + Buffer, P: PWideChar; +begin + if (not Win32PlatformIsUnicode) then + begin + { Windows 95/98/Me } + FAnsiIniFile.ReadSection(Section, Strings.AnsiStrings); + end else + begin + { Windows NT/2000/XP and later } + GetMem(Buffer, BufSize); + try + Strings.BeginUpdate; + try + Strings.Clear; + if GetPrivateProfileStringW(PWideChar(Section), nil, nil, Buffer, BufSize, + PWideChar(FFileName)) <> 0 then + begin + P := Buffer; + while P^ <> #0 do + begin + Strings.Add(P); + Inc(P, WStrLen(P) + 1); + end; + end; + finally + Strings.EndUpdate; + end; + finally + FreeMem(Buffer, BufSize); + end; + end; +end; + +procedure TTntIniFile.ReadSectionValues(const Section: WideString; Strings: TTntStrings); +var + KeyList: TTntStringList; + I: Integer; +begin + if (not Win32PlatformIsUnicode) then + begin + { Windows 95/98/Me } + FAnsiIniFile.ReadSectionValues(Section, Strings.AnsiStrings); + end else + begin + { Windows NT/2000/XP and later } + KeyList := TTntStringList.Create; + try + ReadSection(Section, KeyList); + Strings.BeginUpdate; + try + Strings.Clear; + for I := 0 to KeyList.Count - 1 do + Strings.Add(KeyList[I] + '=' + ReadString(Section, KeyList[I], '')) + finally + Strings.EndUpdate; + end; + finally + KeyList.Free; + end; + end; {if} +end; + +procedure TTntIniFile.EraseSection(const Section: WideString); +begin + if (not Win32PlatformIsUnicode) then + begin + { Windows 95/98/Me } + FAnsiIniFile.EraseSection(Section); + end + else begin + { Windows NT/2000/XP and later } + if not WritePrivateProfileStringW(PWideChar(Section), nil, nil, + PWideChar(FFileName)) then + raise EIniFileException.CreateResFmt(@SIniFileWriteError, [FileName]); + end; {if} +end; + +procedure TTntIniFile.DeleteKey(const Section, Ident: WideString); +begin + if (not Win32PlatformIsUnicode) then + begin + { Windows 95/98/Me } + FAnsiIniFile.DeleteKey(Section, Ident); + end + else begin + { Windows NT/2000/XP and later } + WritePrivateProfileStringW(PWideChar(Section), PWideChar(Ident), nil, + PWideChar(FFileName)); + end; {if} +end; + +procedure TTntIniFile.UpdateFile; +begin + if (not Win32PlatformIsUnicode) then + begin + { Windows 95/98/Me } + FAnsiIniFile.UpdateFile + end + else begin + { Windows NT/2000/XP and later } + WritePrivateProfileStringW(nil, nil, nil, PWideChar(FFileName)); + end; {if} +end; + +{$ELSE} + +destructor TTntIniFile.Destroy; +begin + UpdateFile; + inherited Destroy; +end; + +{$ENDIF} + + + + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas new file mode 100644 index 0000000000..87ec613976 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas @@ -0,0 +1,205 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Extended TTntMemIniFile (compatible with all versions) } +{ } +{ Copyright (c) 1999-2007 Stanley Xu } +{ http://getgosurf.com/?go=supportFeedback&ln=en } +{ } +{*****************************************************************************} + +{*****************************************************************************} +{ } +{ BACKGROUND: } +{ TTntMemIniFile buffers all changes to the INI file in memory. To write } +{ the data from memory back to the associated INI file, call the } +{ UpdateFile() method. However, the whole content of this INI file will } +{ be overwritten. Even those sections that are not used. This will make } +{ troubles, if two instances try to change the same file at the same } +{ time, without some method of managing access the instances may well end } +{ up overwriting each other's work. } +{ } +{ IDEA: } +{ TTntMemIniFileEx implementes a simple idea: To check the timestamp } +{ before each operation. If the file is modified, TTntMemIniFileEx will } +{ reload the file to keep the content updated. } +{ } +{ CONCLUSION: } +{ # TTntMemIniFileEx and TTntMemIniFile are ideal for read-only access. } +{ For instance: To read localization files, etc. } +{ # To perform mass WriteString() operations, please use the following } +{ code. } +{ BeginUpdate(); } +{ try } +{ for I := 0 to 10000 do } +{ WriteString(...); } +{ finally; } +{ EndUpdate(); } +{ UpdateFile; } +{ end; } +{ } +{*****************************************************************************} + +unit TntIniFilesEx; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + TntClasses, TntIniFiles; + +type + TTntMemIniFileEx = class(TTntMemIniFile) + private + FUpdateCount: Integer; + FModified: Boolean; + FLastAccessed: Integer; + function FileRealLastAccessedTime: Integer; + procedure GetLatestVersion; + protected + procedure LoadValues; // Extended + public + constructor Create(const FileName: WideString); override; + procedure BeginUpdate; virtual; + procedure EndUpdate; virtual; + function ReadString(const Section, Ident, Default: WideString): WideString; override; + procedure WriteString(const Section, Ident, Value: WideString); override; + procedure ReadSection(const Section: WideString; Strings: TTntStrings); override; + procedure ReadSections(Strings: TTntStrings); override; + procedure ReadSectionValues(const Section: WideString; Strings: TTntStrings); override; + procedure DeleteKey(const Section, Ident: WideString); override; + procedure EraseSection(const Section: WideString); override; + procedure UpdateFile; override; + end; + + + +implementation + +uses + SysUtils, TntSysUtils; + + +{ TTntMemIniFileEx } + +function TTntMemIniFileEx.FileRealLastAccessedTime: Integer; +var + H: Integer; // file handle +begin + Result := 0; + H := WideFileOpen(FileName, fmOpenWrite); //fmOpenRead (?) + if H <> -1 then + try + Result := FileGetDate(H); + finally + FileClose(H); + end; +end; + +procedure TTntMemIniFileEx.GetLatestVersion; +begin + if FLastAccessed = FileRealLastAccessedTime then + Exit; + + LoadValues; + // FLastAccess will be updated in LoadValues(...) +end; + +procedure TTntMemIniFileEx.LoadValues; // Copied from TntIniFiles.pas +var + List: TTntStringList; +begin + if (FileName <> '') and WideFileExists(FileName) then + begin + List := TTntStringList.Create; + try + List.LoadFromFile(FileName); + FLastAccessed := FileRealLastAccessedTime; // Extra + FModified := False; // + SetStrings(List); + finally + List.Free; + end; + end else + Clear; +end; + +constructor TTntMemIniFileEx.Create(const FileName: WideString); +begin + inherited Create(FileName); + FUpdateCount := 0; +end; + +procedure TTntMemIniFileEx.BeginUpdate; +begin + Inc(FUpdateCount); +end; + +procedure TTntMemIniFileEx.EndUpdate; +begin + Dec(FUpdateCount); +end; + +function TTntMemIniFileEx.ReadString(const Section, Ident, Default: WideString): WideString; +begin + GetLatestVersion; + Result := inherited ReadString(Section, Ident, Default); +end; + +procedure TTntMemIniFileEx.WriteString(const Section, Ident, Value: WideString); +begin + GetLatestVersion; + inherited WriteString(Section, Ident, Value); + FModified := True; + UpdateFile; // Flush changes to disk +end; + +procedure TTntMemIniFileEx.ReadSection(const Section: WideString; Strings: TTntStrings); +begin + GetLatestVersion; + inherited ReadSection(Section, Strings); +end; + +procedure TTntMemIniFileEx.ReadSections(Strings: TTntStrings); +begin + GetLatestVersion; + inherited ReadSections(Strings); +end; + +procedure TTntMemIniFileEx.ReadSectionValues(const Section: WideString; Strings: TTntStrings); +begin + GetLatestVersion; + inherited ReadSectionValues(Section, Strings); +end; + +procedure TTntMemIniFileEx.DeleteKey(const Section, Ident: WideString); +begin + GetLatestVersion; + inherited DeleteKey(Section, Ident); + FModified := True; + UpdateFile; // Flush changes to disk +end; + +procedure TTntMemIniFileEx.EraseSection(const Section: WideString); +begin + GetLatestVersion; + inherited EraseSection(Section); + FModified := True; + UpdateFile; // Flush changes to disk +end; + +procedure TTntMemIniFileEx.UpdateFile; +begin + if not FModified or (FUpdateCount > 0) then + Exit; + inherited; +end; + + + + + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas new file mode 100644 index 0000000000..00601c0449 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas @@ -0,0 +1,207 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntListActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, TntActnList, ListActns; + +type +{TNT-WARN TCustomListAction} + TTntCustomListAction = class(TCustomListAction{TNT-ALLOW TCustomListAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TStaticListAction} + TTntStaticListAction = class(TStaticListAction{TNT-ALLOW TStaticListAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TVirtualListAction} + TTntVirtualListAction = class(TVirtualListAction{TNT-ALLOW TVirtualListAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +implementation + +uses + ActnList, TntClasses; + +{TNT-IGNORE-UNIT} + +type TAccessCustomListAction = class(TCustomListAction); + +procedure TntListActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntAction_AfterInherited_Assign(Action, Source); + // TCustomListAction + if (Action is TCustomListAction) and (Source is TCustomListAction) then begin + TAccessCustomListAction(Action).Images := TAccessCustomListAction(Source).Images; + TAccessCustomListAction(Action).OnGetItemCount := TAccessCustomListAction(Source).OnGetItemCount; + TAccessCustomListAction(Action).OnItemSelected := TAccessCustomListAction(Source).OnItemSelected; + TAccessCustomListAction(Action).Active := TAccessCustomListAction(Source).Active; + TAccessCustomListAction(Action).ItemIndex := TAccessCustomListAction(Source).ItemIndex; + end; + // TStaticListAction + if (Action is TStaticListAction) and (Source is TStaticListAction) then begin + TStaticListAction(Action).Items := TStaticListAction(Source).Items; + TStaticListAction(Action).OnGetItem := TStaticListAction(Source).OnGetItem; + end; + // TVirtualListAction + if (Action is TVirtualListAction) and (Source is TVirtualListAction) then begin + TVirtualListAction(Action).OnGetItem := TVirtualListAction(Source).OnGetItem; + end; +end; + +//------------------------- +// TNT LIST ACTNS +//------------------------- + +{ TTntCustomListAction } + +procedure TTntCustomListAction.Assign(Source: TPersistent); +begin + inherited; + TntListActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCustomListAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomListAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCustomListAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCustomListAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCustomListAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntStaticListAction } + +procedure TTntStaticListAction.Assign(Source: TPersistent); +begin + inherited; + TntListActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntStaticListAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntStaticListAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntStaticListAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntStaticListAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntStaticListAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntVirtualListAction } + +procedure TTntVirtualListAction.Assign(Source: TPersistent); +begin + inherited; + TntListActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntVirtualListAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntVirtualListAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntVirtualListAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntVirtualListAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntVirtualListAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas new file mode 100644 index 0000000000..577764661c --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas @@ -0,0 +1,1146 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntMenus; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Windows, Classes, Menus, Graphics, Messages; + +type +{TNT-WARN TMenuItem} + TTntMenuItem = class(TMenuItem{TNT-ALLOW TMenuItem}) + private + FIgnoreMenuChanged: Boolean; + FCaption: WideString; + FHint: WideString; + FKeyboardLayout: HKL; + function GetCaption: WideString; + procedure SetInheritedCaption(const Value: AnsiString); + procedure SetCaption(const Value: WideString); + function IsCaptionStored: Boolean; + procedure UpdateMenuString(ParentMenu: TMenu); + function GetAlignmentDrawStyle: Word; + function MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer; + function GetHint: WideString; + procedure SetInheritedHint(const Value: AnsiString); + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TMenuActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure MenuChanged(Rebuild: Boolean); override; + procedure AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; + State: TOwnerDrawState; TopLevel: Boolean); override; + procedure DoDrawText(ACanvas: TCanvas; const ACaption: WideString; + var Rect: TRect; Selected: Boolean; Flags: Integer); + procedure MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); override; + public + procedure InitiateAction; override; + procedure Loaded; override; + function Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem}; + published + property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TMainMenu} + TTntMainMenu = class(TMainMenu{TNT-ALLOW TMainMenu}) + protected + procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override; + public + {$IFDEF COMPILER_9_UP} + function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override; + {$ENDIF} + end; + +{TNT-WARN TPopupMenu} + TTntPopupMenu = class(TPopupMenu{TNT-ALLOW TPopupMenu}) + protected + procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + {$IFDEF COMPILER_9_UP} + function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override; + {$ENDIF} + destructor Destroy; override; + procedure Popup(X, Y: Integer); override; + end; + +{TNT-WARN NewSubMenu} +function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext; + const AName: TComponentName; const Items: array of TTntMenuItem; + AEnabled: Boolean): TTntMenuItem; +{TNT-WARN NewItem} +function WideNewItem(const ACaption: WideString; AShortCut: TShortCut; + AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext; + const AName: TComponentName): TTntMenuItem; + +function MessageToShortCut(Msg: TWMKeyDown): TShortCut; + +{TNT-WARN ShortCutToText} +function WideShortCutToText(WordShortCut: Word): WideString; +{TNT-WARN TextToShortCut} +function WideTextToShortCut(Text: WideString): TShortCut; +{TNT-WARN GetHotKey} +function WideGetHotkey(const Text: WideString): WideString; +{TNT-WARN StripHotkey} +function WideStripHotkey(const Text: WideString): WideString; +{TNT-WARN AnsiSameCaption} +function WideSameCaption(const Text1, Text2: WideString): Boolean; + +function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; +function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; + +procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu}); + +procedure FixMenuBiDiProblem(Menu: TMenu); + +function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean; + +type + TTntPopupList = class(TPopupList) + private + SavedPopupList: TPopupList; + protected + procedure WndProc(var Message: TMessage); override; + end; + +var + TntPopupList: TTntPopupList; + +implementation + +uses + Forms, SysUtils, Consts, ActnList, ImgList, TntControls, TntGraphics, + TntActnList, TntClasses, TntForms, TntSysUtils, TntWindows; + +function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext; + const AName: TComponentName; const Items: array of TTntMenuItem; + AEnabled: Boolean): TTntMenuItem; +var + I: Integer; +begin + Result := TTntMenuItem.Create(nil); + for I := Low(Items) to High(Items) do + Result.Add(Items[I]); + Result.Caption := ACaption; + Result.HelpContext := hCtx; + Result.Name := AName; + Result.Enabled := AEnabled; +end; + +function WideNewItem(const ACaption: WideString; AShortCut: TShortCut; + AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext; + const AName: TComponentName): TTntMenuItem; +begin + Result := TTntMenuItem.Create(nil); + with Result do + begin + Caption := ACaption; + ShortCut := AShortCut; + OnClick := AOnClick; + HelpContext := hCtx; + Checked := AChecked; + Enabled := AEnabled; + Name := AName; + end; +end; + +function MessageToShortCut(Msg: TWMKeyDown): TShortCut; +var + ShiftState: TShiftState; +begin + ShiftState := Forms.KeyDataToShiftState(TWMKeyDown(Msg).KeyData); + Result := Menus.ShortCut(TWMKeyDown(Msg).CharCode, ShiftState); +end; + +function WideGetSpecialName(WordShortCut: Word): WideString; +var + ScanCode: Integer; + KeyName: array[0..255] of WideChar; +begin + Assert(Win32PlatformIsUnicode); + Result := ''; + ScanCode := MapVirtualKeyW(WordRec(WordShortCut).Lo, 0) shl 16; + if ScanCode <> 0 then + begin + GetKeyNameTextW(ScanCode, KeyName, SizeOf(KeyName)); + Result := KeyName; + end; +end; + +function WideGetKeyboardChar(Key: Word): WideChar; +var + LatinNumChar: WideChar; +begin + Assert(Win32PlatformIsUnicode); + Result := WideChar(MapVirtualKeyW(Key, 2)); + if (Key in [$30..$39]) then + begin + // Check to see if "0" - "9" can be used if all that differs is shift state + LatinNumChar := WideChar(Key - $30 + Ord('0')); + if (Result <> LatinNumChar) + and (Byte(Key) = WordRec(VkKeyScanW(LatinNumChar)).Lo) then // .Hi would be the shift state + Result := LatinNumChar; + end; +end; + +function WideShortCutToText(WordShortCut: Word): WideString; +var + Name: WideString; +begin + if (not Win32PlatformIsUnicode) + or (WordRec(WordShortCut).Lo in [$08..$09 {BKSP, TAB}, $0D {ENTER}, $1B {ESC}, $20..$28 {Misc Nav}, + $2D..$2E {INS, DEL}, $70..$87 {F1 - F24}]) + then + Result := ShortCutToText{TNT-ALLOW ShortCutToText}(WordShortCut) + else begin + case WordRec(WordShortCut).Lo of + $30..$39: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {1-9,0} + $41..$5A: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {A-Z} + $60..$69: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {numpad 1-9,0} + else + Name := WideGetSpecialName(WordShortCut); + end; + if Name <> '' then + begin + Result := ''; + if WordShortCut and scShift <> 0 then Result := Result + SmkcShift; + if WordShortCut and scCtrl <> 0 then Result := Result + SmkcCtrl; + if WordShortCut and scAlt <> 0 then Result := Result + SmkcAlt; + Result := Result + Name; + end + else Result := ''; + end; +end; + +{ This function is *very* slow. Use sparingly. Return 0 if no VK code was + found for the text } + +function WideTextToShortCut(Text: WideString): TShortCut; + + { If the front of Text is equal to Front then remove the matching piece + from Text and return True, otherwise return False } + + function CompareFront(var Text: WideString; const Front: WideString): Boolean; + begin + Result := (Pos(Front, Text) = 1); + if Result then + Delete(Text, 1, Length(Front)); + end; + +var + Key: TShortCut; + Shift: TShortCut; +begin + Result := 0; + Shift := 0; + while True do + begin + if CompareFront(Text, SmkcShift) then Shift := Shift or scShift + else if CompareFront(Text, '^') then Shift := Shift or scCtrl + else if CompareFront(Text, SmkcCtrl) then Shift := Shift or scCtrl + else if CompareFront(Text, SmkcAlt) then Shift := Shift or scAlt + else Break; + end; + if Text = '' then Exit; + for Key := $08 to $255 do { Copy range from table in ShortCutToText } + if WideSameText(Text, WideShortCutToText(Key)) then + begin + Result := Key or Shift; + Exit; + end; +end; + +function WideGetHotkeyPos(const Text: WideString): Integer; +var + I, L: Integer; +begin + Result := 0; + I := 1; + L := Length(Text); + while I <= L do + begin + if (Text[I] = cHotkeyPrefix) and (L - I >= 1) then + begin + Inc(I); + if Text[I] <> cHotkeyPrefix then + Result := I; // this might not be the last + end; + Inc(I); + end; +end; + +function WideGetHotkey(const Text: WideString): WideString; +var + I: Integer; +begin + I := WideGetHotkeyPos(Text); + if I = 0 then + Result := '' + else + Result := Text[I]; +end; + +function WideStripHotkey(const Text: WideString): WideString; +var + I: Integer; +begin + Result := Text; + I := 1; + while I <= Length(Result) do + begin + if Result[I] = cHotkeyPrefix then + if SysLocale.FarEast + and ((I > 1) and (Length(Result) - I >= 2) + and (Result[I - 1] = '(') and (Result[I + 2] = ')')) then begin + Delete(Result, I - 1, 4); + Dec(I, 2); + end else + Delete(Result, I, 1); + Inc(I); + end; +end; + +function WideSameCaption(const Text1, Text2: WideString): Boolean; +begin + Result := WideSameText(WideStripHotkey(Text1), WideStripHotkey(Text2)); +end; + +function WideSameCaptionStr(const Text1, Text2: WideString): Boolean; +begin + Result := WideSameStr(WideStripHotkey(Text1), WideStripHotkey(Text2)); +end; + +function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; +begin + if MenuItem is TTntMenuItem then + Result := TTntMenuItem(MenuItem).Caption + else + Result := MenuItem.Caption; +end; + +function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; +begin + if MenuItem is TTntMenuItem then + Result := TTntMenuItem(MenuItem).Hint + else + Result := MenuItem.Hint; +end; + +procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu}); +{If top-level items are created as owner-drawn, they will not appear as raised +buttons when the mouse hovers over them. The VCL will often create top-level +items as owner-drawn even when they don't need to be (owner-drawn state can be +set on an item-by-item basis). This routine turns off the owner-drawn flag for +top-level items if it appears unnecessary} + + function ItemHasValidImage(Item: TMenuItem{TNT-ALLOW TMenuItem}): boolean; + var + Images: TCustomImageList; + begin + Assert(Item <> nil, 'TNT Internal Error: ItemHasValidImage: item = nil'); + Images := Item.GetImageList; + Result := (Assigned(Images) and (Item.ImageIndex >= 0) and (Item.ImageIndex < Images.Count)) + or (MenuItemHasBitmap(Item) and (not Item.Bitmap.Empty)) + end; + +var + HM: HMenu; + i: integer; + Info: TMenuItemInfoA; + Item: TMenuItem{TNT-ALLOW TMenuItem}; + Win98Plus: boolean; +begin + if Assigned(Menu) then begin + Win98Plus:= (Win32MajorVersion > 4) + or((Win32MajorVersion = 4) and (Win32MinorVersion > 0)); + if not Win98Plus then + Exit; {exit if Windows 95 or NT 4.0} + HM:= Menu.Handle; + Info.cbSize:= sizeof(Info); + for i := 0 to GetMenuItemCount(HM) - 1 do begin + Info.fMask:= MIIM_FTYPE or MIIM_ID; + if not GetMenuItemInfo(HM, i, true, Info) then + Break; + if Info.fType and MFT_OWNERDRAW <> 0 then begin + Item:= Menu.FindItem(Info.wID, fkCommand); + if not Assigned(Item) then + continue; + if Assigned(Item.OnDrawItem) + or Assigned(Item.OnAdvancedDrawItem) + or ItemHasValidImage(Item) then + Continue; + Info.fMask:= MIIM_FTYPE or MIIM_STRING; + Info.fType:= (Info.fType and not MFT_OWNERDRAW) or MFT_STRING; + if Win32PlatformIsUnicode and (Item is TTntMenuItem) then begin + // Unicode + TMenuItemInfoW(Info).dwTypeData:= PWideChar(TTntMenuItem(Item).Caption); + SetMenuItemInfoW(HM, i, true, TMenuItemInfoW(Info)); + end else begin + // Ansi + Info.dwTypeData:= PAnsiChar(Item.Caption); + SetMenuItemInfoA(HM, i, true, Info); + end; + end; + end; + end; +end; + +{ TTntMenuItem's utility procs } + +procedure SyncHotKeyPosition(const Source: WideString; var Dest: WideString); +var + I: Integer; + FarEastHotString: WideString; +begin + if (AnsiString(Source) <> AnsiString(Dest)) + and WideSameCaptionStr(AnsiString(Source), AnsiString(Dest)) then begin + // when reduced to ansi, the only difference is hot key positions + Dest := WideStripHotkey(Dest); + I := 1; + while I <= Length(Source) do + begin + if Source[I] = cHotkeyPrefix then begin + if SysLocale.FarEast + and ((I > 1) and (Length(Source) - I >= 2) + and (Source[I - 1] = '(') and (Source[I + 2] = ')')) then begin + FarEastHotString := Copy(Source, I - 1, 4); + Dec(I); + Insert(FarEastHotString, Dest, I); + Inc(I, 3); + end else begin + Insert(cHotkeyPrefix, Dest, I); + Inc(I); + end; + end; + Inc(I); + end; + // test work + if AnsiString(Source) <> AnsiString(Dest) then + raise ETntInternalError.CreateFmt('Internal Error: SyncHotKeyPosition Failed ("%s" <> "%s").', + [AnsiString(Source), AnsiString(Dest)]); + end; +end; + +procedure UpdateMenuItems(Items: TMenuItem{TNT-ALLOW TMenuItem}; ParentMenu: TMenu); +var + i: integer; +begin + if (Items.ComponentState * [csReading, csDestroying] = []) then begin + for i := Items.Count - 1 downto 0 do + UpdateMenuItems(Items[i], ParentMenu); + if Items is TTntMenuItem then + TTntMenuItem(Items).UpdateMenuString(ParentMenu); + end; +end; + +procedure FixMenuBiDiProblem(Menu: TMenu); +var + i: integer; +begin + // TMenu sometimes sets bidi on first visible item which can convert caption to ansi + if (SysLocale.MiddleEast) + and (Menu <> nil) + and (Menu.Items.Count > 0) then + begin + for i := 0 to Menu.Items.Count - 1 do begin + if Menu.Items[i].Visible then begin + if (Menu.Items[i] is TTntMenuItem) then + (Menu.Items[i] as TTntMenuItem).UpdateMenuString(Menu); + break; // found first visible menu item! + end; + end; + end; +end; + + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackMenuItem = class(TComponent) + protected + FxxxxCaption: Ansistring; + FxxxxHandle: HMENU; + FxxxxChecked: Boolean; + FxxxxEnabled: Boolean; + FxxxxDefault: Boolean; + FxxxxAutoHotkeys: TMenuItemAutoFlag; + FxxxxAutoLineReduction: TMenuItemAutoFlag; + FxxxxRadioItem: Boolean; + FxxxxVisible: Boolean; + FxxxxGroupIndex: Byte; + FxxxxImageIndex: TImageIndex; + FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; + FxxxxBreak: TMenuBreak; + FBitmap: TBitmap; + FxxxxCommand: Word; + FxxxxHelpContext: THelpContext; + FxxxxHint: AnsiString; + FxxxxItems: TList; + FxxxxShortCut: TShortCut; + FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; + FMerged: TMenuItem{TNT-ALLOW TMenuItem}; + FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackMenuItem = class(TComponent) + protected + FxxxxCaption: AnsiString; + FxxxxHandle: HMENU; + FxxxxChecked: Boolean; + FxxxxEnabled: Boolean; + FxxxxDefault: Boolean; + FxxxxAutoHotkeys: TMenuItemAutoFlag; + FxxxxAutoLineReduction: TMenuItemAutoFlag; + FxxxxRadioItem: Boolean; + FxxxxVisible: Boolean; + FxxxxGroupIndex: Byte; + FxxxxImageIndex: TImageIndex; + FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; + FxxxxBreak: TMenuBreak; + FBitmap: TBitmap; + FxxxxCommand: Word; + FxxxxHelpContext: THelpContext; + FxxxxHint: AnsiString; + FxxxxItems: TList; + FxxxxShortCut: TShortCut; + FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; + FMerged: TMenuItem{TNT-ALLOW TMenuItem}; + FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackMenuItem = class(TComponent) + protected + FxxxxCaption: AnsiString; + FxxxxHandle: HMENU; + FxxxxChecked: Boolean; + FxxxxEnabled: Boolean; + FxxxxDefault: Boolean; + FxxxxAutoHotkeys: TMenuItemAutoFlag; + FxxxxAutoLineReduction: TMenuItemAutoFlag; + FxxxxRadioItem: Boolean; + FxxxxVisible: Boolean; + FxxxxGroupIndex: Byte; + FxxxxImageIndex: TImageIndex; + FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; + FxxxxBreak: TMenuBreak; + FBitmap: TBitmap; + FxxxxCommand: Word; + FxxxxHelpContext: THelpContext; + FxxxxHint: AnsiString; + FxxxxItems: TList; + FxxxxShortCut: TShortCut; + FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; + FMerged: TMenuItem{TNT-ALLOW TMenuItem}; + FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackMenuItem = class(TComponent) + protected + FxxxxCaption: AnsiString; + FxxxxHandle: HMENU; + FxxxxChecked: Boolean; + FxxxxEnabled: Boolean; + FxxxxDefault: Boolean; + FxxxxAutoHotkeys: TMenuItemAutoFlag; + FxxxxAutoLineReduction: TMenuItemAutoFlag; + FxxxxRadioItem: Boolean; + FxxxxVisible: Boolean; + FxxxxGroupIndex: Byte; + FxxxxImageIndex: TImageIndex; + FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; + FxxxxBreak: TMenuBreak; + FBitmap: TBitmap; + FxxxxCommand: Word; + FxxxxHelpContext: THelpContext; + FxxxxHint: AnsiString; + FxxxxItems: TList; + FxxxxShortCut: TShortCut; + FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; + FMerged: TMenuItem{TNT-ALLOW TMenuItem}; + FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} + +function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean; +begin + Result := Assigned(THackMenuItem(MenuItem).FBitmap); +end; + +{ TTntMenuItem } + +procedure TTntMenuItem.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +type TAccessActionlink = class(TActionLink); + +procedure TTntMenuItem.InitiateAction; +begin + if GetKeyboardLayout(0) <> FKeyboardLayout then + MenuChanged(False); + inherited; +end; + +function TTntMenuItem.IsCaptionStored: Boolean; +begin + Result := (ActionLink = nil) or (not TAccessActionlink(ActionLink).IsCaptionLinked); +end; + +procedure TTntMenuItem.SetInheritedCaption(const Value: AnsiString); +begin + inherited Caption := Value; +end; + +function TTntMenuItem.GetCaption: WideString; +begin + if (AnsiString(FCaption) <> inherited Caption) + and WideSameCaptionStr(AnsiString(FCaption), inherited Caption) then + begin + // only difference is hotkey position, update caption with new hotkey position + SyncHotKeyPosition(inherited Caption, FCaption); + end; + Result := GetSyncedWideString(FCaption, (inherited Caption)); +end; + +procedure TTntMenuItem.SetCaption(const Value: WideString); +begin + GetCaption; // auto adjust for hot key changes + SetSyncedWideString(Value, FCaption, (inherited Caption), SetInheritedCaption); +end; + +function TTntMenuItem.GetHint: WideString; +begin + Result := GetSyncedWideString(FHint, inherited Hint); +end; + +procedure TTntMenuItem.SetInheritedHint(const Value: AnsiString); +begin + inherited Hint := Value; +end; + +procedure TTntMenuItem.SetHint(const Value: WideString); +begin + SetSyncedWideString(Value, FHint, inherited Hint, SetInheritedHint); +end; + +function TTntMenuItem.IsHintStored: Boolean; +begin + Result := (ActionLink = nil) or not TAccessActionlink(ActionLink).IsHintLinked; +end; + +procedure TTntMenuItem.Loaded; +begin + inherited; + UpdateMenuString(GetParentMenu); +end; + +procedure TTntMenuItem.MenuChanged(Rebuild: Boolean); +begin + if (not FIgnoreMenuChanged) then begin + inherited; + UpdateMenuItems(Self, GetParentMenu); + FixMenuBiDiProblem(GetParentMenu); + end; +end; + +procedure TTntMenuItem.UpdateMenuString(ParentMenu: TMenu); +var + ParentHandle: THandle; + + function NativeMenuTypeIsString: Boolean; + var + MenuItemInfo: TMenuItemInfoW; + Buffer: array[0..79] of WideChar; + begin + MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0 + MenuItemInfo.fMask := MIIM_TYPE; + MenuItemInfo.dwTypeData := Buffer; // ?? + MenuItemInfo.cch := Length(Buffer); // ?? + Result := GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo) + and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0) + end; + + function NativeMenuString: WideString; + var + Len: Integer; + begin + Assert(Win32PlatformIsUnicode); + Len := GetMenuStringW(ParentHandle, Command, nil, 0, MF_BYCOMMAND); + if Len = 0 then + Result := '' + else begin + SetLength(Result, Len + 1); + Len := GetMenuStringW(ParentHandle, Command, PWideChar(Result), Len + 1, MF_BYCOMMAND); + SetLength(Result, Len); + end; + end; + + procedure SetMenuString(const Value: WideString); + var + MenuItemInfo: TMenuItemInfoW; + Buffer: array[0..79] of WideChar; + begin + MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0 + MenuItemInfo.fMask := MIIM_TYPE; + MenuItemInfo.dwTypeData := Buffer; // ?? + MenuItemInfo.cch := Length(Buffer); // ?? + if GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo) + and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0) then + begin + MenuItemInfo.dwTypeData := PWideChar(Value); + MenuItemInfo.cch := Length(Value); + Win32Check(SetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo)); + end; + end; + + function SameEvent(A, B: TMenuMeasureItemEvent): Boolean; + begin + Result := @A = @B; + end; + +var + MenuCaption: WideString; +begin + FKeyboardLayout := GetKeyboardLayout(0); + if Parent = nil then + ParentHandle := 0 + else if (THackMenuItem(Self.Parent).FMergedWith <> nil) then + ParentHandle := THackMenuItem(Self.Parent).FMergedWith.Handle + else + ParentHandle := Parent.Handle; + + if (Win32PlatformIsUnicode) + and (Parent <> nil) and (ParentMenu <> nil) + and (ComponentState * [csReading, csDestroying] = []) + and (Visible) + and (NativeMenuTypeIsString) then begin + MenuCaption := Caption; + if (Count = 0) + and ((ShortCut <> scNone) + and ((Parent = nil) or (Parent.Parent <> nil) or not (Parent.Owner is TMainMenu{TNT-ALLOW TMainMenu}))) then + MenuCaption := MenuCaption + #9 + WideShortCutToText(ShortCut); + if (NativeMenuString <> MenuCaption) then + begin + SetMenuString(MenuCaption); + if ((Parent = ParentMenu.Items) or (THackMenuItem(Self.Parent).FMergedWith <> nil)) + and (ParentMenu is TMainMenu{TNT-ALLOW TMainMenu}) + and (ParentMenu.WindowHandle <> 0) then + DrawMenuBar(ParentMenu.WindowHandle) {top level menu bar items} + end; + end; +end; + +function TTntMenuItem.GetAlignmentDrawStyle: Word; +const + Alignments: array[TPopupAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER); +var + ParentMenu: TMenu; + Alignment: TPopupAlignment; +begin + ParentMenu := GetParentMenu; + if ParentMenu is TMenu then + Alignment := paLeft + else if ParentMenu is TPopupMenu{TNT-ALLOW TPopupMenu} then + Alignment := TPopupMenu{TNT-ALLOW TPopupMenu}(ParentMenu).Alignment + else + Alignment := paLeft; + Result := Alignments[Alignment]; +end; + +procedure TTntMenuItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; + State: TOwnerDrawState; TopLevel: Boolean); + + procedure DrawMenuText(BiDi: Boolean); + var + ImageList: TCustomImageList; + DrawImage, DrawGlyph: Boolean; + GlyphRect, SaveRect: TRect; + DrawStyle: Longint; + Selected: Boolean; + Win98Plus: Boolean; + Win2K: Boolean; + begin + ImageList := GetImageList; + Selected := odSelected in State; + Win98Plus := (Win32MajorVersion > 4) or + ((Win32MajorVersion = 4) and (Win32MinorVersion > 0)); + Win2K := (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT); + with ACanvas do + begin + GlyphRect.Left := ARect.Left + 1; + DrawImage := (ImageList <> nil) and ((ImageIndex > -1) and + (ImageIndex < ImageList.Count) or Checked and ((not MenuItemHasBitmap(Self)) or + Bitmap.Empty)); + if DrawImage or MenuItemHasBitmap(Self) and not Bitmap.Empty then + begin + DrawGlyph := True; + if DrawImage then + GlyphRect.Right := GlyphRect.Left + ImageList.Width + else begin + { Need to add BitmapWidth/Height properties for TMenuItem if we're to + support them. Right now let's hardcode them to 16x16. } + GlyphRect.Right := GlyphRect.Left + 16; + end; + { Draw background pattern brush if selected } + if Checked then + begin + Inc(GlyphRect.Right); + if not Selected then + Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight); + Inc(GlyphRect.Left); + end; + if Checked then + Dec(GlyphRect.Right); + end else begin + if (ImageList <> nil) and (not TopLevel) then + GlyphRect.Right := GlyphRect.Left + ImageList.Width + else + GlyphRect.Right := GlyphRect.Left; + DrawGlyph := False; + end; + if BiDi then begin + SaveRect := GlyphRect; + GlyphRect.Left := ARect.Right - (SaveRect.Right - ARect.Left); + GlyphRect.Right := ARect.Right - (SaveRect.Left - ARect.Left); + end; + with GlyphRect do begin + Dec(Left); + Inc(Right, 2); + end; + if Selected then begin + if DrawGlyph then begin + if BiDi then + ARect.Right := GlyphRect.Left - 1 + else + ARect.Left := GlyphRect.Right + 1; + end; + if not (Win98Plus and TopLevel) then + Brush.Color := clHighlight; + end; + if TopLevel and Win98Plus and (not Selected) + {$IFDEF COMPILER_7_UP} + and (not Win32PlatformIsXP) + {$ENDIF} + then + OffsetRect(ARect, 0, -1); + if not (Selected and DrawGlyph) then begin + if BiDi then + ARect.Right := GlyphRect.Left - 1 + else + ARect.Left := GlyphRect.Right + 1; + end; + Inc(ARect.Left, 2); + Dec(ARect.Right, 1); + DrawStyle := DT_EXPANDTABS or DT_SINGLELINE or GetAlignmentDrawStyle; + if Win2K and (odNoAccel in State) then + DrawStyle := DrawStyle or DT_HIDEPREFIX; + { Calculate vertical layout } + SaveRect := ARect; + if odDefault in State then + Font.Style := [fsBold]; + DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle or DT_CALCRECT or DT_NOCLIP); + if BiDi then begin + { the DT_CALCRECT does not take into account alignment } + ARect.Left := SaveRect.Left; + ARect.Right := SaveRect.Right; + end; + OffsetRect(ARect, 0, ((SaveRect.Bottom - SaveRect.Top) - (ARect.Bottom - ARect.Top)) div 2); + if TopLevel and Selected and Win98Plus + {$IFDEF COMPILER_7_UP} + and (not Win32PlatformIsXP) + {$ENDIF} + then + OffsetRect(ARect, 1, 0); + DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle); + if (ShortCut <> scNone) and not TopLevel then + begin + if BiDi then begin + ARect.Left := 10; + ARect.Right := ARect.Left + WideCanvasTextWidth(ACanvas, WideShortCutToText(ShortCut)); + end else begin + ARect.Left := ARect.Right; + ARect.Right := SaveRect.Right - 10; + end; + DoDrawText(ACanvas, WideShortCutToText(ShortCut), ARect, Selected, DT_RIGHT); + end; + end; + end; + +var + ParentMenu: TMenu; + SaveCaption: WideString; + SaveShortCut: TShortCut; +begin + ParentMenu := GetParentMenu; + if (not Win32PlatformIsUnicode) + or (Self.IsLine) + or ( (ParentMenu <> nil) and (ParentMenu.OwnerDraw or (GetImageList <> nil)) + and (Assigned(OnAdvancedDrawItem) or Assigned(OnDrawItem)) ) then + inherited + else begin + SaveCaption := Caption; + SaveShortCut := ShortCut; + try + FIgnoreMenuChanged := True; + try + Caption := ''; + ShortCut := scNone; + finally + FIgnoreMenuChanged := False; + end; + inherited; + finally + FIgnoreMenuChanged := True; + try + Caption := SaveCaption; + ShortCut := SaveShortcut; + finally + FIgnoreMenuChanged := False; + end; + end; + DrawMenuText((ParentMenu <> nil) and (ParentMenu.IsRightToLeft)) + end; +end; + +procedure TTntMenuItem.DoDrawText(ACanvas: TCanvas; const ACaption: WideString; + var Rect: TRect; Selected: Boolean; Flags: Longint); +var + Text: WideString; + ParentMenu: TMenu; +begin + if (not Win32PlatformIsUnicode) + or (IsLine) then + inherited DoDrawText(ACanvas, ACaption, Rect, Selected, Flags) + else begin + ParentMenu := GetParentMenu; + if (ParentMenu <> nil) and (ParentMenu.IsRightToLeft) then + begin + if Flags and DT_LEFT = DT_LEFT then + Flags := Flags and (not DT_LEFT) or DT_RIGHT + else if Flags and DT_RIGHT = DT_RIGHT then + Flags := Flags and (not DT_RIGHT) or DT_LEFT; + Flags := Flags or DT_RTLREADING; + end; + Text := ACaption; + if (Flags and DT_CALCRECT <> 0) and ((Text = '') or + (Text[1] = cHotkeyPrefix) and (Text[2] = #0)) then Text := Text + ' '; + with ACanvas do + begin + Brush.Style := bsClear; + if Default then + Font.Style := Font.Style + [fsBold]; + if not Enabled then + begin + if not Selected then + begin + OffsetRect(Rect, 1, 1); + Font.Color := clBtnHighlight; + Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags); + OffsetRect(Rect, -1, -1); + end; + if Selected and (ColorToRGB(clHighlight) = ColorToRGB(clBtnShadow)) then + Font.Color := clBtnHighlight else + Font.Color := clBtnShadow; + end; + Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags); + end; + end; +end; + +function TTntMenuItem.MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer; +var + R: TRect; +begin + FillChar(R, SizeOf(R), 0); + DoDrawText(ACanvas, Text, R, False, + GetAlignmentDrawStyle or DT_EXPANDTABS or DT_SINGLELINE or DT_NOCLIP or DT_CALCRECT); + Result := R.Right - R.Left; +end; + +procedure TTntMenuItem.MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); +var + SaveMeasureItemEvent: TMenuMeasureItemEvent; +begin + if (not Win32PlatformIsUnicode) + or (Self.IsLine) then + inherited + else begin + SaveMeasureItemEvent := inherited OnMeasureItem; + try + inherited OnMeasureItem := nil; + inherited; + Inc(Width, MeasureItemTextWidth(ACanvas, Caption)); + Dec(Width, MeasureItemTextWidth(ACanvas, inherited Caption)); + if ShortCut <> scNone then begin + Inc(Width, MeasureItemTextWidth(ACanvas, WideShortCutToText(ShortCut))); + Dec(Width, MeasureItemTextWidth(ACanvas, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut))); + end; + finally + inherited OnMeasureItem := SaveMeasureItemEvent; + end; + if Assigned(OnMeasureItem) then OnMeasureItem(Self, ACanvas, Width, Height); + end; +end; + +function TTntMenuItem.Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem}; +var + I: Integer; +begin + Result := nil; + ACaption := WideStripHotkey(ACaption); + for I := 0 to Count - 1 do + if WideSameText(ACaption, WideStripHotkey(WideGetMenuItemCaption(Items[I]))) then + begin + Result := Items[I]; + System.Break; + end; +end; + +function TTntMenuItem.GetActionLinkClass: TMenuActionLinkClass; +begin + Result := TTntMenuActionLink; +end; + +procedure TTntMenuItem.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + if (Sender is TCustomAction{TNT-ALLOW TCustomAction}) and Supports(Sender, ITntAction) then begin + if not CheckDefaults or (Caption = '') then + Caption := TntAction_GetCaption(TCustomAction{TNT-ALLOW TCustomAction}(Sender)); + if not CheckDefaults or (Hint = '') then + Hint := TntAction_GetHint(TCustomAction{TNT-ALLOW TCustomAction}(Sender)); + end; + inherited; +end; + +{ TTntMainMenu } + +{$IFDEF COMPILER_9_UP} +function TTntMainMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; +begin + Result := TTntMenuItem.Create(Self); +end; +{$ENDIF} + +procedure TTntMainMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); +begin + inherited; + UpdateMenuItems(Items, Self); + if (THackMenuItem(Items).FMerged <> nil) then begin + UpdateMenuItems(THackMenuItem(Items).FMerged, Self); + end; +end; + +{ TTntPopupMenu } + +constructor TTntPopupMenu.Create(AOwner: TComponent); +begin + inherited; + PopupList.Remove(Self); + if TntPopupList <> nil then + TntPopupList.Add(Self); +end; + +{$IFDEF COMPILER_9_UP} +function TTntPopupMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; +begin + Result := TTntMenuItem.Create(Self); +end; +{$ENDIF} + +destructor TTntPopupMenu.Destroy; +begin + if TntPopupList <> nil then + TntPopupList.Remove(Self); + PopupList.Add(Self); + inherited; +end; + +procedure TTntPopupMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); +begin + inherited; + UpdateMenuItems(Items, Self); +end; + +procedure TTntPopupMenu.Popup(X, Y: Integer); +begin + Menus.PopupList := TntPopupList; + try + inherited; + finally + Menus.PopupList := TntPopupList.SavedPopupList; + end; +end; + +{ TTntPopupList } + +procedure TTntPopupList.WndProc(var Message: TMessage); +var + I, Item: Integer; + MenuItem: TMenuItem{TNT-ALLOW TMenuItem}; + FindKind: TFindItemKind; +begin + case Message.Msg of + WM_ENTERMENULOOP: + begin + Menus.PopupList := SavedPopupList; + for i := 0 to Count - 1 do + FixMenuBiDiProblem(Items[i]); + end; + WM_MENUSELECT: + with TWMMenuSelect(Message) do + begin + FindKind := fkCommand; + if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle; + for I := 0 to Count - 1 do + begin + if FindKind = fkHandle then + begin + if Menu <> 0 then + Item := Integer(GetSubMenu(Menu, IDItem)) else + Item := -1; + end + else + Item := IDItem; + MenuItem := TPopupMenu{TNT-ALLOW TPopupMenu}(Items[I]).FindItem(Item, FindKind); + if MenuItem <> nil then + begin + TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem)); + Exit; + end; + end; + TntApplication.Hint := ''; + end; + end; + inherited; +end; + +initialization + TntPopupList := TTntPopupList.Create; + TntPopupList.SavedPopupList := Menus.PopupList; + +finalization + FreeAndNil(TntPopupList); + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas new file mode 100644 index 0000000000..e3f445f92b --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas @@ -0,0 +1,148 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntRegistry; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Registry, Windows, TntClasses; + +{TNT-WARN TRegistry} +type + TTntRegistry = class(TRegistry{TNT-ALLOW TRegistry}) + private + procedure WriteStringEx(dwType: DWORD; const Name, Value: WideString); + public + procedure GetKeyNames(Strings: TTntStrings); + procedure GetValueNames(Strings: TTntStrings); + function ReadString(const Name: WideString): WideString; + procedure WriteString(const Name, Value: WideString); + procedure WriteExpandString(const Name, Value: WideString); + end; + +implementation + +uses + RTLConsts, SysUtils, TntSysUtils; + +{ TTntRegistry } + +procedure TTntRegistry.GetKeyNames(Strings: TTntStrings); +var + Len: DWORD; + I: Integer; + Info: TRegKeyInfo; + S: WideString; +begin + if (not Win32PlatformIsUnicode) then + inherited GetKeyNames(Strings.AnsiStrings) + else begin + Strings.Clear; + if GetKeyInfo(Info) then + begin + SetLength(S, (Info.MaxSubKeyLen + 1) * 2); + for I := 0 to Info.NumSubKeys - 1 do + begin + Len := (Info.MaxSubKeyLen + 1) * 2; + if RegEnumKeyExW(CurrentKey, I, PWideChar(S), Len, nil, nil, nil, nil) = ERROR_SUCCESS then + Strings.Add(PWideChar(S)); + end; + end; + end; +end; + +{$IFNDEF COMPILER_9_UP} // fix declaration for RegEnumValueW (lpValueName is a PWideChar) +function RegEnumValueW(hKey: HKEY; dwIndex: DWORD; lpValueName: PWideChar; + var lpcbValueName: DWORD; lpReserved: Pointer; lpType: PDWORD; + lpData: PByte; lpcbData: PDWORD): Longint; stdcall; external advapi32 name 'RegEnumValueW'; +{$ENDIF} + +procedure TTntRegistry.GetValueNames(Strings: TTntStrings); +var + Len: DWORD; + I: Integer; + Info: TRegKeyInfo; + S: WideString; +begin + if (not Win32PlatformIsUnicode) then + inherited GetValueNames(Strings.AnsiStrings) + else begin + Strings.Clear; + if GetKeyInfo(Info) then + begin + SetLength(S, Info.MaxValueLen + 1); + for I := 0 to Info.NumValues - 1 do + begin + Len := Info.MaxValueLen + 1; + RegEnumValueW(CurrentKey, I, PWideChar(S), Len, nil, nil, nil, nil); + Strings.Add(PWideChar(S)); + end; + end; + end; +end; + +function TTntRegistry.ReadString(const Name: WideString): WideString; +var + DataType: Cardinal; + BufSize: Cardinal; +begin + if (not Win32PlatformIsUnicode) then + result := inherited ReadString(Name) + else begin + // get length and type + DataType := REG_NONE; + if RegQueryValueExW(CurrentKey, PWideChar(Name), nil, + @DataType, nil, @BufSize) <> ERROR_SUCCESS then + Result := '' + else begin + // check type + if not (DataType in [REG_SZ, REG_EXPAND_SZ]) then + raise ERegistryException.CreateFmt(SInvalidRegType, [Name]); + if BufSize = 1 then + BufSize := SizeOf(WideChar); // sometimes this occurs for single character values! + SetLength(Result, BufSize div SizeOf(WideChar)); + if RegQueryValueExW(CurrentKey, PWideChar(Name), nil, + @DataType, PByte(PWideChar(Result)), @BufSize) <> ERROR_SUCCESS then + raise ERegistryException.CreateFmt(SRegGetDataFailed, [Name]); + Result := PWideChar(Result); + end + end +end; + +procedure TTntRegistry.WriteStringEx(dwType: DWORD; const Name, Value: WideString); +begin + Assert(dwType in [REG_SZ, REG_EXPAND_SZ]); + if (not Win32PlatformIsUnicode) then begin + if dwType = REG_SZ then + inherited WriteString(Name, Value) + else + inherited WriteExpandString(Name, Value); + end else begin + if RegSetValueExW(CurrentKey, PWideChar(Name), 0, dwType, + PWideChar(Value), (Length(Value) + 1) * SizeOf(WideChar)) <> ERROR_SUCCESS then + raise ERegistryException.CreateFmt(SRegSetDataFailed, [Name]); + end; +end; + +procedure TTntRegistry.WriteString(const Name, Value: WideString); +begin + WriteStringEx(REG_SZ, Name, Value); +end; + +procedure TTntRegistry.WriteExpandString(const Name, Value: WideString); +begin + WriteStringEx(REG_EXPAND_SZ, Name, Value); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas new file mode 100644 index 0000000000..118e806336 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas @@ -0,0 +1,1922 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntStdActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, ActnList, TntActnList, StdActns, TntDialogs; + +type +{TNT-WARN THintAction} + TTntHintAction = class(THintAction{TNT-ALLOW THintAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + published + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditAction} + TTntEditAction = class(TEditAction{TNT-ALLOW TEditAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditCut} + TTntEditCut = class(TEditCut{TNT-ALLOW TEditCut}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditCopy} + TTntEditCopy = class(TEditCopy{TNT-ALLOW TEditCopy}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditPaste} + TTntEditPaste = class(TEditPaste{TNT-ALLOW TEditPaste}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditSelectAll} + TTntEditSelectAll = class(TEditSelectAll{TNT-ALLOW TEditSelectAll}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditUndo} + TTntEditUndo = class(TEditUndo{TNT-ALLOW TEditUndo}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditDelete} + TTntEditDelete = class(TEditDelete{TNT-ALLOW TEditDelete}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + procedure UpdateTarget(Target: TObject); override; + procedure ExecuteTarget(Target: TObject); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowAction} + TTntWindowAction = class(TWindowAction{TNT-ALLOW TWindowAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowClose} + TTntWindowClose = class(TWindowClose{TNT-ALLOW TWindowClose}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowCascade} + TTntWindowCascade = class(TWindowCascade{TNT-ALLOW TWindowCascade}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowTileHorizontal} + TTntWindowTileHorizontal = class(TWindowTileHorizontal{TNT-ALLOW TWindowTileHorizontal}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowTileVertical} + TTntWindowTileVertical = class(TWindowTileVertical{TNT-ALLOW TWindowTileVertical}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowMinimizeAll} + TTntWindowMinimizeAll = class(TWindowMinimizeAll{TNT-ALLOW TWindowMinimizeAll}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowArrange} + TTntWindowArrange = class(TWindowArrange{TNT-ALLOW TWindowArrange}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpAction} + TTntHelpAction = class(THelpAction{TNT-ALLOW THelpAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpContents} + TTntHelpContents = class(THelpContents{TNT-ALLOW THelpContents}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpTopicSearch} + TTntHelpTopicSearch = class(THelpTopicSearch{TNT-ALLOW THelpTopicSearch}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpOnHelp} + TTntHelpOnHelp = class(THelpOnHelp{TNT-ALLOW THelpOnHelp}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpContextAction} + TTntHelpContextAction = class(THelpContextAction{TNT-ALLOW THelpContextAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TCommonDialogAction} + TTntCommonDialogAction = class(TCommonDialogAction{TNT-ALLOW TCommonDialogAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileAction} + TTntFileAction = class(TFileAction{TNT-ALLOW TFileAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileOpen} + TTntFileOpen = class(TFileOpen{TNT-ALLOW TFileOpen}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function GetDialog: TTntOpenDialog; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetDialogClass: TCommonDialogClass; override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Dialog: TTntOpenDialog read GetDialog; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileOpenWith} + TTntFileOpenWith = class(TFileOpenWith{TNT-ALLOW TFileOpenWith}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function GetDialog: TTntOpenDialog; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetDialogClass: TCommonDialogClass; override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Dialog: TTntOpenDialog read GetDialog; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileSaveAs} + TTntFileSaveAs = class(TFileSaveAs{TNT-ALLOW TFileSaveAs}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function GetDialog: TTntSaveDialog; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetDialogClass: TCommonDialogClass; override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Dialog: TTntSaveDialog read GetDialog; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFilePrintSetup} + TTntFilePrintSetup = class(TFilePrintSetup{TNT-ALLOW TFilePrintSetup}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + + {$IFDEF COMPILER_7_UP} +{TNT-WARN TFilePageSetup} + TTntFilePageSetup = class(TFilePageSetup{TNT-ALLOW TFilePageSetup}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + {$ENDIF} + +{TNT-WARN TFileExit} + TTntFileExit = class(TFileExit{TNT-ALLOW TFileExit}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchAction} + TTntSearchAction = class(TSearchAction{TNT-ALLOW TSearchAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchFind} + TTntSearchFind = class(TSearchFind{TNT-ALLOW TSearchFind}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchReplace} + TTntSearchReplace = class(TSearchReplace{TNT-ALLOW TSearchReplace}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchFindFirst} + TTntSearchFindFirst = class(TSearchFindFirst{TNT-ALLOW TSearchFindFirst}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchFindNext} + TTntSearchFindNext = class(TSearchFindNext{TNT-ALLOW TSearchFindNext}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFontEdit} + TTntFontEdit = class(TFontEdit{TNT-ALLOW TFontEdit}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TColorSelect} + TTntColorSelect = class(TColorSelect{TNT-ALLOW TColorSelect}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TPrintDlg} + TTntPrintDlg = class(TPrintDlg{TNT-ALLOW TPrintDlg}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +procedure TntStdActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); + +implementation + +uses + Dialogs, TntClasses; + +{TNT-IGNORE-UNIT} + +procedure TntStdActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntAction_AfterInherited_Assign(Action, Source); + // TCommonDialogAction + if (Action is TCommonDialogAction) and (Source is TCommonDialogAction) then begin + TCommonDialogAction(Action).BeforeExecute := TCommonDialogAction(Source).BeforeExecute; + TCommonDialogAction(Action).OnAccept := TCommonDialogAction(Source).OnAccept; + TCommonDialogAction(Action).OnCancel := TCommonDialogAction(Source).OnCancel; + end; + // TFileOpen + if (Action is TFileOpen) and (Source is TFileOpen) then begin + {$IFDEF COMPILER_7_UP} + TFileOpen(Action).UseDefaultApp := TFileOpen(Source).UseDefaultApp; + {$ENDIF} + end; + // TFileOpenWith + if (Action is TFileOpenWith) and (Source is TFileOpenWith) then begin + TFileOpenWith(Action).FileName := TFileOpenWith(Source).FileName; + {$IFDEF COMPILER_7_UP} + TFileOpenWith(Action).AfterOpen := TFileOpenWith(Source).AfterOpen; + {$ENDIF} + end; + // TSearchFindNext + if (Action is TSearchFindNext) and (Source is TSearchFindNext) then begin + TSearchFindNext(Action).SearchFind := TSearchFindNext(Source).SearchFind; + end; +end; + +//------------------------- +// TNT STD ACTNS +//------------------------- + +{ TTntHintAction } + +procedure TTntHintAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHintAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHintAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHintAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHintAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHintAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditAction } + +procedure TTntEditAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditCut } + +procedure TTntEditCut.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditCut.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditCut.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditCut.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditCut.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditCut.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditCopy } + +procedure TTntEditCopy.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditCopy.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditCopy.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditCopy.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditCopy.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditCopy.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditPaste } + +procedure TTntEditPaste.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditPaste.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditPaste.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditPaste.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditPaste.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditPaste.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditSelectAll } + +procedure TTntEditSelectAll.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditSelectAll.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditSelectAll.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditSelectAll.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditSelectAll.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditSelectAll.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditUndo } + +procedure TTntEditUndo.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditUndo.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditUndo.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditUndo.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditUndo.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditUndo.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditDelete } + +procedure TTntEditDelete.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditDelete.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditDelete.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditDelete.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditDelete.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditDelete.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +procedure TTntEditDelete.UpdateTarget(Target: TObject); +begin + Enabled := True; +end; + +procedure TTntEditDelete.ExecuteTarget(Target: TObject); +begin + if GetControl(Target).SelLength = 0 then + GetControl(Target).SelLength := 1; + GetControl(Target).ClearSelection +end; + +{ TTntWindowAction } + +procedure TTntWindowAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowClose } + +procedure TTntWindowClose.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowClose.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowClose.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowClose.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowClose.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowClose.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowCascade } + +procedure TTntWindowCascade.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowCascade.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowCascade.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowCascade.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowCascade.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowCascade.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowTileHorizontal } + +procedure TTntWindowTileHorizontal.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowTileHorizontal.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowTileHorizontal.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowTileHorizontal.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowTileHorizontal.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowTileHorizontal.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowTileVertical } + +procedure TTntWindowTileVertical.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowTileVertical.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowTileVertical.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowTileVertical.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowTileVertical.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowTileVertical.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowMinimizeAll } + +procedure TTntWindowMinimizeAll.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowMinimizeAll.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowMinimizeAll.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowMinimizeAll.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowMinimizeAll.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowMinimizeAll.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowArrange } + +procedure TTntWindowArrange.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowArrange.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowArrange.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowArrange.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowArrange.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowArrange.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpAction } + +procedure TTntHelpAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpContents } + +procedure TTntHelpContents.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpContents.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpContents.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpContents.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpContents.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpContents.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpTopicSearch } + +procedure TTntHelpTopicSearch.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpTopicSearch.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpTopicSearch.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpTopicSearch.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpTopicSearch.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpTopicSearch.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpOnHelp } + +procedure TTntHelpOnHelp.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpOnHelp.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpOnHelp.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpOnHelp.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpOnHelp.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpOnHelp.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpContextAction } + +procedure TTntHelpContextAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpContextAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpContextAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpContextAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpContextAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpContextAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntCommonDialogAction } + +procedure TTntCommonDialogAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCommonDialogAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCommonDialogAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCommonDialogAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCommonDialogAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCommonDialogAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntFileAction } + +procedure TTntFileAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntFileOpen } + +procedure TTntFileOpen.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileOpen.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileOpen.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileOpen.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileOpen.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileOpen.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +function TTntFileOpen.GetDialog: TTntOpenDialog; +begin + Result := inherited Dialog as TTntOpenDialog; +end; + +function TTntFileOpen.GetDialogClass: TCommonDialogClass; +begin + Result := TTntOpenDialog; +end; + +{ TTntFileOpenWith } + +procedure TTntFileOpenWith.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileOpenWith.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileOpenWith.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileOpenWith.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileOpenWith.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileOpenWith.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +function TTntFileOpenWith.GetDialog: TTntOpenDialog; +begin + Result := inherited Dialog as TTntOpenDialog; +end; + +function TTntFileOpenWith.GetDialogClass: TCommonDialogClass; +begin + Result := TTntOpenDialog; +end; + +{ TTntFileSaveAs } + +procedure TTntFileSaveAs.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileSaveAs.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileSaveAs.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileSaveAs.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileSaveAs.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileSaveAs.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +function TTntFileSaveAs.GetDialog: TTntSaveDialog; +begin + Result := TOpenDialog(inherited Dialog) as TTntSaveDialog; +end; + +function TTntFileSaveAs.GetDialogClass: TCommonDialogClass; +begin + Result := TTntSaveDialog; +end; + +{ TTntFilePrintSetup } + +procedure TTntFilePrintSetup.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFilePrintSetup.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFilePrintSetup.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFilePrintSetup.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFilePrintSetup.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFilePrintSetup.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + + {$IFDEF COMPILER_7_UP} + +{ TTntFilePageSetup } + +procedure TTntFilePageSetup.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFilePageSetup.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFilePageSetup.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFilePageSetup.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFilePageSetup.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFilePageSetup.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + {$ENDIF} + +{ TTntFileExit } + +procedure TTntFileExit.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileExit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileExit.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileExit.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileExit.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileExit.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchAction } + +procedure TTntSearchAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchFind } + +procedure TTntSearchFind.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchFind.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchFind.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchFind.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchFind.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchFind.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchReplace } + +procedure TTntSearchReplace.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchReplace.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchReplace.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchReplace.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchReplace.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchReplace.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchFindFirst } + +procedure TTntSearchFindFirst.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchFindFirst.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchFindFirst.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchFindFirst.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchFindFirst.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchFindFirst.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchFindNext } + +procedure TTntSearchFindNext.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchFindNext.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchFindNext.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchFindNext.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchFindNext.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchFindNext.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntFontEdit } + +procedure TTntFontEdit.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFontEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFontEdit.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFontEdit.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFontEdit.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFontEdit.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntColorSelect } + +procedure TTntColorSelect.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntColorSelect.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntColorSelect.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntColorSelect.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntColorSelect.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntColorSelect.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntPrintDlg } + +procedure TTntPrintDlg.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntPrintDlg.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPrintDlg.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntPrintDlg.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntPrintDlg.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntPrintDlg.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas new file mode 100644 index 0000000000..09c7da4573 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas @@ -0,0 +1,3215 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntStdCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: Implement TCustomListBox.KeyPress, OnDataFind. } + +uses + Windows, Messages, Classes, Controls, TntControls, StdCtrls, Graphics, + TntClasses, TntSysUtils; + +{TNT-WARN TCustomEdit} +type + TTntCustomEdit = class(TCustomEdit{TNT-ALLOW TCustomEdit}) + private + FPasswordChar: WideChar; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + function GetPasswordChar: WideChar; + procedure SetPasswordChar(const Value: WideChar); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetSelStart: Integer; reintroduce; virtual; + procedure SetSelStart(const Value: Integer); reintroduce; virtual; + function GetSelLength: Integer; reintroduce; virtual; + procedure SetSelLength(const Value: Integer); reintroduce; virtual; + function GetSelText: WideString; reintroduce; virtual; + property PasswordChar: WideChar read GetPasswordChar write SetPasswordChar default #0; + public + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TEdit} + TTntEdit = class(TTntCustomEdit) + published + property Align; + property Anchors; + property AutoSelect; + property AutoSize; + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property CharCase; + property Color; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property ImeMode; + property ImeName; + property MaxLength; + property OEMConvert; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PasswordChar; + property PopupMenu; + property ReadOnly; + property ShowHint; + property TabOrder; + property TabStop; + property Text; + property Visible; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +type + TTntCustomMemo = class; + + TTntMemoStrings = class(TTntStrings) + protected + FMemo: TCustomMemo{TNT-ALLOW TCustomMemo}; + FMemoLines: TStrings{TNT-ALLOW TStrings}; + FRichEditMode: Boolean; + FLineBreakStyle: TTntTextLineBreakStyle; + function Get(Index: Integer): WideString; override; + function GetCount: Integer; override; + function GetTextStr: WideString; override; + procedure Put(Index: Integer; const S: WideString); override; + procedure SetUpdateState(Updating: Boolean); override; + public + constructor Create; + procedure SetTextStr(const Value: WideString); override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: WideString); override; + end; + +{TNT-WARN TCustomMemo} + TTntCustomMemo = class(TCustomMemo{TNT-ALLOW TCustomMemo}) + private + FLines: TTntStrings; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure SetLines(const Value: TTntStrings); virtual; + function GetSelStart: Integer; reintroduce; virtual; + procedure SetSelStart(const Value: Integer); reintroduce; virtual; + function GetSelLength: Integer; reintroduce; virtual; + procedure SetSelLength(const Value: Integer); reintroduce; virtual; + function GetSelText: WideString; reintroduce; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + property Lines: TTntStrings read FLines write SetLines; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TMemo} + TTntMemo = class(TTntCustomMemo) + published + property Align; + property Alignment; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property BiDiMode; + property BorderStyle; + property Color; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property ImeMode; + property ImeName; + property Lines; + property MaxLength; + property OEMConvert; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly; + property ScrollBars; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property WantReturns; + property WantTabs; + property WordWrap; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + + TTntComboBoxStrings = class(TTntStrings) + protected + function Get(Index: Integer): WideString; override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + ComboBox: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + function Add(const S: WideString): Integer; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + function IndexOf(const S: WideString): Integer; override; + procedure Insert(Index: Integer; const S: WideString); override; + end; + +type + TWMCharMsgHandler = procedure(var Message: TWMChar) of object; + +{$IFDEF DELPHI_7} // fix for Delphi 7 only +{ TD7PatchedComboBoxStrings } +type + TD7PatchedComboBoxStrings = class(TCustomComboBoxStrings) + protected + function Get(Index: Integer): string{TNT-ALLOW string}; override; + public + function Add(const S: string{TNT-ALLOW string}): Integer; override; + procedure Insert(Index: Integer; const S: string{TNT-ALLOW string}); override; + end; +{$ENDIF} + +type + ITntComboFindString = interface + ['{63BEBEF4-B1A2-495A-B558-7487B66F6827}'] + function FindString(const Value: WideString; StartPos: Integer): Integer; + end; + +{TNT-WARN TCustomComboBox} +type + TTntCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}, + IWideCustomListControl) + private + FItems: TTntStrings; + FSaveItems: TTntStrings; + FSaveItemIndex: Integer; + FFilter: WideString; + FLastTime: Cardinal; + function GetItems: TTntStrings; + function GetSelStart: Integer; + procedure SetSelStart(const Value: Integer); + function GetSelLength: Integer; + procedure SetSelLength(const Value: Integer); + function GetSelText: WideString; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Message: TWMChar); message WM_CHAR; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure DestroyWnd; override; + function GetAutoComplete_UniqueMatchOnly: Boolean; dynamic; + function GetAutoComplete_PreserveDataEntryCase: Boolean; dynamic; + procedure DoEditCharMsg(var Message: TWMChar); virtual; + procedure CreateWnd; override; + procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); override; + procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; + procedure KeyPress(var Key: AnsiChar); override; + {$IFDEF DELPHI_7} // fix for Delphi 7 only + function GetItemsClass: TCustomComboBoxStringsClass; override; + {$ENDIF} + procedure SetItems(const Value: TTntStrings); reintroduce; virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + public + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + property Items: TTntStrings read GetItems write SetItems; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TComboBox} + TTntComboBox = class(TTntCustomComboBox) + published + property Align; + property AutoComplete default True; + {$IFDEF COMPILER_9_UP} + property AutoCompleteDelay default 500; + {$ENDIF} + property AutoDropDown default False; + {$IFDEF COMPILER_7_UP} + property AutoCloseUp default False; + {$ENDIF} + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property Style; {Must be published before Items} + property Anchors; + property BiDiMode; + property CharCase; + property Color; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property DropDownCount; + property Enabled; + property Font; + property ImeMode; + property ImeName; + property ItemHeight; + property ItemIndex default -1; + property MaxLength; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property Sorted; + property TabOrder; + property TabStop; + property Text; + property Visible; + property OnChange; + property OnClick; + property OnCloseUp; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawItem; + property OnDropDown; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMeasureItem; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnSelect; + property OnStartDock; + property OnStartDrag; + property Items; { Must be published after OnMeasureItem } + end; + + TLBGetWideDataEvent = procedure(Control: TWinControl; Index: Integer; + var Data: WideString) of object; + + TAccessCustomListBox = class(TCustomListBox{TNT-ALLOW TCustomListBox}); + + TTntListBoxStrings = class(TTntStrings) + private + FListBox: TAccessCustomListBox; + function GetListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + procedure SetListBox(const Value: TCustomListBox{TNT-ALLOW TCustomListBox}); + protected + procedure Put(Index: Integer; const S: WideString); override; + function Get(Index: Integer): WideString; override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + function Add(const S: WideString): Integer; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Exchange(Index1, Index2: Integer); override; + function IndexOf(const S: WideString): Integer; override; + procedure Insert(Index: Integer; const S: WideString); override; + procedure Move(CurIndex, NewIndex: Integer); override; + property ListBox: TCustomListBox{TNT-ALLOW TCustomListBox} read GetListBox write SetListBox; + end; + +{TNT-WARN TCustomListBox} +type + TTntCustomListBox = class(TCustomListBox{TNT-ALLOW TCustomListBox}, IWideCustomListControl) + private + FItems: TTntStrings; + FSaveItems: TTntStrings; + FSaveTopIndex: Integer; + FSaveItemIndex: Integer; + FOnData: TLBGetWideDataEvent; + procedure SetItems(const Value: TTntStrings); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure LBGetText(var Message: TMessage); message LB_GETTEXT; + procedure LBGetTextLen(var Message: TMessage); message LB_GETTEXTLEN; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; + property OnData: TLBGetWideDataEvent read FOnData write FOnData; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + property Items: TTntStrings read FItems write SetItems; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TListBox} + TTntListBox = class(TTntCustomListBox) + published + property Style; + property AutoComplete; + {$IFDEF COMPILER_9_UP} + property AutoCompleteDelay; + {$ENDIF} + property Align; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property Color; + property Columns; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ExtendedSelect; + property Font; + property ImeMode; + property ImeName; + property IntegralHeight; + property ItemHeight; + property Items; + property MultiSelect; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ScrollWidth; + property ShowHint; + property Sorted; + property TabOrder; + property TabStop; + property TabWidth; + property Visible; + property OnClick; + property OnContextPopup; + property OnData; + property OnDataFind; + property OnDataObject; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawItem; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMeasureItem; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +{TNT-WARN TCustomLabel} + TTntCustomLabel = class(TCustomLabel{TNT-ALLOW TCustomLabel}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetLabelText: WideString; reintroduce; virtual; + procedure DoDrawText(var Rect: TRect; Flags: Longint); override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TLabel} + TTntLabel = class(TTntCustomLabel) + published + property Align; + property Alignment; + property Anchors; + property AutoSize; + property BiDiMode; + property Caption; + property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + {$IFDEF COMPILER_9_UP} + property EllipsisPosition; + {$ENDIF} + property Enabled; + property FocusControl; + property Font; + property ParentBiDiMode; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowAccelChar; + property ShowHint; + property Transparent; + property Layout; + property Visible; + property WordWrap; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseEnter; + property OnMouseLeave; + property OnStartDock; + property OnStartDrag; + end; + +{TNT-WARN TButton} + TTntButton = class(TButton{TNT-ALLOW TButton}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomCheckBox} + TTntCustomCheckBox = class(TCustomCheckBox{TNT-ALLOW TCustomCheckBox}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCheckBox} + TTntCheckBox = class(TTntCustomCheckBox) + published + property Action; + property Align; + property Alignment; + property AllowGrayed; + property Anchors; + property BiDiMode; + property Caption; + property Checked; + property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property State; + property TabOrder; + property TabStop; + property Visible; + {$IFDEF COMPILER_7_UP} + property WordWrap; + {$ENDIF} + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +{TNT-WARN TRadioButton} + TTntRadioButton = class(TRadioButton{TNT-ALLOW TRadioButton}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TScrollBar} + TTntScrollBar = class(TScrollBar{TNT-ALLOW TScrollBar}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomGroupBox} + TTntCustomGroupBox = class(TCustomGroupBox{TNT-ALLOW TCustomGroupBox}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure Paint; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TGroupBox} + TTntGroupBox = class(TTntCustomGroupBox) + published + property Align; + property Anchors; + property BiDiMode; + property Caption; + property Color; + property Constraints; + property Ctl3D; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + {$IFDEF COMPILER_10_UP} + property Padding; + {$ENDIF} + {$IFDEF COMPILER_7_UP} + property ParentBackground default True; + {$ENDIF} + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + {$IFDEF COMPILER_9_UP} + property OnAlignInsertBefore; + property OnAlignPosition; + {$ENDIF} + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDockDrop; + property OnDockOver; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +{TNT-WARN TCustomStaticText} + TTntCustomStaticText = class(TCustomStaticText{TNT-ALLOW TCustomStaticText}) + private + procedure AdjustBounds; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; + procedure Loaded; override; + procedure SetAutoSize(AValue: boolean); override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + public + constructor Create(AOwner: TComponent); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TStaticText} + TTntStaticText = class(TTntCustomStaticText) + published + property Align; + property Alignment; + property Anchors; + property AutoSize; + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property BiDiMode; + property BorderStyle; + property Caption; + property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property FocusControl; + property Font; + property ParentBiDiMode; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowAccelChar; + property ShowHint; + property TabOrder; + property TabStop; + {$IFDEF COMPILER_7_UP} + property Transparent; + {$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +procedure TntCombo_AfterInherited_CreateWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var FSaveItems: TTntStrings; FSaveItemIndex: integer; PreInheritedAnsiText: AnsiString); +procedure TntCombo_BeforeInherited_DestroyWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var FSaveItems: TTntStrings; ItemIndex: integer; var FSaveItemIndex: integer; + var SavedText: WideString); +function TntCombo_ComboWndProc(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer; DoEditCharMsg: TWMCharMsgHandler): Boolean; +function TntCombo_CNCommand(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; Items: TTntStrings; var Message: TWMCommand): Boolean; +function TntCombo_GetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; +procedure TntCombo_SetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); +function TntCombo_GetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; +procedure TntCombo_SetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); +function TntCombo_GetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): WideString; +procedure TntCombo_SetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: WideString); +procedure TntCombo_BeforeKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); +procedure TntCombo_AfterKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); +procedure TntCombo_DropDown_PreserveSelection(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}); +procedure TntComboBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); +procedure TntComboBox_CopySelection(Items: TTntStrings; ItemIndex: Integer; + Destination: TCustomListControl); +procedure TntCombo_AutoSearchKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var Message: TWMChar; var FFilter: WideString; var FLastTime: Cardinal); +procedure TntCombo_AutoCompleteKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var Message: TWMChar; + AutoComplete_UniqueMatchOnly, AutoComplete_PreserveDataEntryCase: Boolean); +procedure TntCombo_DefaultDrawItem(Canvas: TCanvas; Index: Integer; Rect: TRect; + State: TOwnerDrawState; Items: TTntStrings); + +procedure TntCustomEdit_CreateWindowHandle(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Params: TCreateParams); +procedure TntCustomEdit_AfterInherited_CreateWnd(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar); +function TntCustomEdit_GetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; +procedure TntCustomEdit_SetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); +function TntCustomEdit_GetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; +procedure TntCustomEdit_SetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); +function TntCustomEdit_GetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): WideString; +procedure TntCustomEdit_SetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: WideString); +function TntCustomEdit_GetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar): WideChar; +procedure TntCustomEdit_SetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar; const Value: WideChar); + + +function TntMemo_LineStart(Handle: THandle; Index: Integer): Integer; +function TntMemo_LineLength(Handle: THandle; Index: Integer; StartPos: Integer = -1): Integer; + +procedure TntListBox_AfterInherited_CreateWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + var FSaveItems: TTntStrings; FItems: TTntStrings; FSaveTopIndex, FSaveItemIndex: Integer); +procedure TntListBox_BeforeInherited_DestroyWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + var FSaveItems: TTntStrings; const FItems: TTntStrings; var FSaveTopIndex, FSaveItemIndex: Integer); +procedure TntListBox_DrawItem_Text(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; Items: TTntStrings; Index: Integer; Rect: TRect); +procedure TntListBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); +procedure TntListBox_CopySelection(ListBox: TCustomListbox{TNT-ALLOW TCustomListbox}; + Items: TTntStrings; Destination: TCustomListControl); +function TntCustomListBox_LBGetText(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; +function TntCustomListBox_LBGetTextLen(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; + +function TntLabel_DoDrawText(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Rect: TRect; Flags: Integer; const GetLabelText: WideString): Boolean; +procedure TntLabel_CMDialogChar(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Message: TCMDialogChar; const Caption: WideString); + +procedure TntButton_CMDialogChar(Button: TButton{TNT-ALLOW TButton}; var Message: TCMDialogChar); + +implementation + +uses + Forms, SysUtils, Consts, RichEdit, ComStrs, + RTLConsts, {$IFDEF THEME_7_UP} Themes, {$ENDIF} + TntForms, TntGraphics, TntActnList, TntWindows, + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; + +{ TTntCustomEdit } + +procedure TntCustomEdit_CreateWindowHandle(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Params: TCreateParams); +var + P: TCreateParams; +begin + if SysLocale.FarEast + and (not Win32PlatformIsUnicode) + and ((Params.Style and ES_READONLY) <> 0) then begin + // Work around Far East Win95 API/IME bug. + P := Params; + P.Style := P.Style and (not ES_READONLY); + CreateUnicodeHandle(Edit, P, 'EDIT'); + if Edit.HandleAllocated then + SendMessage(Edit.Handle, EM_SETREADONLY, Ord(True), 0); + end else + CreateUnicodeHandle(Edit, Params, 'EDIT'); +end; + +procedure TntCustomEdit_AfterInherited_CreateWnd(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar); +var + PasswordChar: WideChar; +begin + PasswordChar := TntCustomEdit_GetPasswordChar(Edit, FPasswordChar); + if Win32PlatformIsUnicode then + SendMessageW(Edit.Handle, EM_SETPASSWORDCHAR, Ord(PasswordChar), 0); +end; + +function TntCustomEdit_GetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; +begin + if Win32PlatformIsUnicode then + Result := Edit.SelStart + else + Result := Length(WideString(Copy(Edit.Text, 1, Edit.SelStart))); +end; + +procedure TntCustomEdit_SetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); +begin + if Win32PlatformIsUnicode then + Edit.SelStart := Value + else + Edit.SelStart := Length(AnsiString(Copy(TntControl_GetText(Edit), 1, Value))); +end; + +function TntCustomEdit_GetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; +begin + if Win32PlatformIsUnicode then + Result := Edit.SelLength + else + Result := Length(TntCustomEdit_GetSelText(Edit)); +end; + +procedure TntCustomEdit_SetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); +var + StartPos: Integer; +begin + if Win32PlatformIsUnicode then + Edit.SelLength := Value + else begin + StartPos := TntCustomEdit_GetSelStart(Edit); + Edit.SelLength := Length(AnsiString(Copy(TntControl_GetText(Edit), StartPos + 1, Value))); + end; +end; + +function TntCustomEdit_GetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): WideString; +begin + if Win32PlatformIsUnicode then + Result := Copy(TntControl_GetText(Edit), Edit.SelStart + 1, Edit.SelLength) + else + Result := Edit.SelText +end; + +procedure TntCustomEdit_SetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: WideString); +begin + if Win32PlatformIsUnicode then + SendMessageW(Edit.Handle, EM_REPLACESEL, 0, Longint(PWideChar(Value))) + else + Edit.SelText := Value; +end; + +function WideCharToAnsiChar(const C: WideChar): AnsiChar; +begin + if C <= High(AnsiChar) then + Result := AnsiChar(C) + else + Result := '*'; +end; + +type TAccessCustomEdit = class(TCustomEdit{TNT-ALLOW TCustomEdit}); + +function TntCustomEdit_GetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar): WideChar; +begin + if TAccessCustomEdit(Edit).PasswordChar <> WideCharToAnsiChar(FPasswordChar) then + FPasswordChar := WideChar(TAccessCustomEdit(Edit).PasswordChar); + Result := FPasswordChar; +end; + +procedure TntCustomEdit_SetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar; const Value: WideChar); +var + SaveWindowHandle: Integer; + PasswordCharSetHere: Boolean; +begin + if TntCustomEdit_GetPasswordChar(Edit, FPasswordChar) <> Value then + begin + FPasswordChar := Value; + PasswordCharSetHere := Win32PlatformIsUnicode and Edit.HandleAllocated; + SaveWindowHandle := TAccessCustomEdit(Edit).WindowHandle; + try + if PasswordCharSetHere then + TAccessCustomEdit(Edit).WindowHandle := 0; // this prevents TCustomEdit from actually changing it + TAccessCustomEdit(Edit).PasswordChar := WideCharToAnsiChar(FPasswordChar); + finally + TAccessCustomEdit(Edit).WindowHandle := SaveWindowHandle; + end; + if PasswordCharSetHere then + begin + Assert(Win32PlatformIsUnicode); + Assert(Edit.HandleAllocated); + SendMessageW(Edit.Handle, EM_SETPASSWORDCHAR, Ord(FPasswordChar), 0); + Edit.Invalidate; + end; + end; +end; + +procedure TTntCustomEdit.CreateWindowHandle(const Params: TCreateParams); +begin + TntCustomEdit_CreateWindowHandle(Self, Params); +end; + +procedure TTntCustomEdit.CreateWnd; +begin + inherited; + TntCustomEdit_AfterInherited_CreateWnd(Self, FPasswordChar); +end; + +procedure TTntCustomEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomEdit.GetSelStart: Integer; +begin + Result := TntCustomEdit_GetSelStart(Self); +end; + +procedure TTntCustomEdit.SetSelStart(const Value: Integer); +begin + TntCustomEdit_SetSelStart(Self, Value); +end; + +function TTntCustomEdit.GetSelLength: Integer; +begin + Result := TntCustomEdit_GetSelLength(Self); +end; + +procedure TTntCustomEdit.SetSelLength(const Value: Integer); +begin + TntCustomEdit_SetSelLength(Self, Value); +end; + +function TTntCustomEdit.GetSelText: WideString; +begin + Result := TntCustomEdit_GetSelText(Self); +end; + +procedure TTntCustomEdit.SetSelText(const Value: WideString); +begin + TntCustomEdit_SetSelText(Self, Value); +end; + +function TTntCustomEdit.GetPasswordChar: WideChar; +begin + Result := TntCustomEdit_GetPasswordChar(Self, FPasswordChar); +end; + +procedure TTntCustomEdit.SetPasswordChar(const Value: WideChar); +begin + TntCustomEdit_SetPasswordChar(Self, FPasswordChar, Value); +end; + +function TTntCustomEdit.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomEdit.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +function TTntCustomEdit.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomEdit.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomEdit.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomEdit.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntMemoStrings } + +constructor TTntMemoStrings.Create; +begin + inherited; + FLineBreakStyle := tlbsCRLF; +end; + +function TTntMemoStrings.GetCount: Integer; +begin + Result := FMemoLines.Count; +end; + +function TntMemo_LineStart(Handle: THandle; Index: Integer): Integer; +begin + Assert(Win32PlatformIsUnicode); + Result := SendMessageW(Handle, EM_LINEINDEX, Index, 0); +end; + +function TntMemo_LineLength(Handle: THandle; Index: Integer; StartPos: Integer = -1): Integer; +begin + Assert(Win32PlatformIsUnicode); + if StartPos = -1 then + StartPos := TntMemo_LineStart(Handle, Index); + if StartPos < 0 then + Result := 0 + else + Result := SendMessageW(Handle, EM_LINELENGTH, StartPos, 0); +end; + +function TTntMemoStrings.Get(Index: Integer): WideString; +var + Len: Integer; +begin + if (not IsWindowUnicode(FMemo.Handle)) then + Result := FMemoLines[Index] + else begin + SetLength(Result, TntMemo_LineLength(FMemo.Handle, Index)); + if Length(Result) > 0 then begin + if Length(Result) > High(Word) then + raise EOutOfResources.Create(SOutlineLongLine); + Word((PWideChar(Result))^) := Length(Result); + Len := SendMessageW(FMemo.Handle, EM_GETLINE, Index, Longint(PWideChar(Result))); + SetLength(Result, Len); + end; + end; +end; + +procedure TTntMemoStrings.Put(Index: Integer; const S: WideString); +var + StartPos: Integer; +begin + if (not IsWindowUnicode(FMemo.Handle)) then + FMemoLines[Index] := S + else begin + StartPos := TntMemo_LineStart(FMemo.Handle, Index); + if StartPos >= 0 then + begin + SendMessageW(FMemo.Handle, EM_SETSEL, StartPos, StartPos + TntMemo_LineLength(FMemo.Handle, Index)); + SendMessageW(FMemo.Handle, EM_REPLACESEL, 0, Longint(PWideChar(S))); + end; + end; +end; + +procedure TTntMemoStrings.Insert(Index: Integer; const S: Widestring); + + function RichEditSelStartW: Integer; + var + CharRange: TCharRange; + begin + SendMessageW(FMemo.Handle, EM_EXGETSEL, 0, Longint(@CharRange)); + Result := CharRange.cpMin; + end; + +var + StartPos, LineLen: Integer; + Line: WideString; +begin + if (not IsWindowUnicode(FMemo.Handle)) then + FMemoLines.Insert(Index, S) + else begin + if Index >= 0 then + begin + StartPos := TntMemo_LineStart(FMemo.Handle, Index); + if StartPos >= 0 then + Line := S + CRLF + else begin + StartPos := TntMemo_LineStart(FMemo.Handle, Index - 1); + LineLen := TntMemo_LineLength(FMemo.Handle, Index - 1); + if LineLen = 0 then + Exit; + Inc(StartPos, LineLen); + Line := CRLF + s; + end; + SendMessageW(FMemo.Handle, EM_SETSEL, StartPos, StartPos); + + if (FRichEditMode) + and (FLineBreakStyle <> tlbsCRLF) then begin + Line := TntAdjustLineBreaks(Line, FLineBreakStyle); + if Line = CR then + Line := CRLF; { This helps a ReadOnly RichEdit 4.1 control to insert a blank line. } + SendMessageW(FMemo.Handle, EM_REPLACESEL, 0, Longint(PWideChar(Line))); + if Line = CRLF then + Line := CR; + end else + SendMessageW(FMemo.Handle, EM_REPLACESEL, 0, Longint(PWideChar(Line))); + + if (FRichEditMode) + and (RichEditSelStartW <> (StartPos + Length(Line))) then + raise EOutOfResources.Create(sRichEditInsertError); + end; + end; +end; + +procedure TTntMemoStrings.Delete(Index: Integer); +begin + FMemoLines.Delete(Index); +end; + +procedure TTntMemoStrings.Clear; +begin + FMemoLines.Clear; +end; + +type TAccessStrings = class(TStrings{TNT-ALLOW TStrings}); + +procedure TTntMemoStrings.SetUpdateState(Updating: Boolean); +begin + TAccessStrings(FMemoLines).SetUpdateState(Updating); +end; + +function TTntMemoStrings.GetTextStr: WideString; +begin + if (not FRichEditMode) then + Result := TntControl_GetText(FMemo) + else + Result := inherited GetTextStr; +end; + +procedure TTntMemoStrings.SetTextStr(const Value: WideString); +var + NewText: WideString; +begin + NewText := TntAdjustLineBreaks(Value, FLineBreakStyle); + if NewText <> GetTextStr then begin + FMemo.HandleNeeded; + TntControl_SetText(FMemo, NewText); + end; +end; + +{ TTntCustomMemo } + +constructor TTntCustomMemo.Create(AOwner: TComponent); +begin + inherited; + FLines := TTntMemoStrings.Create; + TTntMemoStrings(FLines).FMemo := Self; + TTntMemoStrings(FLines).FMemoLines := TCustomMemo{TNT-ALLOW TCustomMemo}(Self).Lines; +end; + +destructor TTntCustomMemo.Destroy; +begin + FreeAndNil(FLines); + inherited; +end; + +procedure TTntCustomMemo.SetLines(const Value: TTntStrings); +begin + FLines.Assign(Value); +end; + +procedure TTntCustomMemo.CreateWindowHandle(const Params: TCreateParams); +begin + TntCustomEdit_CreateWindowHandle(Self, Params); +end; + +procedure TTntCustomMemo.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomMemo.GetSelStart: Integer; +begin + Result := TntCustomEdit_GetSelStart(Self); +end; + +procedure TTntCustomMemo.SetSelStart(const Value: Integer); +begin + TntCustomEdit_SetSelStart(Self, Value); +end; + +function TTntCustomMemo.GetSelLength: Integer; +begin + Result := TntCustomEdit_GetSelLength(Self); +end; + +procedure TTntCustomMemo.SetSelLength(const Value: Integer); +begin + TntCustomEdit_SetSelLength(Self, Value); +end; + +function TTntCustomMemo.GetSelText: WideString; +begin + Result := TntCustomEdit_GetSelText(Self); +end; + +procedure TTntCustomMemo.SetSelText(const Value: WideString); +begin + TntCustomEdit_SetSelText(Self, Value); +end; + +function TTntCustomMemo.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomMemo.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +function TTntCustomMemo.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomMemo.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomMemo.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomMemo.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomMemo.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{$IFDEF DELPHI_7} // fix for Delphi 7 only +function TD7PatchedComboBoxStrings.Get(Index: Integer): string{TNT-ALLOW string}; +var + Len: Integer; +begin + Len := SendMessage(ComboBox.Handle, CB_GETLBTEXTLEN, Index, 0); + if Len > 0 then + begin + SetLength(Result, Len); + SendMessage(ComboBox.Handle, CB_GETLBTEXT, Index, Longint(PChar{TNT-ALLOW PChar}(Result))); + end + else + SetLength(Result, 0); +end; + +function TD7PatchedComboBoxStrings.Add(const S: string{TNT-ALLOW string}): Integer; +begin + Result := SendMessage(ComboBox.Handle, CB_ADDSTRING, 0, Longint(PChar{TNT-ALLOW PChar}(S))); + if Result < 0 then + raise EOutOfResources.Create(SInsertLineError); +end; + +procedure TD7PatchedComboBoxStrings.Insert(Index: Integer; const S: string{TNT-ALLOW string}); +begin + if SendMessage(ComboBox.Handle, CB_INSERTSTRING, Index, + Longint(PChar{TNT-ALLOW PChar}(S))) < 0 then + raise EOutOfResources.Create(SInsertLineError); +end; +{$ENDIF} + +{ TTntComboBoxStrings } + +function TTntComboBoxStrings.GetCount: Integer; +begin + Result := ComboBox.Items.Count; +end; + +function TTntComboBoxStrings.Get(Index: Integer): WideString; +var + Len: Integer; +begin + if (not IsWindowUnicode(ComboBox.Handle)) then + Result := ComboBox.Items[Index] + else begin + Len := SendMessageW(ComboBox.Handle, CB_GETLBTEXTLEN, Index, 0); + if Len = CB_ERR then + Result := '' + else begin + SetLength(Result, Len + 1); + Len := SendMessageW(ComboBox.Handle, CB_GETLBTEXT, Index, Longint(PWideChar(Result))); + if Len = CB_ERR then + Result := '' + else + Result := PWideChar(Result); + end; + end; +end; + +function TTntComboBoxStrings.GetObject(Index: Integer): TObject; +begin + Result := ComboBox.Items.Objects[Index]; +end; + +procedure TTntComboBoxStrings.PutObject(Index: Integer; AObject: TObject); +begin + ComboBox.Items.Objects[Index] := AObject; +end; + +function TTntComboBoxStrings.Add(const S: WideString): Integer; +begin + if (not IsWindowUnicode(ComboBox.Handle)) then + Result := ComboBox.Items.Add(S) + else begin + Result := SendMessageW(ComboBox.Handle, CB_ADDSTRING, 0, Longint(PWideChar(S))); + if Result < 0 then + raise EOutOfResources.Create(SInsertLineError); + end; +end; + +procedure TTntComboBoxStrings.Insert(Index: Integer; const S: WideString); +begin + if (not IsWindowUnicode(ComboBox.Handle)) then + ComboBox.Items.Insert(Index, S) + else begin + if SendMessageW(ComboBox.Handle, CB_INSERTSTRING, Index, Longint(PWideChar(S))) < 0 then + raise EOutOfResources.Create(SInsertLineError); + end; +end; + +procedure TTntComboBoxStrings.Delete(Index: Integer); +begin + ComboBox.Items.Delete(Index); +end; + +procedure TTntComboBoxStrings.Clear; +var + S: WideString; +begin + S := TntControl_GetText(ComboBox); + SendMessage(ComboBox.Handle, CB_RESETCONTENT, 0, 0); + TntControl_SetText(ComboBox, S); + ComboBox.Update; +end; + +procedure TTntComboBoxStrings.SetUpdateState(Updating: Boolean); +begin + TAccessStrings(ComboBox.Items).SetUpdateState(Updating); +end; + +function TTntComboBoxStrings.IndexOf(const S: WideString): Integer; +begin + if (not IsWindowUnicode(ComboBox.Handle)) then + Result := ComboBox.Items.IndexOf(S) + else + Result := SendMessageW(ComboBox.Handle, CB_FINDSTRINGEXACT, -1, LongInt(PWideChar(S))); +end; + +{ TTntCustomComboBox } + +type TAccessCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}); + +procedure TntCombo_AfterInherited_CreateWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var FSaveItems: TTntStrings; FSaveItemIndex: integer; PreInheritedAnsiText: AnsiString); +begin + if (not Win32PlatformIsUnicode) then begin + TAccessCustomComboBox(Combo).Text := PreInheritedAnsiText; + end else begin + with TAccessCustomComboBox(Combo) do + begin + if ListHandle <> 0 then begin + // re-extract FDefListProc as a Unicode proc + SetWindowLongA(ListHandle, GWL_WNDPROC, Integer(FDefListProc)); + FDefListProc := Pointer(GetWindowLongW(ListHandle, GWL_WNDPROC)); + // override with FListInstance as a Unicode proc + SetWindowLongW(ListHandle, GWL_WNDPROC, Integer(FListInstance)); + end; + SetWindowLongW(EditHandle, GWL_WNDPROC, GetWindowLong(EditHandle, GWL_WNDPROC)); + end; + if FSaveItems <> nil then + begin + Items.Assign(FSaveItems); + FreeAndNil(FSaveItems); + if FSaveItemIndex <> -1 then + begin + if Items.Count < FSaveItemIndex then FSaveItemIndex := Items.Count; + SendMessage(Combo.Handle, CB_SETCURSEL, FSaveItemIndex, 0); + end; + end; + TntControl_SetText(Combo, TntControl_GetStoredText(Combo, TAccessCustomComboBox(Combo).Text)); + end; +end; + +procedure TntCombo_BeforeInherited_DestroyWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var FSaveItems: TTntStrings; ItemIndex: integer; var FSaveItemIndex: integer; + var SavedText: WideString); +begin + Assert(not (csDestroyingHandle in Combo.ControlState)); + if (Win32PlatformIsUnicode) then begin + SavedText := TntControl_GetText(Combo); + if (Items.Count > 0) then + begin + FSaveItems := TTntStringList.Create; + FSaveItems.Assign(Items); + FSaveItemIndex:= ItemIndex; + Items.Clear; { This keeps TCustomComboBox from creating its own FSaveItems. (this kills the original ItemIndex) } + end; + end; +end; + +function TntCombo_ComboWndProc(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer; DoEditCharMsg: TWMCharMsgHandler): Boolean; + + procedure CallDefaultWindowProc; + begin + with Message do begin { call default wnd proc } + if IsWindowUnicode(ComboWnd) then + Result := CallWindowProcW(ComboProc, ComboWnd, Msg, WParam, LParam) + else + Result := CallWindowProcA(ComboProc, ComboWnd, Msg, WParam, LParam); + end; + end; + + function DoWideKeyPress(Message: TWMChar): Boolean; + begin + DoEditCharMsg(Message); + Result := (Message.CharCode = 0); + end; + +begin + Result := False; + try + if (Message.Msg = WM_CHAR) then begin + // WM_CHAR + Result := True; + if IsWindowUnicode(ComboWnd) then + MakeWMCharMsgSafeForAnsi(Message); + try + if TAccessCustomComboBox(Combo).DoKeyPress(TWMKey(Message)) then Exit; + if DoWideKeyPress(TWMKey(Message)) then Exit; + finally + if IsWindowUnicode(ComboWnd) then + RestoreWMCharMsg(Message); + end; + with TWMKey(Message) do begin + if ((CharCode = VK_RETURN) or (CharCode = VK_ESCAPE)) and Combo.DroppedDown then begin + Combo.DroppedDown := False; + Exit; + end; + end; + CallDefaultWindowProc; + end else if (IsWindowUnicode(ComboWnd)) then begin + // UNICODE + if IsTextMessage(Message.Msg) + or (Message.Msg = EM_REPLACESEL) + or (Message.Msg = WM_IME_COMPOSITION) + then begin + // message w/ text parameter + Result := True; + CallDefaultWindowProc; + end else if (Message.Msg = WM_IME_CHAR) then begin + // WM_IME_CHAR + Result := True; + with Message do { convert to WM_CHAR } + Result := SendMessageW(ComboWnd, WM_CHAR, WParam, LParam); + end; + end; + except + Application.HandleException(Combo); + end; +end; + +function TntCombo_CNCommand(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; Items: TTntStrings; var Message: TWMCommand): Boolean; +begin + Result := False; + if Message.NotifyCode = CBN_SELCHANGE then begin + Result := True; + TntControl_SetText(Combo, Items[Combo.ItemIndex]); + TAccessCustomComboBox(Combo).Click; + TAccessCustomComboBox(Combo).Select; + end; +end; + +function TntCombo_GetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; +begin + if Win32PlatformIsUnicode then + Result := Combo.SelStart + else + Result := Length(WideString(Copy(TAccessCustomComboBox(Combo).Text, 1, Combo.SelStart))); +end; + +procedure TntCombo_SetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); +begin + if Win32PlatformIsUnicode then + Combo.SelStart := Value + else + Combo.SelStart := Length(AnsiString(Copy(TntControl_GetText(Combo), 1, Value))); +end; + +function TntCombo_GetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; +begin + if Win32PlatformIsUnicode then + Result := Combo.SelLength + else + Result := Length(TntCombo_GetSelText(Combo)); +end; + +procedure TntCombo_SetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); +var + StartPos: Integer; +begin + if Win32PlatformIsUnicode then + Combo.SelLength := Value + else begin + StartPos := TntCombo_GetSelStart(Combo); + Combo.SelLength := Length(AnsiString(Copy(TntControl_GetText(Combo), StartPos + 1, Value))); + end; +end; + +function TntCombo_GetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): WideString; +begin + if Win32PlatformIsUnicode then begin + Result := ''; + if TAccessCustomComboBox(Combo).Style < csDropDownList then + Result := Copy(TntControl_GetText(Combo), Combo.SelStart + 1, Combo.SelLength); + end else + Result := Combo.SelText +end; + +procedure TntCombo_SetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: WideString); +begin + if Win32PlatformIsUnicode then begin + if TAccessCustomComboBox(Combo).Style < csDropDownList then + begin + Combo.HandleNeeded; + SendMessageW(TAccessCustomComboBox(Combo).EditHandle, EM_REPLACESEL, 0, Longint(PWideChar(Value))); + end; + end else + Combo.SelText := Value +end; + +procedure TntCombo_BeforeKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); +begin + SaveAutoComplete := TAccessCustomComboBox(Combo).AutoComplete; + TAccessCustomComboBox(Combo).AutoComplete := False; +end; + +procedure TntCombo_AfterKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); +begin + TAccessCustomComboBox(Combo).AutoComplete := SaveAutoComplete; +end; + +procedure TntCombo_DropDown_PreserveSelection(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}); +var + OldSelStart, OldSelLength: Integer; + OldText: WideString; +begin + OldText := TntControl_GetText(Combo); + OldSelStart := TntCombo_GetSelStart(Combo); + OldSelLength := TntCombo_GetSelLength(Combo); + Combo.DroppedDown := True; + TntControl_SetText(Combo, OldText); + TntCombo_SetSelStart(Combo, OldSelStart); + TntCombo_SetSelLength(Combo ,OldSelLength); +end; + +procedure TntComboBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); +begin + Items.AddObject(Item, AObject); +end; + +procedure TntComboBox_CopySelection(Items: TTntStrings; ItemIndex: Integer; + Destination: TCustomListControl); +begin + if ItemIndex <> -1 then + WideListControl_AddItem(Destination, Items[ItemIndex], Items.Objects[ItemIndex]); +end; + +function TntCombo_FindString(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + StartPos: Integer; const Text: WideString): Integer; +var + ComboFindString: ITntComboFindString; +begin + if Combo.GetInterface(ITntComboFindString, ComboFindString) then + Result := ComboFindString.FindString(Text, StartPos) + else if IsWindowUnicode(Combo.Handle) then + Result := SendMessageW(Combo.Handle, CB_FINDSTRING, StartPos, Integer(PWideChar(Text))) + else + Result := SendMessageA(Combo.Handle, CB_FINDSTRING, StartPos, Integer(PAnsiChar(AnsiString(Text)))) +end; + +function TntCombo_FindUniqueString(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + StartPos: Integer; const Text: WideString): Integer; +var + Match_1, Match_2: Integer; +begin + Result := CB_ERR; + Match_1 := TntCombo_FindString(Combo, -1, Text); + if Match_1 <> CB_ERR then begin + Match_2 := TntCombo_FindString(Combo, Match_1, Text); + if Match_2 = Match_1 then + Result := Match_1; + end; +end; + +function TntCombo_AutoSelect(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; Items: TTntStrings; + const SearchText: WideString; UniqueMatchOnly: Boolean; UseDataEntryCase: Boolean): Boolean; +var + Idx: Integer; + ValueChange: Boolean; +begin + if UniqueMatchOnly then + Idx := TntCombo_FindUniqueString(Combo, -1, SearchText) + else + Idx := TntCombo_FindString(Combo, -1, SearchText); + Result := (Idx <> CB_ERR); + if Result then begin + if TAccessCustomComboBox(Combo).Style = csDropDown then + ValueChange := not WideSameStr(TntControl_GetText(Combo), Items[Idx]) + else + ValueChange := Idx <> Combo.ItemIndex; + {$IFDEF COMPILER_7_UP} + // auto-closeup + if Combo.AutoCloseUp and (Items.IndexOf(SearchText) <> -1) then + Combo.DroppedDown := False; + {$ENDIF} + // select item + Combo.ItemIndex := Idx; + // update edit + if (TAccessCustomComboBox(Combo).Style in [csDropDown, csSimple]) then begin + if UseDataEntryCase then begin + // preserve case of characters as they are entered + TntControl_SetText(Combo, SearchText + Copy(Items[Combo.ItemIndex], Length(SearchText) + 1, MaxInt)); + end else begin + TntControl_SetText(Combo, Items[Idx]); + end; + // select the rest of the string + TntCombo_SetSelStart(Combo, Length(SearchText)); + TntCombo_SetSelLength(Combo, Length(TntControl_GetText(Combo)) - TntCombo_GetSelStart(Combo)); + end; + // notify events + if ValueChange then begin + TAccessCustomComboBox(Combo).Click; + TAccessCustomComboBox(Combo).Select; + end; + end; +end; + +procedure TntCombo_AutoSearchKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var Message: TWMChar; var FFilter: WideString; var FLastTime: Cardinal); +var + Key: WideChar; +begin + if TAccessCustomComboBox(Combo).Style in [csSimple, csDropDown] then + exit; + if not Combo.AutoComplete then + exit; + Key := GetWideCharFromWMCharMsg(Message); + try + case Ord(Key) of + VK_ESCAPE: + exit; + VK_TAB: + if Combo.AutoDropDown and Combo.DroppedDown then + Combo.DroppedDown := False; + VK_BACK: + Delete(FFilter, Length(FFilter), 1); + else begin + if Combo.AutoDropDown and (not Combo.DroppedDown) then + Combo.DroppedDown := True; + // reset FFilter if it's been too long (1.25 sec) { Windows XP is actually 2 seconds! } + if GetTickCount - FLastTime >= 1250 then + FFilter := ''; + FLastTime := GetTickCount; + // if AutoSelect works, remember new FFilter + if TntCombo_AutoSelect(Combo, Items, FFilter + Key, False, True) then begin + FFilter := FFilter + Key; + Key := #0; + end; + end; + end; + finally + SetWideCharForWMCharMsg(Message, Key); + end; +end; + +procedure TntCombo_AutoCompleteKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var Message: TWMChar; + AutoComplete_UniqueMatchOnly, AutoComplete_PreserveDataEntryCase: Boolean); +var + Key: WideChar; + FindText: WideString; +begin + Assert(TAccessCustomComboBox(Combo).Style in [csSimple, csDropDown], 'Internal Error: TntCombo_AutoCompleteKeyPress is only for csSimple and csDropDown style combo boxes.'); + if not Combo.AutoComplete then exit; + Key := GetWideCharFromWMCharMsg(Message); + try + case Ord(Key) of + VK_ESCAPE: + exit; + VK_TAB: + if Combo.AutoDropDown and Combo.DroppedDown then + Combo.DroppedDown := False; + VK_BACK: + exit; + else begin + if Combo.AutoDropDown and (not Combo.DroppedDown) then + TntCombo_DropDown_PreserveSelection(Combo); + // AutoComplete only if the selection is at the very end + if ((TntCombo_GetSelStart(Combo) + TntCombo_GetSelLength(Combo)) + = Length(TntControl_GetText(Combo))) then + begin + FindText := Copy(TntControl_GetText(Combo), 1, TntCombo_GetSelStart(Combo)) + Key; + if TntCombo_AutoSelect(Combo, Items, FindText, AutoComplete_UniqueMatchOnly, AutoComplete_PreserveDataEntryCase) then + begin + Key := #0; + end; + end; + end; + end; + finally + SetWideCharForWMCharMsg(Message, Key); + end; +end; + +//-- +constructor TTntCustomComboBox.Create(AOwner: TComponent); +begin + inherited; + FItems := TTntComboBoxStrings.Create; + TTntComboBoxStrings(FItems).ComboBox := Self; +end; + +destructor TTntCustomComboBox.Destroy; +begin + FreeAndNil(FItems); + FreeAndNil(FSaveItems); + inherited; +end; + +procedure TTntCustomComboBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'COMBOBOX'); +end; + +procedure TTntCustomComboBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomComboBox.CreateWnd; +var + PreInheritedAnsiText: AnsiString; +begin + PreInheritedAnsiText := TAccessCustomComboBox(Self).Text; + inherited; + TntCombo_AfterInherited_CreateWnd(Self, Items, FSaveItems, FSaveItemIndex, PreInheritedAnsiText); +end; + +procedure TTntCustomComboBox.DestroyWnd; +var + SavedText: WideString; +begin + if not (csDestroyingHandle in ControlState) then begin { avoid recursion when parent is TToolBar and system font changes. } + TntCombo_BeforeInherited_DestroyWnd(Self, Items, FSaveItems, ItemIndex, FSaveItemIndex, SavedText); + inherited; + TntControl_SetStoredText(Self, SavedText); + end; +end; + +procedure TTntCustomComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); +begin + if not TntCombo_ComboWndProc(Self, Message, ComboWnd, ComboProc, DoEditCharMsg) then + inherited; +end; + +procedure TTntCustomComboBox.KeyPress(var Key: AnsiChar); +var + SaveAutoComplete: Boolean; +begin + TntCombo_BeforeKeyPress(Self, SaveAutoComplete); + try + inherited; + finally + TntCombo_AfterKeyPress(Self, SaveAutoComplete); + end; +end; + +procedure TTntCustomComboBox.DoEditCharMsg(var Message: TWMChar); +begin + TntCombo_AutoCompleteKeyPress(Self, Items, Message, + GetAutoComplete_UniqueMatchOnly, GetAutoComplete_PreserveDataEntryCase); +end; + +procedure TTntCustomComboBox.WMChar(var Message: TWMChar); +begin + TntCombo_AutoSearchKeyPress(Self, Items, Message, FFilter, FLastTime); + if Message.CharCode <> 0 then + inherited; +end; + +procedure TntCombo_DefaultDrawItem(Canvas: TCanvas; Index: Integer; Rect: TRect; + State: TOwnerDrawState; Items: TTntStrings); +begin + Canvas.FillRect(Rect); + if Index >= 0 then + WideCanvasTextOut(Canvas, Rect.Left + 2, Rect.Top, Items[Index]); +end; + +procedure TTntCustomComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); +begin + TControlCanvas(Canvas).UpdateTextFlags; + if Assigned(OnDrawItem) then + OnDrawItem(Self, Index, Rect, State) + else + TntCombo_DefaultDrawItem(Canvas, Index, Rect, State, Items); +end; + +function TTntCustomComboBox.GetItems: TTntStrings; +begin + Result := FItems; +end; + +procedure TTntCustomComboBox.SetItems(const Value: TTntStrings); +begin + FItems.Assign(Value); +end; + +function TTntCustomComboBox.GetSelStart: Integer; +begin + Result := TntCombo_GetSelStart(Self); +end; + +procedure TTntCustomComboBox.SetSelStart(const Value: Integer); +begin + TntCombo_SetSelStart(Self, Value); +end; + +function TTntCustomComboBox.GetSelLength: Integer; +begin + Result := TntCombo_GetSelLength(Self); +end; + +procedure TTntCustomComboBox.SetSelLength(const Value: Integer); +begin + TntCombo_SetSelLength(Self, Value); +end; + +function TTntCustomComboBox.GetSelText: WideString; +begin + Result := TntCombo_GetSelText(Self); +end; + +procedure TTntCustomComboBox.SetSelText(const Value: WideString); +begin + TntCombo_SetSelText(Self, Value); +end; + +function TTntCustomComboBox.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomComboBox.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomComboBox.CNCommand(var Message: TWMCommand); +begin + if not TntCombo_CNCommand(Self, Items, Message) then + inherited; +end; + +function TTntCustomComboBox.GetAutoComplete_PreserveDataEntryCase: Boolean; +begin + Result := True; +end; + +function TTntCustomComboBox.GetAutoComplete_UniqueMatchOnly: Boolean; +begin + Result := False; +end; + +function TTntCustomComboBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomComboBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomComboBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomComboBox.AddItem(const Item: WideString; AObject: TObject); +begin + TntComboBox_AddItem(Items, Item, AObject); +end; + +procedure TTntCustomComboBox.CopySelection(Destination: TCustomListControl); +begin + TntComboBox_CopySelection(Items, ItemIndex, Destination); +end; + +procedure TTntCustomComboBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomComboBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{$IFDEF DELPHI_7} // fix for Delphi 7 only +function TTntCustomComboBox.GetItemsClass: TCustomComboBoxStringsClass; +begin + Result := TD7PatchedComboBoxStrings; +end; +{$ENDIF} + +{ TTntListBoxStrings } + +function TTntListBoxStrings.GetListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; +begin + Result := TCustomListBox{TNT-ALLOW TCustomListBox}(FListBox); +end; + +procedure TTntListBoxStrings.SetListBox(const Value: TCustomListBox{TNT-ALLOW TCustomListBox}); +begin + FListBox := TAccessCustomListBox(Value); +end; + +function TTntListBoxStrings.GetCount: Integer; +begin + Result := ListBox.Items.Count; +end; + +function TTntListBoxStrings.Get(Index: Integer): WideString; +var + Len: Integer; +begin + if (not IsWindowUnicode(ListBox.Handle)) then + Result := ListBox.Items[Index] + else begin + Len := SendMessageW(ListBox.Handle, LB_GETTEXTLEN, Index, 0); + if Len = LB_ERR then + Error(SListIndexError, Index) + else begin + SetLength(Result, Len + 1); + Len := SendMessageW(ListBox.Handle, LB_GETTEXT, Index, Longint(PWideChar(Result))); + if Len = LB_ERR then + Result := '' + else + Result := PWideChar(Result); + end; + end; +end; + +function TTntListBoxStrings.GetObject(Index: Integer): TObject; +begin + Result := ListBox.Items.Objects[Index]; +end; + +procedure TTntListBoxStrings.Put(Index: Integer; const S: WideString); +var + I: Integer; + TempData: Longint; +begin + I := ListBox.ItemIndex; + TempData := FListBox.InternalGetItemData(Index); + // Set the Item to 0 in case it is an object that gets freed during Delete + FListBox.InternalSetItemData(Index, 0); + Delete(Index); + InsertObject(Index, S, nil); + FListBox.InternalSetItemData(Index, TempData); + ListBox.ItemIndex := I; +end; + +procedure TTntListBoxStrings.PutObject(Index: Integer; AObject: TObject); +begin + ListBox.Items.Objects[Index] := AObject; +end; + +function TTntListBoxStrings.Add(const S: WideString): Integer; +begin + if (not IsWindowUnicode(ListBox.Handle)) then + Result := ListBox.Items.Add(S) + else begin + Result := SendMessageW(ListBox.Handle, LB_ADDSTRING, 0, Longint(PWideChar(S))); + if Result < 0 then + raise EOutOfResources.Create(SInsertLineError); + end; +end; + +procedure TTntListBoxStrings.Insert(Index: Integer; const S: WideString); +begin + if (not IsWindowUnicode(ListBox.Handle)) then + ListBox.Items.Insert(Index, S) + else begin + if SendMessageW(ListBox.Handle, LB_INSERTSTRING, Index, Longint(PWideChar(S))) < 0 then + raise EOutOfResources.Create(SInsertLineError); + end; +end; + +procedure TTntListBoxStrings.Delete(Index: Integer); +begin + FListBox.DeleteString(Index); +end; + +procedure TTntListBoxStrings.Exchange(Index1, Index2: Integer); +var + TempData: Longint; + TempString: WideString; +begin + BeginUpdate; + try + TempString := Strings[Index1]; + TempData := FListBox.InternalGetItemData(Index1); + Strings[Index1] := Strings[Index2]; + FListBox.InternalSetItemData(Index1, FListBox.InternalGetItemData(Index2)); + Strings[Index2] := TempString; + FListBox.InternalSetItemData(Index2, TempData); + if ListBox.ItemIndex = Index1 then + ListBox.ItemIndex := Index2 + else if ListBox.ItemIndex = Index2 then + ListBox.ItemIndex := Index1; + finally + EndUpdate; + end; +end; + +procedure TTntListBoxStrings.Clear; +begin + FListBox.ResetContent; +end; + +procedure TTntListBoxStrings.SetUpdateState(Updating: Boolean); +begin + TAccessStrings(ListBox.Items).SetUpdateState(Updating); +end; + +function TTntListBoxStrings.IndexOf(const S: WideString): Integer; +begin + if (not IsWindowUnicode(ListBox.Handle)) then + Result := ListBox.Items.IndexOf(S) + else + Result := SendMessageW(ListBox.Handle, LB_FINDSTRINGEXACT, -1, LongInt(PWideChar(S))); +end; + +procedure TTntListBoxStrings.Move(CurIndex, NewIndex: Integer); +var + TempData: Longint; + TempString: WideString; +begin + BeginUpdate; + FListBox.FMoving := True; + try + if CurIndex <> NewIndex then + begin + TempString := Get(CurIndex); + TempData := FListBox.InternalGetItemData(CurIndex); + FListBox.InternalSetItemData(CurIndex, 0); + Delete(CurIndex); + Insert(NewIndex, TempString); + FListBox.InternalSetItemData(NewIndex, TempData); + end; + finally + FListBox.FMoving := False; + EndUpdate; + end; +end; + +//-- list box helper procs + +procedure TntListBox_AfterInherited_CreateWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + var FSaveItems: TTntStrings; FItems: TTntStrings; FSaveTopIndex, FSaveItemIndex: Integer); +begin + if FSaveItems <> nil then + begin + FItems.Assign(FSaveItems); + FreeAndNil(FSaveItems); + ListBox.TopIndex := FSaveTopIndex; + ListBox.ItemIndex := FSaveItemIndex; + end; +end; + +procedure TntListBox_BeforeInherited_DestroyWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + var FSaveItems: TTntStrings; const FItems: TTntStrings; var FSaveTopIndex, FSaveItemIndex: Integer); +begin + if (FItems.Count > 0) + and (not (TAccessCustomListBox(ListBox).Style in [lbVirtual, lbVirtualOwnerDraw])) + then begin + FSaveItems := TTntStringList.Create; + FSaveItems.Assign(FItems); + FSaveTopIndex := ListBox.TopIndex; + FSaveItemIndex := ListBox.ItemIndex; + ListBox.Items.Clear; { This keeps TCustomListBox from creating its own FSaveItems. (this kills the original ItemIndex) } + end; +end; + +procedure TntListBox_DrawItem_Text(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; Items: TTntStrings; Index: Integer; Rect: TRect); +var + Flags: Integer; + Canvas: TCanvas; +begin + Canvas := TAccessCustomListBox(ListBox).Canvas; + Canvas.FillRect(Rect); + if Index < Items.Count then + begin + Flags := ListBox.DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX); + if not ListBox.UseRightToLeftAlignment then + Inc(Rect.Left, 2) + else + Dec(Rect.Right, 2); + Tnt_DrawTextW(Canvas.Handle, PWideChar(Items[Index]), Length(Items[Index]), Rect, Flags); + end; +end; + +procedure TntListBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); +begin + Items.AddObject(PWideChar(Item), AObject); +end; + +procedure TntListBox_CopySelection(ListBox: TCustomListbox{TNT-ALLOW TCustomListbox}; + Items: TTntStrings; Destination: TCustomListControl); +var + I: Integer; +begin + if ListBox.MultiSelect then + begin + for I := 0 to Items.Count - 1 do + if ListBox.Selected[I] then + WideListControl_AddItem(Destination, PWideChar(Items[I]), Items.Objects[I]); + end + else + if Listbox.ItemIndex <> -1 then + WideListControl_AddItem(Destination, PWideChar(Items[ListBox.ItemIndex]), Items.Objects[ListBox.ItemIndex]); +end; + +function TntCustomListBox_GetOwnerData(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; Index: Integer; out Data: WideString): Boolean; +var + AnsiData: AnsiString; +begin + Result := False; + Data := ''; + if (Index > -1) and (Index < ListBox.Count) then begin + if Assigned(OnData) then begin + OnData(ListBox, Index, Data); + Result := True; + end else if Assigned(TAccessCustomListBox(ListBox).OnData) then begin + AnsiData := ''; + TAccessCustomListBox(ListBox).OnData(ListBox, Index, AnsiData); + Data := AnsiData; + Result := True; + end; + end; +end; + +function TntCustomListBox_LBGetText(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; +var + S: WideString; + AnsiS: AnsiString; +begin + if TAccessCustomListBox(ListBox).Style in [lbVirtual, lbVirtualOwnerDraw] then + begin + Result := True; + if TntCustomListBox_GetOwnerData(ListBox, OnData, Message.WParam, S) then begin + if Win32PlatformIsUnicode then begin + WStrCopy(PWideChar(Message.LParam), PWideChar(S)); + Message.Result := Length(S); + end else begin + AnsiS := S; + StrCopy{TNT-ALLOW StrCopy}(PAnsiChar(Message.LParam), PAnsiChar(AnsiS)); + Message.Result := Length(AnsiS); + end; + end + else + Message.Result := LB_ERR; + end + else + Result := False; +end; + +function TntCustomListBox_LBGetTextLen(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; +var + S: WideString; +begin + if TAccessCustomListBox(ListBox).Style in [lbVirtual, lbVirtualOwnerDraw] then + begin + Result := True; + if TntCustomListBox_GetOwnerData(ListBox, OnData, Message.WParam, S) then begin + if Win32PlatformIsUnicode then + Message.Result := Length(S) + else + Message.Result := Length(AnsiString(S)); + end else + Message.Result := LB_ERR; + end + else + Result := False; +end; + +{ TTntCustomListBox } + +constructor TTntCustomListBox.Create(AOwner: TComponent); +begin + inherited; + FItems := TTntListBoxStrings.Create; + TTntListBoxStrings(FItems).ListBox := Self; +end; + +destructor TTntCustomListBox.Destroy; +begin + FreeAndNil(FItems); + FreeAndNil(FSaveItems); + inherited; +end; + +procedure TTntCustomListBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'LISTBOX'); +end; + +procedure TTntCustomListBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomListBox.CreateWnd; +begin + inherited; + TntListBox_AfterInherited_CreateWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); +end; + +procedure TTntCustomListBox.DestroyWnd; +begin + TntListBox_BeforeInherited_DestroyWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); + inherited; +end; + +procedure TTntCustomListBox.SetItems(const Value: TTntStrings); +begin + FItems.Assign(Value); +end; + +procedure TTntCustomListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); +begin + if Assigned(OnDrawItem) then + OnDrawItem(Self, Index, Rect, State) + else + TntListBox_DrawItem_Text(Self, Items, Index, Rect); +end; + +function TTntCustomListBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomListBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomListBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomListBox.AddItem(const Item: WideString; AObject: TObject); +begin + TntListBox_AddItem(Items, Item, AObject); +end; + +procedure TTntCustomListBox.CopySelection(Destination: TCustomListControl); +begin + TntListBox_CopySelection(Self, Items, Destination); +end; + +procedure TTntCustomListBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomListBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntCustomListBox.LBGetText(var Message: TMessage); +begin + if not TntCustomListBox_LBGetText(Self, OnData, Message) then + inherited; +end; + +procedure TTntCustomListBox.LBGetTextLen(var Message: TMessage); +begin + if not TntCustomListBox_LBGetTextLen(Self, OnData, Message) then + inherited; +end; + +// --- label helper procs + +type TAccessCustomLabel = class(TCustomLabel{TNT-ALLOW TCustomLabel}); + +function TntLabel_DoDrawText(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Rect: TRect; Flags: Integer; const GetLabelText: WideString): Boolean; +{$IFDEF COMPILER_9_UP} +const + EllipsisStr = '...'; + Ellipsis: array[TEllipsisPosition] of Longint = (0, DT_PATH_ELLIPSIS, + DT_END_ELLIPSIS, DT_WORD_ELLIPSIS); +{$ENDIF} +var + Text: WideString; + ShowAccelChar: Boolean; + Canvas: TCanvas; + {$IFDEF COMPILER_9_UP} + DText: WideString; + NewRect: TRect; + Height: Integer; + Delim: Integer; + {$ENDIF} +begin + Result := False; + if Win32PlatformIsUnicode then begin + Result := True; + Text := GetLabelText; + ShowAccelChar := TAccessCustomLabel(Control).ShowAccelChar; + Canvas := Control.Canvas; + if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and + (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' '; + if not ShowAccelChar then Flags := Flags or DT_NOPREFIX; + Flags := Control.DrawTextBiDiModeFlags(Flags); + Canvas.Font := TAccessCustomLabel(Control).Font; + {$IFDEF COMPILER_9_UP} + if (TAccessCustomLabel(Control).EllipsisPosition <> epNone) + and (not TAccessCustomLabel(Control).AutoSize) then + begin + DText := Text; + Flags := Flags and not (DT_EXPANDTABS or DT_CALCRECT); + Flags := Flags or Ellipsis[TAccessCustomLabel(Control).EllipsisPosition]; + if TAccessCustomLabel(Control).WordWrap + and (TAccessCustomLabel(Control).EllipsisPosition in [epEndEllipsis, epWordEllipsis]) then + begin + repeat + NewRect := Rect; + Dec(NewRect.Right, WideCanvasTextWidth(Canvas, EllipsisStr)); + Tnt_DrawTextW(Canvas.Handle, PWideChar(DText), Length(DText), NewRect, Flags or DT_CALCRECT); + Height := NewRect.Bottom - NewRect.Top; + if (Height > TAccessCustomLabel(Control).ClientHeight) + and (Height > Canvas.Font.Height) then + begin + Delim := WideLastDelimiter(' '#9, Text); + if Delim = 0 then + Delim := Length(Text); + Dec(Delim); + Text := Copy(Text, 1, Delim); + DText := Text + EllipsisStr; + if Text = '' then + Break; + end else + Break; + until False; + end; + if Text <> '' then + Text := DText; + end; + {$ENDIF} + if not Control.Enabled then + begin + OffsetRect(Rect, 1, 1); + Canvas.Font.Color := clBtnHighlight; + Tnt_DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Flags); + OffsetRect(Rect, -1, -1); + Canvas.Font.Color := clBtnShadow; + Tnt_DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Flags); + end + else + Tnt_DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Flags); + end; +end; + +procedure TntLabel_CMDialogChar(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Message: TCMDialogChar; const Caption: WideString); +var + FocusControl: TWinControl; + ShowAccelChar: Boolean; +begin + FocusControl := TAccessCustomLabel(Control).FocusControl; + ShowAccelChar := TAccessCustomLabel(Control).ShowAccelChar; + if (FocusControl <> nil) and Control.Enabled and ShowAccelChar and + IsWideCharAccel(Message.CharCode, Caption) then + with FocusControl do + if CanFocus then + begin + SetFocus; + Message.Result := 1; + end; +end; + +{ TTntCustomLabel } + +procedure TTntCustomLabel.CMDialogChar(var Message: TCMDialogChar); +begin + TntLabel_CMDialogChar(Self, Message, Caption); +end; + +function TTntCustomLabel.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntCustomLabel.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomLabel.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomLabel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomLabel.GetLabelText: WideString; +begin + Result := Caption; +end; + +procedure TTntCustomLabel.DoDrawText(var Rect: TRect; Flags: Integer); +begin + if not TntLabel_DoDrawText(Self, Rect, Flags, GetLabelText) then + inherited; +end; + +function TTntCustomLabel.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomLabel.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomLabel.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomLabel.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntCustomLabel.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomLabel.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntButton } + +procedure TntButton_CMDialogChar(Button: TButton{TNT-ALLOW TButton}; var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(Message.CharCode, TntControl_GetText(Button)) + and Button.CanFocus then + begin + Button.Click; + Result := 1; + end else + Button.Broadcast(Message); +end; + +procedure TTntButton.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntButton.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntButton.CMDialogChar(var Message: TCMDialogChar); +begin + TntButton_CMDialogChar(Self, Message); +end; + +function TTntButton.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntButton.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntButton.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntButton.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntButton.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntButton.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntButton.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomCheckBox } + +procedure TTntCustomCheckBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntCustomCheckBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomCheckBox.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(Message.CharCode, Caption) + and CanFocus then + begin + SetFocus; + if Focused then Toggle; + Result := 1; + end else + Broadcast(Message); +end; + +function TTntCustomCheckBox.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntCustomCheckBox.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomCheckBox.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntCustomCheckBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomCheckBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomCheckBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomCheckBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomCheckBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntRadioButton } + +procedure TTntRadioButton.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntRadioButton.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntRadioButton.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(Message.CharCode, Caption) + and CanFocus then + begin + SetFocus; + Result := 1; + end else + Broadcast(Message); +end; + +function TTntRadioButton.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntRadioButton.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntRadioButton.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntRadioButton.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntRadioButton.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntRadioButton.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntRadioButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntRadioButton.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntScrollBar } + +procedure TTntScrollBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'SCROLLBAR'); +end; + +procedure TTntScrollBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntScrollBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntScrollBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntScrollBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntScrollBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntScrollBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomGroupBox } + +procedure TTntCustomGroupBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomGroupBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomGroupBox.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(Message.CharCode, Caption) + and CanFocus then + begin + SelectFirst; + Result := 1; + end else + Broadcast(Message); +end; + +function TTntCustomGroupBox.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntCustomGroupBox.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomGroupBox.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomGroupBox.Paint; + + {$IFDEF THEME_7_UP} + procedure PaintThemedGroupBox; + var + CaptionRect: TRect; + OuterRect: TRect; + Size: TSize; + Box: TThemedButton; + Details: TThemedElementDetails; + begin + with Canvas do begin + if Caption <> '' then + begin + GetTextExtentPoint32W(Handle, PWideChar(Caption), Length(Caption), Size); + CaptionRect := Rect(0, 0, Size.cx, Size.cy); + if not UseRightToLeftAlignment then + OffsetRect(CaptionRect, 8, 0) + else + OffsetRect(CaptionRect, Width - 8 - CaptionRect.Right, 0); + end + else + CaptionRect := Rect(0, 0, 0, 0); + + OuterRect := ClientRect; + OuterRect.Top := (CaptionRect.Bottom - CaptionRect.Top) div 2; + with CaptionRect do + ExcludeClipRect(Handle, Left, Top, Right, Bottom); + if Enabled then + Box := tbGroupBoxNormal + else + Box := tbGroupBoxDisabled; + Details := ThemeServices.GetElementDetails(Box); + ThemeServices.DrawElement(Handle, Details, OuterRect); + + SelectClipRgn(Handle, 0); + if Text <> '' then + ThemeServices.DrawText{TNT-ALLOW DrawText}(Handle, Details, Caption, CaptionRect, DT_LEFT, 0); + end; + end; + {$ENDIF} + + procedure PaintGroupBox; + var + H: Integer; + R: TRect; + Flags: Longint; + begin + with Canvas do begin + H := WideCanvasTextHeight(Canvas, '0'); + R := Rect(0, H div 2 - 1, Width, Height); + if Ctl3D then + begin + Inc(R.Left); + Inc(R.Top); + Brush.Color := clBtnHighlight; + FrameRect(R); + OffsetRect(R, -1, -1); + Brush.Color := clBtnShadow; + end else + Brush.Color := clWindowFrame; + FrameRect(R); + if Caption <> '' then + begin + if not UseRightToLeftAlignment then + R := Rect(8, 0, 0, H) + else + R := Rect(R.Right - WideCanvasTextWidth(Canvas, Caption) - 8, 0, 0, H); + Flags := DrawTextBiDiModeFlags(DT_SINGLELINE); + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), R, Flags or DT_CALCRECT); + Brush.Color := Color; + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), R, Flags); + end; + end; + end; + +begin + if (not Win32PlatformIsUnicode) then + inherited + else + begin + Canvas.Font := Self.Font; + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled then + PaintThemedGroupBox + else + PaintGroupBox; + {$ELSE} + PaintGroupBox; + {$ENDIF} + end; +end; + +function TTntCustomGroupBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomGroupBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomGroupBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomGroupBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomGroupBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomStaticText } + +constructor TTntCustomStaticText.Create(AOwner: TComponent); +begin + inherited; + AdjustBounds; +end; + +procedure TTntCustomStaticText.CMFontChanged(var Message: TMessage); +begin + inherited; + AdjustBounds; +end; + +procedure TTntCustomStaticText.CMTextChanged(var Message: TMessage); +begin + inherited; + AdjustBounds; +end; + +procedure TTntCustomStaticText.Loaded; +begin + inherited; + AdjustBounds; +end; + +procedure TTntCustomStaticText.SetAutoSize(AValue: boolean); +begin + inherited; + if AValue then + AdjustBounds; +end; + +procedure TTntCustomStaticText.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'STATIC'); +end; + +procedure TTntCustomStaticText.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomStaticText.CMDialogChar(var Message: TCMDialogChar); +begin + if (FocusControl <> nil) and Enabled and ShowAccelChar and + IsWideCharAccel(Message.CharCode, Caption) then + with FocusControl do + if CanFocus then + begin + SetFocus; + Message.Result := 1; + end; +end; + +function TTntCustomStaticText.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +procedure TTntCustomStaticText.AdjustBounds; +var + DC: HDC; + SaveFont: HFont; + TextSize: TSize; +begin + if not (csReading in ComponentState) and AutoSize then + begin + DC := GetDC(0); + SaveFont := SelectObject(DC, Font.Handle); + GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), TextSize); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + SetBounds(Left, Top, + TextSize.cx + (GetSystemMetrics(SM_CXBORDER) * 4), + TextSize.cy + (GetSystemMetrics(SM_CYBORDER) * 4)); + end; +end; + +function TTntCustomStaticText.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomStaticText.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntCustomStaticText.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomStaticText.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomStaticText.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomStaticText.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomStaticText.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas new file mode 100644 index 0000000000..f6cd3e2ebb --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas @@ -0,0 +1,1699 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntSysUtils; + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: Consider: more filename functions from SysUtils } +{ TODO: Consider: string functions from StrUtils. } + +uses + Types, SysUtils, Windows; + +//--------------------------------------------------------------------------------------------- +// Tnt - Types +//--------------------------------------------------------------------------------------------- + +// ......... introduced ......... +type + // The user of the application did something plainly wrong. + ETntUserError = class(Exception); + // A general error occured. (ie. file didn't exist, server didn't return data, etc.) + ETntGeneralError = class(Exception); + // Like Assert(). An error occured that should never have happened, send me a bug report now! + ETntInternalError = class(Exception); + +//--------------------------------------------------------------------------------------------- +// Tnt - SysUtils +//--------------------------------------------------------------------------------------------- + +// ......... SBCS and MBCS functions with WideString replacements in SysUtils.pas ......... + +{TNT-WARN CompareStr} {TNT-WARN AnsiCompareStr} +{TNT-WARN SameStr} {TNT-WARN AnsiSameStr} +{TNT-WARN SameText} {TNT-WARN AnsiSameText} +{TNT-WARN CompareText} {TNT-WARN AnsiCompareText} +{TNT-WARN UpperCase} {TNT-WARN AnsiUpperCase} +{TNT-WARN LowerCase} {TNT-WARN AnsiLowerCase} + +{TNT-WARN AnsiPos} { --> Pos() supports WideString. } +{TNT-WARN FmtStr} +{TNT-WARN Format} +{TNT-WARN FormatBuf} + +// ......... MBCS Byte Type Procs ......... + +{TNT-WARN ByteType} +{TNT-WARN StrByteType} +{TNT-WARN ByteToCharIndex} +{TNT-WARN ByteToCharLen} +{TNT-WARN CharToByteIndex} +{TNT-WARN CharToByteLen} + +// ........ null-terminated string functions ......... + +{TNT-WARN StrEnd} +{TNT-WARN StrLen} +{TNT-WARN StrLCopy} +{TNT-WARN StrCopy} +{TNT-WARN StrECopy} +{TNT-WARN StrPLCopy} +{TNT-WARN StrPCopy} +{TNT-WARN StrLComp} +{TNT-WARN AnsiStrLComp} +{TNT-WARN StrComp} +{TNT-WARN AnsiStrComp} +{TNT-WARN StrLIComp} +{TNT-WARN AnsiStrLIComp} +{TNT-WARN StrIComp} +{TNT-WARN AnsiStrIComp} +{TNT-WARN StrLower} +{TNT-WARN AnsiStrLower} +{TNT-WARN StrUpper} +{TNT-WARN AnsiStrUpper} +{TNT-WARN StrPos} +{TNT-WARN AnsiStrPos} +{TNT-WARN StrScan} +{TNT-WARN AnsiStrScan} +{TNT-WARN StrRScan} +{TNT-WARN AnsiStrRScan} +{TNT-WARN StrLCat} +{TNT-WARN StrCat} +{TNT-WARN StrMove} +{TNT-WARN StrPas} +{TNT-WARN StrAlloc} +{TNT-WARN StrBufSize} +{TNT-WARN StrNew} +{TNT-WARN StrDispose} + +{TNT-WARN AnsiExtractQuotedStr} +{TNT-WARN AnsiLastChar} +{TNT-WARN AnsiStrLastChar} +{TNT-WARN QuotedStr} +{TNT-WARN AnsiQuotedStr} +{TNT-WARN AnsiDequotedStr} + +// ........ string functions ......... + +{$IFNDEF COMPILER_9_UP} + // + // pre-Delphi 9 issues w/ WideFormatBuf, WideFmtStr and WideFormat + // + + {$IFDEF COMPILER_7_UP} + type + PFormatSettings = ^TFormatSettings; + {$ENDIF} + + // SysUtils.WideFormatBuf doesn't correctly handle numeric specifiers. + function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const): Cardinal; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} + + {$IFDEF COMPILER_7_UP} + function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; overload; + {$ENDIF} + + // SysUtils.WideFmtStr doesn't handle string lengths > 4096. + procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const); {$IFDEF COMPILER_7_UP} overload; {$ENDIF} + + {$IFDEF COMPILER_7_UP} + procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const; const FormatSettings: TFormatSettings); overload; + {$ENDIF} + + {---------------------------------------------------------------------------------------- + Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... + TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); + will fix WideFormat as well as WideFmtStr. + ----------------------------------------------------------------------------------------} + function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} + + {$IFDEF COMPILER_7_UP} + function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; + const FormatSettings: TFormatSettings): WideString; overload; + {$ENDIF} + +{$ENDIF} + +{TNT-WARN WideUpperCase} // SysUtils.WideUpperCase is broken on Win9x for D6, D7, D9. +function Tnt_WideUpperCase(const S: WideString): WideString; +{TNT-WARN WideLowerCase} // SysUtils.WideLowerCase is broken on Win9x for D6, D7, D9. +function Tnt_WideLowerCase(const S: WideString): WideString; + +function TntWideLastChar(const S: WideString): WideChar; + +{TNT-WARN StringReplace} +{TNT-WARN WideStringReplace} // <-- WideStrUtils.WideStringReplace uses SysUtils.WideUpperCase which is broken on Win9x. +function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; + Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; + +{TNT-WARN AdjustLineBreaks} +type TTntTextLineBreakStyle = (tlbsLF, tlbsCRLF, tlbsCR); +function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; +function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; + +{TNT-WARN WrapText} +function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; + MaxCol: Integer): WideString; overload; +function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; overload; + +// ........ filename manipulation ......... + +{TNT-WARN SameFileName} // doesn't apply to Unicode filenames, use WideSameText +{TNT-WARN AnsiCompareFileName} // doesn't apply to Unicode filenames, use WideCompareText +{TNT-WARN AnsiLowerCaseFileName} // doesn't apply to Unicode filenames, use WideLowerCase +{TNT-WARN AnsiUpperCaseFileName} // doesn't apply to Unicode filenames, use WideUpperCase + +{TNT-WARN IncludeTrailingBackslash} +function WideIncludeTrailingBackslash(const S: WideString): WideString; +{TNT-WARN IncludeTrailingPathDelimiter} +function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; +{TNT-WARN ExcludeTrailingBackslash} +function WideExcludeTrailingBackslash(const S: WideString): WideString; +{TNT-WARN ExcludeTrailingPathDelimiter} +function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; +{TNT-WARN IsDelimiter} +function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; +{TNT-WARN IsPathDelimiter} +function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; +{TNT-WARN LastDelimiter} +function WideLastDelimiter(const Delimiters, S: WideString): Integer; +{TNT-WARN ChangeFileExt} +function WideChangeFileExt(const FileName, Extension: WideString): WideString; +{TNT-WARN ExtractFilePath} +function WideExtractFilePath(const FileName: WideString): WideString; +{TNT-WARN ExtractFileDir} +function WideExtractFileDir(const FileName: WideString): WideString; +{TNT-WARN ExtractFileDrive} +function WideExtractFileDrive(const FileName: WideString): WideString; +{TNT-WARN ExtractFileName} +function WideExtractFileName(const FileName: WideString): WideString; +{TNT-WARN ExtractFileExt} +function WideExtractFileExt(const FileName: WideString): WideString; +{TNT-WARN ExtractRelativePath} +function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; + +// ........ file management routines ......... + +{TNT-WARN ExpandFileName} +function WideExpandFileName(const FileName: WideString): WideString; +{TNT-WARN ExtractShortPathName} +function WideExtractShortPathName(const FileName: WideString): WideString; +{TNT-WARN FileCreate} +function WideFileCreate(const FileName: WideString): Integer; +{TNT-WARN FileOpen} +function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; +{TNT-WARN FileAge} +function WideFileAge(const FileName: WideString): Integer; overload; +function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; overload; +{TNT-WARN DirectoryExists} +function WideDirectoryExists(const Name: WideString): Boolean; +{TNT-WARN FileExists} +function WideFileExists(const Name: WideString): Boolean; +{TNT-WARN FileGetAttr} +function WideFileGetAttr(const FileName: WideString): Cardinal; +{TNT-WARN FileSetAttr} +function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; +{TNT-WARN FileIsReadOnly} +function WideFileIsReadOnly(const FileName: WideString): Boolean; +{TNT-WARN FileSetReadOnly} +function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; +{TNT-WARN ForceDirectories} +function WideForceDirectories(Dir: WideString): Boolean; +{TNT-WARN FileSearch} +function WideFileSearch(const Name, DirList: WideString): WideString; +{TNT-WARN RenameFile} +function WideRenameFile(const OldName, NewName: WideString): Boolean; +{TNT-WARN DeleteFile} +function WideDeleteFile(const FileName: WideString): Boolean; +{TNT-WARN CopyFile} +function WideCopyFile(FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; + + +{TNT-WARN TFileName} +type + TWideFileName = type WideString; + +{TNT-WARN TSearchRec} // <-- FindFile - warning on TSearchRec is all that is necessary +type + TSearchRecW = record + Time: Integer; + Size: Int64; + Attr: Integer; + Name: TWideFileName; + ExcludeAttr: Integer; + FindHandle: THandle; + FindData: TWin32FindDataW; + end; +function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; +function WideFindNext(var F: TSearchRecW): Integer; +procedure WideFindClose(var F: TSearchRecW); + +{TNT-WARN CreateDir} +function WideCreateDir(const Dir: WideString): Boolean; +{TNT-WARN RemoveDir} +function WideRemoveDir(const Dir: WideString): Boolean; +{TNT-WARN GetCurrentDir} +function WideGetCurrentDir: WideString; +{TNT-WARN SetCurrentDir} +function WideSetCurrentDir(const Dir: WideString): Boolean; + + +// ........ date/time functions ......... + +{TNT-WARN TryStrToDateTime} +function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; +{TNT-WARN TryStrToDate} +function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; +{TNT-WARN TryStrToTime} +function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; + +{ introduced } +function ValidDateTimeStr(Str: WideString): Boolean; +function ValidDateStr(Str: WideString): Boolean; +function ValidTimeStr(Str: WideString): Boolean; + +{TNT-WARN StrToDateTime} +function TntStrToDateTime(Str: WideString): TDateTime; +{TNT-WARN StrToDate} +function TntStrToDate(Str: WideString): TDateTime; +{TNT-WARN StrToTime} +function TntStrToTime(Str: WideString): TDateTime; +{TNT-WARN StrToDateTimeDef} +function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; +{TNT-WARN StrToDateDef} +function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; +{TNT-WARN StrToTimeDef} +function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; + +{TNT-WARN CurrToStr} +{TNT-WARN CurrToStrF} +function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; +{TNT-WARN StrToCurr} +function TntStrToCurr(const S: WideString): Currency; +{TNT-WARN StrToCurrDef} +function ValidCurrencyStr(const S: WideString): Boolean; +function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; +function GetDefaultCurrencyFmt: TCurrencyFmtW; + +// ........ misc functions ......... + +{TNT-WARN GetLocaleStr} +function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; +{TNT-WARN SysErrorMessage} +function WideSysErrorMessage(ErrorCode: Integer): WideString; + +// ......... introduced ......... + +function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; + +const + CR = WideChar(#13); + LF = WideChar(#10); + CRLF = WideString(#13#10); + WideLineSeparator = WideChar($2028); + +var + Win32PlatformIsUnicode: Boolean; + Win32PlatformIsXP: Boolean; + Win32PlatformIs2003: Boolean; + Win32PlatformIsVista: Boolean; + +{$IFNDEF COMPILER_7_UP} +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; +{$ENDIF} +function WinCheckH(RetVal: Cardinal): Cardinal; +function WinCheckFileH(RetVal: Cardinal): Cardinal; +function WinCheckP(RetVal: Pointer): Pointer; + +function WideGetModuleFileName(Instance: HModule): WideString; +function WideSafeLoadLibrary(const Filename: Widestring; + ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; +function WideLoadPackage(const Name: Widestring): HMODULE; + +function IsWideCharUpper(WC: WideChar): Boolean; +function IsWideCharLower(WC: WideChar): Boolean; +function IsWideCharDigit(WC: WideChar): Boolean; +function IsWideCharSpace(WC: WideChar): Boolean; +function IsWideCharPunct(WC: WideChar): Boolean; +function IsWideCharCntrl(WC: WideChar): Boolean; +function IsWideCharBlank(WC: WideChar): Boolean; +function IsWideCharXDigit(WC: WideChar): Boolean; +function IsWideCharAlpha(WC: WideChar): Boolean; +function IsWideCharAlphaNumeric(WC: WideChar): Boolean; + +function WideTextPos(const SubStr, S: WideString): Integer; + +function ExtractStringArrayStr(P: PWideChar): WideString; +function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; +function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; + +function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; +function IsWideStringMappableToAnsi(const WS: WideString): Boolean; +function IsRTF(const Value: WideString): Boolean; + +function ENG_US_FloatToStr(Value: Extended): WideString; +function ENG_US_StrToFloat(const S: WideString): Extended; + +//--------------------------------------------------------------------------------------------- +// Tnt - Variants +//--------------------------------------------------------------------------------------------- + +// ........ Variants.pas has WideString versions of these functions ......... +{TNT-WARN VarToStr} +{TNT-WARN VarToStrDef} + +var + _SettingChangeTime: Cardinal; + +implementation + +uses + ActiveX, ComObj, SysConst, + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils, + TntSystem, TntWindows, TntFormatStrUtils; + +//--------------------------------------------------------------------------------------------- +// Tnt - SysUtils +//--------------------------------------------------------------------------------------------- + +{$IFNDEF COMPILER_9_UP} + + function _Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const + {$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings {$ENDIF}): Cardinal; + var + OldFormat: WideString; + NewFormat: WideString; + begin + SetString(OldFormat, PWideChar(@FormatStr), FmtLen); + { The reason for this is that WideFormat doesn't correctly format floating point specifiers. + See QC#4254. } + NewFormat := ReplaceFloatingArgumentsInFormatString(OldFormat, Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); + {$IFDEF COMPILER_7_UP} + if FormatSettings <> nil then + Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, + Length(NewFormat), Args, FormatSettings^) + else + {$ENDIF} + Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, + Length(NewFormat), Args); + end; + + function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const): Cardinal; + begin + Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); + end; + + {$IFDEF COMPILER_7_UP} + function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; + FmtLen: Cardinal; const Args: array of const; const FormatSettings: TFormatSettings): Cardinal; + begin + Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args, @FormatSettings); + end; + {$ENDIF} + + procedure _Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const{$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings{$ENDIF}); + var + Len, BufLen: Integer; + Buffer: array[0..4095] of WideChar; + begin + BufLen := Length(Buffer); // Fixes buffer overwrite issue. (See QC #4703, #4744) + if Length(FormatStr) < (Length(Buffer) - (Length(Buffer) div 4)) then + Len := _Tnt_WideFormatBuf(Buffer, Length(Buffer) - 1, Pointer(FormatStr)^, + Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}) + else + begin + BufLen := Length(FormatStr); + Len := BufLen; + end; + if Len >= BufLen - 1 then + begin + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := _Tnt_WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(FormatStr)^, + Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); + end; + SetLength(Result, Len); + end + else + SetString(Result, Buffer, Len); + end; + + procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const); + begin + _Tnt_WideFmtStr(Result, FormatStr, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); + end; + + {$IFDEF COMPILER_7_UP} + procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; + const Args: array of const; const FormatSettings: TFormatSettings); + begin + _Tnt_WideFmtStr(Result, FormatStr, Args, @FormatSettings); + end; + {$ENDIF} + + {---------------------------------------------------------------------------------------- + Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... + TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); + will fix WideFormat as well as WideFmtStr. + ----------------------------------------------------------------------------------------} + function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; + begin + Tnt_WideFmtStr(Result, FormatStr, Args); + end; + + {$IFDEF COMPILER_7_UP} + function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; + const FormatSettings: TFormatSettings): WideString; + begin + Tnt_WideFmtStr(Result, FormatStr, Args, FormatSettings); + end; + {$ENDIF} + +{$ENDIF} + +function Tnt_WideUpperCase(const S: WideString): WideString; +begin + {$IFNDEF COMPILER_10_UP} + { SysUtils.WideUpperCase is broken for Win9x. } + Result := S; + if Length(Result) > 0 then + Tnt_CharUpperBuffW(PWideChar(Result), Length(Result)); + {$ELSE} + Result := SysUtils.WideUpperCase{TNT-ALLOW WideUpperCase}(S); + {$ENDIF} +end; + +function Tnt_WideLowerCase(const S: WideString): WideString; +begin + {$IFNDEF COMPILER_10_UP} + { SysUtils.WideLowerCase is broken for Win9x. } + Result := S; + if Length(Result) > 0 then + Tnt_CharLowerBuffW(PWideChar(Result), Length(Result)); + {$ELSE} + Result := SysUtils.WideLowerCase{TNT-ALLOW WideLowerCase}(S); + {$ENDIF} +end; + +function TntWideLastChar(const S: WideString): WideChar; +var + P: PWideChar; +begin + P := WideLastChar(S); + if P = nil then + Result := #0 + else + Result := P^; +end; + +function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; + Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; + + function IsWordSeparator(WC: WideChar): Boolean; + begin + Result := (WC = WideChar(#0)) + or IsWideCharSpace(WC) + or IsWideCharPunct(WC); + end; + +var + SearchStr, Patt, NewStr: WideString; + Offset: Integer; + PrevChar, NextChar: WideChar; +begin + if rfIgnoreCase in Flags then + begin + SearchStr := Tnt_WideUpperCase(S); + Patt := Tnt_WideUpperCase(OldPattern); + end else + begin + SearchStr := S; + Patt := OldPattern; + end; + NewStr := S; + Result := ''; + while SearchStr <> '' do + begin + Offset := Pos(Patt, SearchStr); + if Offset = 0 then + begin + Result := Result + NewStr; + Break; + end; // done + + if (WholeWord) then + begin + if (Offset = 1) then + PrevChar := TntWideLastChar(Result) + else + PrevChar := NewStr[Offset - 1]; + + if Offset + Length(OldPattern) <= Length(NewStr) then + NextChar := NewStr[Offset + Length(OldPattern)] + else + NextChar := WideChar(#0); + + if (not IsWordSeparator(PrevChar)) + or (not IsWordSeparator(NextChar)) then + begin + Result := Result + Copy(NewStr, 1, Offset + Length(OldPattern) - 1); + NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); + SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); + continue; + end; + end; + + Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; + NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); + if not (rfReplaceAll in Flags) then + begin + Result := Result + NewStr; + Break; + end; + SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); + end; +end; + +function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; +var + Source, SourceEnd: PWideChar; +begin + Source := Pointer(S); + SourceEnd := Source + Length(S); + Result := Length(S); + while Source < SourceEnd do + begin + case Source^ of + #10, WideLineSeparator: + if Style = tlbsCRLF then + Inc(Result); + #13: + if Style = tlbsCRLF then + if Source[1] = #10 then + Inc(Source) + else + Inc(Result) + else + if Source[1] = #10 then + Dec(Result); + end; + Inc(Source); + end; +end; + +function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; +var + Source, SourceEnd, Dest: PWideChar; + DestLen: Integer; +begin + Source := Pointer(S); + SourceEnd := Source + Length(S); + DestLen := TntAdjustLineBreaksLength(S, Style); + SetString(Result, nil, DestLen); + Dest := Pointer(Result); + while Source < SourceEnd do begin + case Source^ of + #10, WideLineSeparator: + begin + if Style in [tlbsCRLF, tlbsCR] then + begin + Dest^ := #13; + Inc(Dest); + end; + if Style in [tlbsCRLF, tlbsLF] then + begin + Dest^ := #10; + Inc(Dest); + end; + Inc(Source); + end; + #13: + begin + if Style in [tlbsCRLF, tlbsCR] then + begin + Dest^ := #13; + Inc(Dest); + end; + if Style in [tlbsCRLF, tlbsLF] then + begin + Dest^ := #10; + Inc(Dest); + end; + Inc(Source); + if Source^ = #10 then Inc(Source); + end; + else + Dest^ := Source^; + Inc(Dest); + Inc(Source); + end; + end; +end; + +function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; + MaxCol: Integer): WideString; + + function WideCharIn(C: WideChar; SysCharSet: TSysCharSet): Boolean; + begin + Result := (C <= High(AnsiChar)) and (AnsiChar(C) in SysCharSet); + end; + +const + QuoteChars = ['''', '"']; +var + Col, Pos: Integer; + LinePos, LineLen: Integer; + BreakLen, BreakPos: Integer; + QuoteChar, CurChar: WideChar; + ExistingBreak: Boolean; +begin + Col := 1; + Pos := 1; + LinePos := 1; + BreakPos := 0; + QuoteChar := ' '; + ExistingBreak := False; + LineLen := Length(Line); + BreakLen := Length(BreakStr); + Result := ''; + while Pos <= LineLen do + begin + CurChar := Line[Pos]; + if CurChar = BreakStr[1] then + begin + if QuoteChar = ' ' then + begin + ExistingBreak := WideSameText(BreakStr, Copy(Line, Pos, BreakLen)); + if ExistingBreak then + begin + Inc(Pos, BreakLen-1); + BreakPos := Pos; + end; + end + end + else if WideCharIn(CurChar, BreakChars) then + begin + if QuoteChar = ' ' then BreakPos := Pos + end + else if WideCharIn(CurChar, QuoteChars) then + begin + if CurChar = QuoteChar then + QuoteChar := ' ' + else if QuoteChar = ' ' then + QuoteChar := CurChar; + end; + Inc(Pos); + Inc(Col); + if not (WideCharIn(QuoteChar, QuoteChars)) and (ExistingBreak or + ((Col > MaxCol) and (BreakPos > LinePos))) then + begin + Col := Pos - BreakPos; + Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1); + if not (WideCharIn(CurChar, QuoteChars)) then + while Pos <= LineLen do + begin + if WideCharIn(Line[Pos], BreakChars) then + Inc(Pos) + else if Copy(Line, Pos, Length(sLineBreak)) = sLineBreak then + Inc(Pos, Length(sLineBreak)) + else + break; + end; + if not ExistingBreak and (Pos < LineLen) then + Result := Result + BreakStr; + Inc(BreakPos); + LinePos := BreakPos; + ExistingBreak := False; + end; + end; + Result := Result + Copy(Line, LinePos, MaxInt); +end; + +function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; +begin + Result := WideWrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize } +end; + +function WideIncludeTrailingBackslash(const S: WideString): WideString; +begin + Result := WideIncludeTrailingPathDelimiter(S); +end; + +function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; +begin + Result := S; + if not WideIsPathDelimiter(Result, Length(Result)) then Result := Result + PathDelim; +end; + +function WideExcludeTrailingBackslash(const S: WideString): WideString; +begin + Result := WideExcludeTrailingPathDelimiter(S); +end; + +function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; +begin + Result := S; + if WideIsPathDelimiter(Result, Length(Result)) then + SetLength(Result, Length(Result)-1); +end; + +function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; +begin + Result := False; + if (Index <= 0) or (Index > Length(S)) then exit; + Result := WStrScan(PWideChar(Delimiters), S[Index]) <> nil; +end; + +function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; +begin + Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim); +end; + +function WideLastDelimiter(const Delimiters, S: WideString): Integer; +var + P: PWideChar; +begin + Result := Length(S); + P := PWideChar(Delimiters); + while Result > 0 do + begin + if (S[Result] <> #0) and (WStrScan(P, S[Result]) <> nil) then + Exit; + Dec(Result); + end; +end; + +function WideChangeFileExt(const FileName, Extension: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter('.\:',Filename); + if (I = 0) or (FileName[I] <> '.') then I := MaxInt; + Result := Copy(FileName, 1, I - 1) + Extension; +end; + +function WideExtractFilePath(const FileName: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter('\:', FileName); + Result := Copy(FileName, 1, I); +end; + +function WideExtractFileDir(const FileName: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter(DriveDelim + PathDelim,Filename); + if (I > 1) and (FileName[I] = PathDelim) and + (not (FileName[I - 1] in [WideChar(PathDelim), WideChar(DriveDelim)])) then Dec(I); + Result := Copy(FileName, 1, I); +end; + +function WideExtractFileDrive(const FileName: WideString): WideString; +var + I, J: Integer; +begin + if (Length(FileName) >= 2) and (FileName[2] = DriveDelim) then + Result := Copy(FileName, 1, 2) + else if (Length(FileName) >= 2) and (FileName[1] = PathDelim) and + (FileName[2] = PathDelim) then + begin + J := 0; + I := 3; + While (I < Length(FileName)) and (J < 2) do + begin + if FileName[I] = PathDelim then Inc(J); + if J < 2 then Inc(I); + end; + if FileName[I] = PathDelim then Dec(I); + Result := Copy(FileName, 1, I); + end else Result := ''; +end; + +function WideExtractFileName(const FileName: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter('\:', FileName); + Result := Copy(FileName, I + 1, MaxInt); +end; + +function WideExtractFileExt(const FileName: WideString): WideString; +var + I: Integer; +begin + I := WideLastDelimiter('.\:', FileName); + if (I > 0) and (FileName[I] = '.') then + Result := Copy(FileName, I, MaxInt) else + Result := ''; +end; + +function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; +var + BasePath, DestPath: WideString; + BaseLead, DestLead: PWideChar; + BasePtr, DestPtr: PWideChar; + + function WideExtractFilePathNoDrive(const FileName: WideString): WideString; + begin + Result := WideExtractFilePath(FileName); + Delete(Result, 1, Length(WideExtractFileDrive(FileName))); + end; + + function Next(var Lead: PWideChar): PWideChar; + begin + Result := Lead; + if Result = nil then Exit; + Lead := WStrScan(Lead, PathDelim); + if Lead <> nil then + begin + Lead^ := #0; + Inc(Lead); + end; + end; + +begin + if WideSameText(WideExtractFileDrive(BaseName), WideExtractFileDrive(DestName)) then + begin + BasePath := WideExtractFilePathNoDrive(BaseName); + DestPath := WideExtractFilePathNoDrive(DestName); + BaseLead := Pointer(BasePath); + BasePtr := Next(BaseLead); + DestLead := Pointer(DestPath); + DestPtr := Next(DestLead); + while (BasePtr <> nil) and (DestPtr <> nil) and WideSameText(BasePtr, DestPtr) do + begin + BasePtr := Next(BaseLead); + DestPtr := Next(DestLead); + end; + Result := ''; + while BaseLead <> nil do + begin + Result := Result + '..' + PathDelim; { Do not localize } + Next(BaseLead); + end; + if (DestPtr <> nil) and (DestPtr^ <> #0) then + Result := Result + DestPtr + PathDelim; + if DestLead <> nil then + Result := Result + DestLead; // destlead already has a trailing backslash + Result := Result + WideExtractFileName(DestName); + end + else + Result := DestName; +end; + +function WideExpandFileName(const FileName: WideString): WideString; +var + FName: PWideChar; + Buffer: array[0..MAX_PATH - 1] of WideChar; +begin + SetString(Result, Buffer, Tnt_GetFullPathNameW(PWideChar(FileName), MAX_PATH, Buffer, FName)); +end; + +function WideExtractShortPathName(const FileName: WideString): WideString; +var + Buffer: array[0..MAX_PATH - 1] of WideChar; +begin + SetString(Result, Buffer, Tnt_GetShortPathNameW(PWideChar(FileName), Buffer, MAX_PATH)); +end; + +function WideFileCreate(const FileName: WideString): Integer; +begin + Result := Integer(Tnt_CreateFileW(PWideChar(FileName), GENERIC_READ or GENERIC_WRITE, + 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)) +end; + +function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; +const + AccessMode: array[0..2] of LongWord = ( + GENERIC_READ, + GENERIC_WRITE, + GENERIC_READ or GENERIC_WRITE); + ShareMode: array[0..4] of LongWord = ( + 0, + 0, + FILE_SHARE_READ, + FILE_SHARE_WRITE, + FILE_SHARE_READ or FILE_SHARE_WRITE); +begin + Result := Integer(Tnt_CreateFileW(PWideChar(FileName), AccessMode[Mode and 3], + ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, 0)); +end; + +function WideFileAge(const FileName: WideString): Integer; +var + Handle: THandle; + FindData: TWin32FindDataW; + LocalFileTime: TFileTime; +begin + Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); + if Handle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(Handle); + if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then + begin + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, LongRec(Result).Lo) then + Exit + end; + end; + Result := -1; +end; + +function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; +var + Handle: THandle; + FindData: TWin32FindDataW; + LSystemTime: TSystemTime; + LocalFileTime: TFileTime; +begin + Result := False; + Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); + if Handle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(Handle); + if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then + begin + Result := True; + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + FileTimeToSystemTime(LocalFileTime, LSystemTime); + with LSystemTime do + FileDateTime := EncodeDate(wYear, wMonth, wDay) + + EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); + end; + end; +end; + +function WideDirectoryExists(const Name: WideString): Boolean; +var + Code: Cardinal; +begin + Code := WideFileGetAttr(Name); + Result := (Code <> INVALID_FILE_ATTRIBUTES) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); +end; + +function WideFileExists(const Name: WideString): Boolean; +var + Handle: THandle; + FindData: TWin32FindDataW; +begin + Result := False; + Handle := Tnt_FindFirstFileW(PWideChar(Name), FindData); + if Handle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(Handle); + if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then + Result := True; + end; +end; + +function WideFileGetAttr(const FileName: WideString): Cardinal; +begin + Result := Tnt_GetFileAttributesW(PWideChar(FileName)); +end; + +function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; +begin + Result := Tnt_SetFileAttributesW(PWideChar(FileName), Attr) +end; + +function WideFileIsReadOnly(const FileName: WideString): Boolean; +begin + Result := (Tnt_GetFileAttributesW(PWideChar(FileName)) and faReadOnly) <> 0; +end; + +function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; +var + Flags: Integer; +begin + Result := False; + Flags := Tnt_GetFileAttributesW(PWideChar(FileName)); + if Flags = -1 then Exit; + if ReadOnly then + Flags := Flags or faReadOnly + else + Flags := Flags and not faReadOnly; + Result := Tnt_SetFileAttributesW(PWideChar(FileName), Flags); +end; + +function WideForceDirectories(Dir: WideString): Boolean; +begin + Result := True; + if Length(Dir) = 0 then + raise ETntGeneralError.Create(SCannotCreateDir); + Dir := WideExcludeTrailingBackslash(Dir); + if (Length(Dir) < 3) or WideDirectoryExists(Dir) + or (WideExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. + Result := WideForceDirectories(WideExtractFilePath(Dir)); + if Result then + Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil) +end; + +function WideFileSearch(const Name, DirList: WideString): WideString; +var + I, P, L: Integer; + C: WideChar; +begin + Result := Name; + P := 1; + L := Length(DirList); + while True do + begin + if WideFileExists(Result) then Exit; + while (P <= L) and (DirList[P] = PathSep) do Inc(P); + if P > L then Break; + I := P; + while (P <= L) and (DirList[P] <> PathSep) do + Inc(P); + Result := Copy(DirList, I, P - I); + C := TntWideLastChar(Result); + if (C <> DriveDelim) and (C <> PathDelim) then + Result := Result + PathDelim; + Result := Result + Name; + end; + Result := ''; +end; + +function WideRenameFile(const OldName, NewName: WideString): Boolean; +begin + Result := Tnt_MoveFileW(PWideChar(OldName), PWideChar(NewName)) +end; + +function WideDeleteFile(const FileName: WideString): Boolean; +begin + Result := Tnt_DeleteFileW(PWideChar(FileName)) +end; + +function WideCopyFile(FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; +begin + Result := Tnt_CopyFileW(PWideChar(FromFile), PWideChar(ToFile), FailIfExists) +end; + +function _WideFindMatchingFile(var F: TSearchRecW): Integer; +var + LocalFileTime: TFileTime; +begin + with F do + begin + while FindData.dwFileAttributes and ExcludeAttr <> 0 do + if not Tnt_FindNextFileW(FindHandle, FindData) then + begin + Result := GetLastError; + Exit; + end; + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo); + Size := (Int64(FindData.nFileSizeHigh) shl 32) + FindData.nFileSizeLow; + Attr := FindData.dwFileAttributes; + Name := FindData.cFileName; + end; + Result := 0; +end; + +function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; +const + faSpecial = faHidden or faSysFile {$IFNDEF COMPILER_9_UP} or faVolumeID {$ENDIF} or faDirectory; +begin + F.ExcludeAttr := not Attr and faSpecial; + F.FindHandle := Tnt_FindFirstFileW(PWideChar(Path), F.FindData); + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Result := _WideFindMatchingFile(F); + if Result <> 0 then WideFindClose(F); + end else + Result := GetLastError; +end; + +function WideFindNext(var F: TSearchRecW): Integer; +begin + if Tnt_FindNextFileW(F.FindHandle, F.FindData) then + Result := _WideFindMatchingFile(F) else + Result := GetLastError; +end; + +procedure WideFindClose(var F: TSearchRecW); +begin + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(F.FindHandle); + F.FindHandle := INVALID_HANDLE_VALUE; + end; +end; + +function WideCreateDir(const Dir: WideString): Boolean; +begin + Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil); +end; + +function WideRemoveDir(const Dir: WideString): Boolean; +begin + Result := Tnt_RemoveDirectoryW(PWideChar(Dir)); +end; + +function WideGetCurrentDir: WideString; +begin + SetLength(Result, MAX_PATH); + Tnt_GetCurrentDirectoryW(MAX_PATH, PWideChar(Result)); + Result := PWideChar(Result); +end; + +function WideSetCurrentDir(const Dir: WideString): Boolean; +begin + Result := Tnt_SetCurrentDirectoryW(PWideChar(Dir)); +end; + +//============================================================================================= +//== DATE/TIME STRING PARSING ================================================================ +//============================================================================================= + +function _IntTryStrToDateTime(Str: WideString; Flags: Integer; out DateTime: TDateTime): HResult; +begin + Result := VarDateFromStr(Str, GetThreadLocale, Flags, Double(DateTime)); + if (not Succeeded(Result)) then begin + if (Flags = VAR_TIMEVALUEONLY) + and SysUtils.TryStrToTime{TNT-ALLOW TryStrToTime}(Str, DateTime) then + Result := S_OK // SysUtils seems confident (works for date = "dd.MM.yy" and time = "H.mm.ss") + else if (Flags = VAR_DATEVALUEONLY) + and SysUtils.TryStrToDate{TNT-ALLOW TryStrToDate}(Str, DateTime) then + Result := S_OK // SysUtils seems confident + else if (Flags = 0) + and SysUtils.TryStrToDateTime{TNT-ALLOW TryStrToDateTime}(Str, DateTime) then + Result := S_OK // SysUtils seems confident + end; +end; + +function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, 0, DateTime)); +end; + +function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, DateTime)); +end; + +function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, DateTime)); +end; + +function ValidDateTimeStr(Str: WideString): Boolean; +var + Temp: TDateTime; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, 0, Temp)); +end; + +function ValidDateStr(Str: WideString): Boolean; +var + Temp: TDateTime; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, Temp)); +end; + +function ValidTimeStr(Str: WideString): Boolean; +var + Temp: TDateTime; +begin + Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, Temp)); +end; + +function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; +begin + if not TntTryStrToDateTime(Str, Result) then + Result := Default; +end; + +function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; +begin + if not TntTryStrToDate(Str, Result) then + Result := Default; +end; + +function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; +begin + if not TntTryStrToTime(Str, Result) then + Result := Default; +end; + +function _IntStrToDateTime(Str: WideString; Flags: Integer; ErrorFormatStr: WideString): TDateTime; +begin + try + OleCheck(_IntTryStrToDateTime(Str, Flags, Result)); + except + on E: Exception do begin + E.Message := E.Message + CRLF + WideFormat(ErrorFormatStr, [Str]); + raise EConvertError.Create(E.Message); + end; + end; +end; + +function TntStrToDateTime(Str: WideString): TDateTime; +begin + Result := _IntStrToDateTime(Str, 0, SInvalidDateTime); +end; + +function TntStrToDate(Str: WideString): TDateTime; +begin + Result := _IntStrToDateTime(Str, VAR_DATEVALUEONLY, SInvalidDate); +end; + +function TntStrToTime(Str: WideString): TDateTime; +begin + Result := _IntStrToDateTime(Str, VAR_TIMEVALUEONLY, SInvalidTime); +end; + +//============================================================================================= +//== CURRENCY STRING PARSING ================================================================= +//============================================================================================= + +function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; +const + MAX_BUFF_SIZE = 64; // can a currency string actually be larger? +var + ValueStr: WideString; +begin + // format lpValue using ENG-US settings + ValueStr := ENG_US_FloatToStr(Value); + // get currency format + SetLength(Result, MAX_BUFF_SIZE); + if 0 = Tnt_GetCurrencyFormatW(GetThreadLocale, 0, PWideChar(ValueStr), + lpFormat, PWideChar(Result), Length(Result)) + then begin + RaiseLastOSError; + end; + Result := PWideChar(Result); +end; + +function TntStrToCurr(const S: WideString): Currency; +begin + try + OleCheck(VarCyFromStr(S, GetThreadLocale, 0, Result)); + except + on E: Exception do begin + E.Message := E.Message + CRLF + WideFormat(SInvalidCurrency, [S]); + raise EConvertError.Create(E.Message); + end; + end; +end; + +function ValidCurrencyStr(const S: WideString): Boolean; +var + Dummy: Currency; +begin + Result := Succeeded(VarCyFromStr(S, GetThreadLocale, 0, Dummy)); +end; + +function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; +begin + if not Succeeded(VarCyFromStr(S, GetThreadLocale, 0, Result)) then + Result := Default; +end; + +threadvar + Currency_DecimalSep: WideString; + Currency_ThousandSep: WideString; + Currency_CurrencySymbol: WideString; + +function GetDefaultCurrencyFmt: TCurrencyFmtW; +begin + ZeroMemory(@Result, SizeOf(Result)); + Result.NumDigits := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRDIGITS, '2'), 2); + Result.LeadingZero := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ILZERO, '1'), 1); + Result.Grouping := StrToIntDef(Copy(WideGetLocaleStr(GetThreadLocale, LOCALE_SMONGROUPING, '3;0'), 1, 1), 3); + Currency_DecimalSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONDECIMALSEP, '.'); + Result.lpDecimalSep := PWideChar(Currency_DecimalSep); + Currency_ThousandSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONTHOUSANDSEP, ','); + Result.lpThousandSep := PWideChar(Currency_ThousandSep); + Result.NegativeOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_INEGCURR, '0'), 0); + Result.PositiveOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRENCY, '0'), 0); + Currency_CurrencySymbol := WideGetLocaleStr(GetThreadLocale, LOCALE_SCURRENCY, ''); + Result.lpCurrencySymbol := PWideChar(Currency_CurrencySymbol); +end; + +//============================================================================================= + +function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; +var + L: Integer; +begin + if (not Win32PlatformIsUnicode) then + Result := GetLocaleStr{TNT-ALLOW GetLocaleStr}(LocaleID, LocaleType, Default) + else begin + SetLength(Result, 255); + L := GetLocaleInfoW(LocaleID, LocaleType, PWideChar(Result), Length(Result)); + if L > 0 then + SetLength(Result, L - 1) + else + Result := Default; + end; +end; + +function WideSysErrorMessage(ErrorCode: Integer): WideString; +begin + Result := WideLibraryErrorMessage('system', 0, ErrorCode); +end; + +function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; +var + Len: Integer; + AnsiResult: AnsiString; + Flags: Cardinal; +begin + Flags := FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY; + if Dll <> 0 then + Flags := Flags or FORMAT_MESSAGE_FROM_HMODULE; + if Win32PlatformIsUnicode then begin + SetLength(Result, 256); + Len := FormatMessageW(Flags, Pointer(Dll), ErrorCode, 0, PWideChar(Result), Length(Result), nil); + SetLength(Result, Len); + end else begin + SetLength(AnsiResult, 256); + Len := FormatMessageA(Flags, Pointer(Dll), ErrorCode, 0, PAnsiChar(AnsiResult), Length(AnsiResult), nil); + SetLength(AnsiResult, Len); + Result := AnsiResult; + end; + if Trim(Result) = '' then + Result := WideFormat('Unspecified error (%d) from %s.', [ErrorCode, LibName]); +end; + +{$IFNDEF COMPILER_7_UP} +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; +begin + Result := (Win32MajorVersion > AMajor) or + ((Win32MajorVersion = AMajor) and + (Win32MinorVersion >= AMinor)); +end; +{$ENDIF} + +function WinCheckH(RetVal: Cardinal): Cardinal; +begin + if RetVal = 0 then RaiseLastOSError; + Result := RetVal; +end; + +function WinCheckFileH(RetVal: Cardinal): Cardinal; +begin + if RetVal = INVALID_HANDLE_VALUE then RaiseLastOSError; + Result := RetVal; +end; + +function WinCheckP(RetVal: Pointer): Pointer; +begin + if RetVal = nil then RaiseLastOSError; + Result := RetVal; +end; + +function WideGetModuleFileName(Instance: HModule): WideString; +begin + SetLength(Result, MAX_PATH); + WinCheckH(Tnt_GetModuleFileNameW(Instance, PWideChar(Result), Length(Result))); + Result := PWideChar(Result) +end; + +function WideSafeLoadLibrary(const Filename: Widestring; ErrorMode: UINT): HMODULE; +var + OldMode: UINT; + FPUControlWord: Word; +begin + OldMode := SetErrorMode(ErrorMode); + try + asm + FNSTCW FPUControlWord + end; + try + Result := Tnt_LoadLibraryW(PWideChar(Filename)); + finally + asm + FNCLEX + FLDCW FPUControlWord + end; + end; + finally + SetErrorMode(OldMode); + end; +end; + +function WideLoadPackage(const Name: Widestring): HMODULE; +begin + Result := WideSafeLoadLibrary(Name); + if Result = 0 then + begin + raise EPackageError.CreateFmt(sErrorLoadingPackage, [Name, WideSysErrorMessage(GetLastError)]); + end; + try + InitializePackage(Result); + except + FreeLibrary(Result); + raise; + end; +end; + +function _WideCharType(WC: WideChar; dwInfoType: Cardinal): Word; +begin + Win32Check(Tnt_GetStringTypeExW(GetThreadLocale, dwInfoType, PWideChar(@WC), 1, Result)) +end; + +function IsWideCharUpper(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_UPPER) <> 0; +end; + +function IsWideCharLower(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_LOWER) <> 0; +end; + +function IsWideCharDigit(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_DIGIT) <> 0; +end; + +function IsWideCharSpace(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_SPACE) <> 0; +end; + +function IsWideCharPunct(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_PUNCT) <> 0; +end; + +function IsWideCharCntrl(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_CNTRL) <> 0; +end; + +function IsWideCharBlank(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_BLANK) <> 0; +end; + +function IsWideCharXDigit(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_XDIGIT) <> 0; +end; + +function IsWideCharAlpha(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and C1_ALPHA) <> 0; +end; + +function IsWideCharAlphaNumeric(WC: WideChar): Boolean; +begin + Result := (_WideCharType(WC, CT_CTYPE1) and (C1_ALPHA + C1_DIGIT)) <> 0; +end; + +function WideTextPos(const SubStr, S: WideString): Integer; +begin + Result := Pos(Tnt_WideUpperCase(SubStr), Tnt_WideUpperCase(S)); +end; + +function FindDoubleTerminator(P: PWideChar): PWideChar; +begin + Result := P; + while True do begin + Result := WStrScan(Result, #0); + Inc(Result); + if Result^ = #0 then begin + Dec(Result); + break; + end; + end; +end; + +function ExtractStringArrayStr(P: PWideChar): WideString; +var + PEnd: PWideChar; +begin + PEnd := FindDoubleTerminator(P); + Inc(PEnd, 2); // move past #0#0 + SetString(Result, P, PEnd - P); +end; + +function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; +var + Start: PWideChar; +begin + Start := P; + P := WStrScan(Start, Separator); + if P = nil then begin + Result := Start; + P := WStrEnd(Start); + end else begin + SetString(Result, Start, P - Start); + Inc(P); + end; +end; + +function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; +const + GROW_COUNT = 256; +var + Count: Integer; + Item: WideString; +begin + Count := 0; + SetLength(Result, GROW_COUNT); + Item := ExtractStringFromStringArray(P, Separator); + While Item <> '' do begin + if Count > High(Result) then + SetLength(Result, Length(Result) + GROW_COUNT); + Result[Count] := Item; + Inc(Count); + Item := ExtractStringFromStringArray(P, Separator); + end; + SetLength(Result, Count); +end; + +function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; +var + UsedDefaultChar: BOOL; +begin + WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(@WC), 1, nil, 0, nil, @UsedDefaultChar); + Result := not UsedDefaultChar; +end; + +function IsWideStringMappableToAnsi(const WS: WideString): Boolean; +var + UsedDefaultChar: BOOL; +begin + WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(WS), Length(WS), nil, 0, nil, @UsedDefaultChar); + Result := not UsedDefaultChar; +end; + +function IsRTF(const Value: WideString): Boolean; +const + RTF_BEGIN_1 = WideString('{\RTF'); + RTF_BEGIN_2 = WideString('{URTF'); +begin + Result := (WideTextPos(RTF_BEGIN_1, Value) = 1) + or (WideTextPos(RTF_BEGIN_2, Value) = 1); +end; + +{$IFDEF COMPILER_7_UP} +var + Cached_ENG_US_FormatSettings: TFormatSettings; + Cached_ENG_US_FormatSettings_Time: Cardinal; + +function ENG_US_FormatSettings: TFormatSettings; +begin + if Cached_ENG_US_FormatSettings_Time = _SettingChangeTime then + Result := Cached_ENG_US_FormatSettings + else begin + GetLocaleFormatSettings(MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US)), Result); + Result.DecimalSeparator := '.'; // ignore overrides + Cached_ENG_US_FormatSettings := Result; + Cached_ENG_US_FormatSettings_Time := _SettingChangeTime; + end; + end; + +function ENG_US_FloatToStr(Value: Extended): WideString; +begin + Result := FloatToStr(Value, ENG_US_FormatSettings); +end; + +function ENG_US_StrToFloat(const S: WideString): Extended; +begin + if not TextToFloat(PAnsiChar(AnsiString(S)), Result, fvExtended, ENG_US_FormatSettings) then + Result := StrToFloat(S); // try using native format +end; + +{$ELSE} + +function ENG_US_FloatToStr(Value: Extended): WideString; +var + SaveDecimalSep: AnsiChar; +begin + SaveDecimalSep := SysUtils.DecimalSeparator; + try + SysUtils.DecimalSeparator := '.'; + Result := FloatToStr(Value); + finally + SysUtils.DecimalSeparator := SaveDecimalSep; + end; +end; + +function ENG_US_StrToFloat(const S: WideString): Extended; +var + SaveDecimalSep: AnsiChar; +begin + try + SaveDecimalSep := SysUtils.DecimalSeparator; + try + SysUtils.DecimalSeparator := '.'; + Result := StrToFloat(S); + finally + SysUtils.DecimalSeparator := SaveDecimalSep; + end; + except + if SysUtils.DecimalSeparator <> '.' then + Result := StrToFloat(S) // try using native format + else + raise; + end; +end; +{$ENDIF} + +//--------------------------------------------------------------------------------------------- +// Tnt - Variants +//--------------------------------------------------------------------------------------------- + +initialization + Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT); + Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) + or (Win32MajorVersion > 5); + Win32PlatformIs2003 := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 2)) + or (Win32MajorVersion > 5); + Win32PlatformIsVista := (Win32MajorVersion >= 6); + +finalization + Currency_DecimalSep := ''; {make memory sleuth happy} + Currency_ThousandSep := ''; {make memory sleuth happy} + Currency_CurrencySymbol := ''; {make memory sleuth happy} + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas new file mode 100644 index 0000000000..cc99aa48f7 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas @@ -0,0 +1,1384 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntSystem; + +{$INCLUDE TntCompilers.inc} + +{*****************************************************************************} +{ Special thanks go to Francisco Leong for originating the design for } +{ WideString-enabled resourcestrings. } +{*****************************************************************************} + +interface + +uses + Windows; + +// These functions should not be used by Delphi code since conversions are implicit. +{TNT-WARN WideCharToString} +{TNT-WARN WideCharLenToString} +{TNT-WARN WideCharToStrVar} +{TNT-WARN WideCharLenToStrVar} +{TNT-WARN StringToWideChar} + +// ................ ANSI TYPES ................ +{TNT-WARN Char} +{TNT-WARN PChar} +{TNT-WARN String} + +{TNT-WARN CP_ACP} // <-- use DefaultSystemCodePage +function DefaultSystemCodePage: Cardinal; // implicitly used when converting AnsiString <--> WideString. + +var + WideCustomLoadResString: function(ResStringRec: PResStringRec; var Value: WideString): Boolean; + +{TNT-WARN LoadResString} +function WideLoadResString(ResStringRec: PResStringRec): WideString; +{TNT-WARN ParamCount} +function WideParamCount: Integer; +{TNT-WARN ParamStr} +function WideParamStr(Index: Integer): WideString; + +// ......... introduced ......... + +const + { Each Unicode stream should begin with the code U+FEFF, } + { which the standard defines as the *byte order mark*. } + UNICODE_BOM = WideChar($FEFF); + UNICODE_BOM_SWAPPED = WideChar($FFFE); + UTF8_BOM = AnsiString(#$EF#$BB#$BF); + +function WideStringToUTF8(const S: WideString): AnsiString; +function UTF8ToWideString(const S: AnsiString): WideString; + +function WideStringToUTF7(const W: WideString): AnsiString; +function UTF7ToWideString(const S: AnsiString): WideString; + +function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; +function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; + +function UCS2ToWideString(const Value: AnsiString): WideString; +function WideStringToUCS2(const Value: WideString): AnsiString; + +function CharSetToCodePage(ciCharset: UINT): Cardinal; +function LCIDToCodePage(ALcid: LCID): Cardinal; +function KeyboardCodePage: Cardinal; +function KeyUnicode(CharCode: Word): WideChar; + +procedure StrSwapByteOrder(Str: PWideChar); + +type + TTntSystemUpdate = + (tsWideResourceStrings + {$IFNDEF COMPILER_9_UP}, tsFixImplicitCodePage, tsFixWideStrConcat, tsFixWideFormat {$ENDIF} + ); + TTntSystemUpdateSet = set of TTntSystemUpdate; + +const + AllTntSystemUpdates = [Low(TTntSystemUpdate)..High(TTntSystemUpdate)]; + +procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); + +implementation + +uses + SysUtils, Variants, TntWindows, TntSysUtils; + +var + GDefaultSystemCodePage: Cardinal; + +function DefaultSystemCodePage: Cardinal; +begin + Result := GDefaultSystemCodePage; +end; + +var + IsDebugging: Boolean; + +function WideLoadResString(ResStringRec: PResStringRec): WideString; +const + MAX_RES_STRING_SIZE = 4097; { MSDN documents this as the maximum size of a string in table. } +var + Buffer: array [0..MAX_RES_STRING_SIZE] of WideChar; { Buffer leaves room for null terminator. } + PCustom: PAnsiChar; +begin + if Assigned(WideCustomLoadResString) and WideCustomLoadResString(ResStringRec, Result) then + exit; { a custom resourcestring has been loaded. } + + if ResStringRec = nil then + Result := '' + else if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, + Tnt_LoadStringW(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, MAX_RES_STRING_SIZE)) + else begin + // custom string pointer + PCustom := PAnsiChar(ResStringRec.Identifier); { I would like to use PWideChar, but this would break legacy code. } + if (StrLen{TNT-ALLOW StrLen}(PCustom) > Cardinal(Length(UTF8_BOM))) + and CompareMem(PCustom, PAnsiChar(UTF8_BOM), Length(UTF8_BOM)) then + // detected UTF8 + Result := UTF8ToWideString(PAnsiChar(PCustom + Length(UTF8_BOM))) + else + // normal + Result := PCustom; + end; +end; + +function WideGetParamStr(P: PWideChar; var Param: WideString): PWideChar; +var + i, Len: Integer; + Start, S, Q: PWideChar; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do + Inc(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + Start := P; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + Inc(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := P + 1; + Inc(Len, Q - P); + P := Q; + end; + if P[0] <> #0 then + Inc(P); + end + else + begin + Q := P + 1; + Inc(Len, Q - P); + P := Q; + end; + end; + + SetLength(Param, Len); + + P := Start; + S := PWideChar(Param); + i := 0; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + Inc(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := P + 1; + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + if P[0] <> #0 then Inc(P); + end + else + begin + Q := P + 1; + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + end; + + Result := P; +end; + +function WideParamCount: Integer; +var + P: PWideChar; + S: WideString; +begin + P := WideGetParamStr(GetCommandLineW, S); + Result := 0; + while True do + begin + P := WideGetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +end; + +function WideParamStr(Index: Integer): WideString; +var + P: PWideChar; +begin + if Index = 0 then + Result := WideGetModuleFileName(0) + else + begin + P := GetCommandLineW; + while True do + begin + P := WideGetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +end; + +function WideStringToUTF8(const S: WideString): AnsiString; +begin + Result := UTF8Encode(S); +end; + +function UTF8ToWideString(const S: AnsiString): WideString; +begin + Result := UTF8Decode(S); +end; + + { ======================================================================= } + { Original File: ConvertUTF7.c } + { Author: David B. Goldsmith } + { Copyright (C) 1994, 1996 Taligent, Inc. All rights reserved. } + { } + { This code is copyrighted. Under the copyright laws, this code may not } + { be copied, in whole or part, without prior written consent of Taligent. } + { } + { Taligent grants the right to use this code as long as this ENTIRE } + { copyright notice is reproduced in the code. The code is provided } + { AS-IS, AND TALIGENT DISCLAIMS ALL WARRANTIES, EITHER EXPRESS OR } + { IMPLIED, INCLUDING, BUT NOT LIMITED TO IMPLIED WARRANTIES OF } + { MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT } + { WILL TALIGENT BE LIABLE FOR ANY DAMAGES WHATSOEVER (INCLUDING, } + { WITHOUT LIMITATION, DAMAGES FOR LOSS OF BUSINESS PROFITS, BUSINESS } + { INTERRUPTION, LOSS OF BUSINESS INFORMATION, OR OTHER PECUNIARY } + { LOSS) ARISING OUT OF THE USE OR INABILITY TO USE THIS CODE, EVEN } + { IF TALIGENT HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. } + { BECAUSE SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF } + { LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES, THE ABOVE } + { LIMITATION MAY NOT APPLY TO YOU. } + { } + { RESTRICTED RIGHTS LEGEND: Use, duplication, or disclosure by the } + { government is subject to restrictions as set forth in subparagraph } + { (c)(l)(ii) of the Rights in Technical Data and Computer Software } + { clause at DFARS 252.227-7013 and FAR 52.227-19. } + { } + { This code may be protected by one or more U.S. and International } + { Patents. } + { } + { TRADEMARKS: Taligent and the Taligent Design Mark are registered } + { trademarks of Taligent, Inc. } + { ======================================================================= } + +type UCS2 = Word; + +const + _base64: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + _direct: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789''(),-./:?'; + _optional: AnsiString = '!"#$%&*;<=>@[]^_`{|}'; + _spaces: AnsiString = #9#13#10#32; + +var + base64: PAnsiChar; + invbase64: array[0..127] of SmallInt; + direct: PAnsiChar; + optional: PAnsiChar; + spaces: PAnsiChar; + mustshiftsafe: array[0..127] of AnsiChar; + mustshiftopt: array[0..127] of AnsiChar; + +var + needtables: Boolean = True; + +procedure Initialize_UTF7_Data; +begin + base64 := PAnsiChar(_base64); + direct := PAnsiChar(_direct); + optional := PAnsiChar(_optional); + spaces := PAnsiChar(_spaces); +end; + +procedure tabinit; +var + i: Integer; + limit: Integer; +begin + i := 0; + while (i < 128) do + begin + mustshiftopt[i] := #1; + mustshiftsafe[i] := #1; + invbase64[i] := -1; + Inc(i); + end { For }; + limit := Length(_Direct); + i := 0; + while (i < limit) do + begin + mustshiftopt[Integer(direct[i])] := #0; + mustshiftsafe[Integer(direct[i])] := #0; + Inc(i); + end { For }; + limit := Length(_Spaces); + i := 0; + while (i < limit) do + begin + mustshiftopt[Integer(spaces[i])] := #0; + mustshiftsafe[Integer(spaces[i])] := #0; + Inc(i); + end { For }; + limit := Length(_Optional); + i := 0; + while (i < limit) do + begin + mustshiftopt[Integer(optional[i])] := #0; + Inc(i); + end { For }; + limit := Length(_Base64); + i := 0; + while (i < limit) do + begin + invbase64[Integer(base64[i])] := i; + Inc(i); + end { For }; + needtables := False; +end; { tabinit } + +function WRITE_N_BITS(x: UCS2; n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): Integer; +begin + BITbuffer := BITbuffer or (x and (not (-1 shl n))) shl (32 - n - bufferbits); + bufferbits := bufferbits + n; + Result := bufferbits; +end; { WRITE_N_BITS } + +function READ_N_BITS(n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): UCS2; +var + buffertemp: Cardinal; +begin + buffertemp := BITbuffer shr (32 - n); + BITbuffer := BITbuffer shl n; + bufferbits := bufferbits - n; + Result := UCS2(buffertemp); +end; { READ_N_BITS } + +function ConvertUCS2toUTF7(var sourceStart: PWideChar; sourceEnd: PWideChar; + var targetStart: PAnsiChar; targetEnd: PAnsiChar; optional: Boolean; + verbose: Boolean): Integer; +var + r: UCS2; + target: PAnsiChar; + source: PWideChar; + BITbuffer: Cardinal; + bufferbits: Integer; + shifted: Boolean; + needshift: Boolean; + done: Boolean; + mustshift: PAnsiChar; +begin + Initialize_UTF7_Data; + Result := 0; + BITbuffer := 0; + bufferbits := 0; + shifted := False; + source := sourceStart; + target := targetStart; + r := 0; + if needtables then + tabinit; + if optional then + mustshift := @mustshiftopt[0] + else + mustshift := @mustshiftsafe[0]; + repeat + done := source >= sourceEnd; + if not Done then + begin + r := Word(source^); + Inc(Source); + end { If }; + needshift := (not done) and ((r > $7F) or (mustshift[r] <> #0)); + if needshift and (not shifted) then + begin + if (Target >= TargetEnd) then + begin + Result := 2; + break; + end { If }; + target^ := '+'; + Inc(target); + { Special case handling of the SHIFT_IN character } + if (r = UCS2('+')) then + begin + if (target >= targetEnd) then + begin + Result := 2; + break; + end; + target^ := '-'; + Inc(target); + end + else + shifted := True; + end { If }; + if shifted then + begin + { Either write the character to the bit buffer, or pad } + { the bit buffer out to a full base64 character. } + { } + if needshift then + WRITE_N_BITS(r, 16, BITbuffer, bufferbits) + else + WRITE_N_BITS(0, (6 - (bufferbits mod 6)) mod 6, BITbuffer, + bufferbits); + { Flush out as many full base64 characters as possible } + { from the bit buffer. } + { } + while (target < targetEnd) and (bufferbits >= 6) do + begin + Target^ := base64[READ_N_BITS(6, BITbuffer, bufferbits)]; + Inc(Target); + end { While }; + if (bufferbits >= 6) then + begin + if (target >= targetEnd) then + begin + Result := 2; + break; + end { If }; + end { If }; + if (not needshift) then + begin + { Write the explicit shift out character if } + { 1) The caller has requested we always do it, or } + { 2) The directly encoded character is in the } + { base64 set, or } + { 3) The directly encoded character is SHIFT_OUT. } + { } + if verbose or ((not done) and ((invbase64[r] >= 0) or (r = + Integer('-')))) then + begin + if (target >= targetEnd) then + begin + Result := 2; + Break; + end { If }; + Target^ := '-'; + Inc(Target); + end { If }; + shifted := False; + end { If }; + { The character can be directly encoded as ASCII. } + end { If }; + if (not needshift) and (not done) then + begin + if (target >= targetEnd) then + begin + Result := 2; + break; + end { If }; + Target^ := AnsiChar(r); + Inc(Target); + end { If }; + until (done); + sourceStart := source; + targetStart := target; +end; { ConvertUCS2toUTF7 } + +function ConvertUTF7toUCS2(var sourceStart: PAnsiChar; sourceEnd: PAnsiChar; + var targetStart: PWideChar; targetEnd: PWideChar): Integer; +var + target: PWideChar { Register }; + source: PAnsiChar { Register }; + BITbuffer: Cardinal { & "Address Of" Used }; + bufferbits: Integer { & "Address Of" Used }; + shifted: Boolean { Used In Boolean Context }; + first: Boolean { Used In Boolean Context }; + wroteone: Boolean; + base64EOF: Boolean; + base64value: Integer; + done: Boolean; + c: UCS2; + prevc: UCS2; + junk: UCS2 { Used In Boolean Context }; +begin + Initialize_UTF7_Data; + Result := 0; + BITbuffer := 0; + bufferbits := 0; + shifted := False; + first := False; + wroteone := False; + source := sourceStart; + target := targetStart; + c := 0; + if needtables then + tabinit; + repeat + { read an ASCII character c } + done := Source >= SourceEnd; + if (not done) then + begin + c := Word(Source^); + Inc(Source); + end { If }; + if shifted then + begin + { We're done with a base64 string if we hit EOF, it's not a valid } + { ASCII character, or it's not in the base64 set. } + { } + base64value := invbase64[c]; + base64EOF := (done or (c > $7F)) or (base64value < 0); + if base64EOF then + begin + shifted := False; + { If the character causing us to drop out was SHIFT_IN or } + { SHIFT_OUT, it may be a special escape for SHIFT_IN. The } + { test for SHIFT_IN is not necessary, but allows an alternate } + { form of UTF-7 where SHIFT_IN is escaped by SHIFT_IN. This } + { only works for some values of SHIFT_IN. } + { } + if ((not done) and ((c = Integer('+')) or (c = Integer('-')))) then + begin + { get another character c } + prevc := c; + Done := Source >= SourceEnd; + if (not Done) then + begin + c := Word(Source^); + Inc(Source); + { If no base64 characters were encountered, and the } + { character terminating the shift sequence was } + { SHIFT_OUT, then it's a special escape for SHIFT_IN. } + { } + end; + if first and (prevc = Integer('-')) then + begin + { write SHIFT_IN unicode } + if (target >= targetEnd) then + begin + Result := 2; + break; + end { If }; + Target^ := WideChar('+'); + Inc(Target); + end + else + begin + if (not wroteone) then + begin + Result := 1; + end { If }; + end { Else }; + ; + end { If } + else + begin + if (not wroteone) then + begin + Result := 1; + end { If }; + end { Else }; + end { If } + else + begin + { Add another 6 bits of base64 to the bit buffer. } + WRITE_N_BITS(base64value, 6, BITbuffer, + bufferbits); + first := False; + end { Else }; + { Extract as many full 16 bit characters as possible from the } + { bit buffer. } + { } + while (bufferbits >= 16) and (target < targetEnd) do + begin + { write a unicode } + Target^ := WideChar(READ_N_BITS(16, BITbuffer, bufferbits)); + Inc(Target); + wroteone := True; + end { While }; + if (bufferbits >= 16) then + begin + if (target >= targetEnd) then + begin + Result := 2; + Break; + end; + end { If }; + if (base64EOF) then + begin + junk := READ_N_BITS(bufferbits, BITbuffer, bufferbits); + if (junk <> 0) then + begin + Result := 1; + end { If }; + end { If }; + end { If }; + if (not shifted) and (not done) then + begin + if (c = Integer('+')) then + begin + shifted := True; + first := True; + wroteone := False; + end { If } + else + begin + { It must be a directly encoded character. } + if (c > $7F) then + begin + Result := 1; + end { If }; + if (target >= targetEnd) then + begin + Result := 2; + break; + end { If }; + Target^ := WideChar(c); + Inc(Target); + end { Else }; + end { If }; + until (done); + sourceStart := source; + targetStart := target; +end; { ConvertUTF7toUCS2 } + + {*****************************************************************************} + { Thanks to Francisco Leong for providing the Pascal conversion of } + { ConvertUTF7.c (by David B. Goldsmith) } + {*****************************************************************************} + +resourcestring + SBufferOverflow = 'Buffer overflow'; + SInvalidUTF7 = 'Invalid UTF7'; + +function WideStringToUTF7(const W: WideString): AnsiString; +var + SourceStart, SourceEnd: PWideChar; + TargetStart, TargetEnd: PAnsiChar; +begin + if W = '' then + Result := '' + else + begin + SetLength(Result, Length(W) * 7); // Assume worst case + SourceStart := PWideChar(@W[1]); + SourceEnd := PWideChar(@W[Length(W)]) + 1; + TargetStart := PAnsiChar(@Result[1]); + TargetEnd := PAnsiChar(@Result[Length(Result)]) + 1; + if ConvertUCS2toUTF7(SourceStart, SourceEnd, TargetStart, + TargetEnd, True, False) <> 0 + then + raise ETntInternalError.Create(SBufferOverflow); + SetLength(Result, TargetStart - PAnsiChar(@Result[1])); + end; +end; + +function UTF7ToWideString(const S: AnsiString): WideString; +var + SourceStart, SourceEnd: PAnsiChar; + TargetStart, TargetEnd: PWideChar; +begin + if (S = '') then + Result := '' + else + begin + SetLength(Result, Length(S)); // Assume Worst case + SourceStart := PAnsiChar(@S[1]); + SourceEnd := PAnsiChar(@S[Length(S)]) + 1; + TargetStart := PWideChar(@Result[1]); + TargetEnd := PWideChar(@Result[Length(Result)]) + 1; + case ConvertUTF7toUCS2(SourceStart, SourceEnd, TargetStart, + TargetEnd) of + 1: raise ETntGeneralError.Create(SInvalidUTF7); + 2: raise ETntInternalError.Create(SBufferOverflow); + end; + SetLength(Result, TargetStart - PWideChar(@Result[1])); + end; +end; + +function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; +var + InputLength, + OutputLength: Integer; +begin + if CodePage = CP_UTF7 then + Result := UTF7ToWideString(S) // CP_UTF7 not supported on Windows 95 + else if CodePage = CP_UTF8 then + Result := UTF8ToWideString(S) // CP_UTF8 not supported on Windows 95 + else begin + InputLength := Length(S); + OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, nil, 0); + SetLength(Result, OutputLength); + MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result), OutputLength); + end; +end; + +function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; +var + InputLength, + OutputLength: Integer; +begin + if CodePage = CP_UTF7 then + Result := WideStringToUTF7(WS) // CP_UTF7 not supported on Windows 95 + else if CodePage = CP_UTF8 then + Result := WideStringToUTF8(WS) // CP_UTF8 not supported on Windows 95 + else begin + InputLength := Length(WS); + OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, nil, 0, nil, nil); + SetLength(Result, OutputLength); + WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result), OutputLength, nil, nil); + end; +end; + +function UCS2ToWideString(const Value: AnsiString): WideString; +begin + if Length(Value) = 0 then + Result := '' + else + SetString(Result, PWideChar(@Value[1]), Length(Value) div SizeOf(WideChar)) +end; + +function WideStringToUCS2(const Value: WideString): AnsiString; +begin + if Length(Value) = 0 then + Result := '' + else + SetString(Result, PAnsiChar(@Value[1]), Length(Value) * SizeOf(WideChar)) +end; + +{ Windows.pas doesn't declare TranslateCharsetInfo() correctly. } +function TranslateCharsetInfo(lpSrc: PDWORD; var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall; external gdi32 name 'TranslateCharsetInfo'; + +function CharSetToCodePage(ciCharset: UINT): Cardinal; +var + C: TCharsetInfo; +begin + Win32Check(TranslateCharsetInfo(PDWORD(ciCharset), C, TCI_SRCCHARSET)); + Result := C.ciACP +end; + +function LCIDToCodePage(ALcid: LCID): Cardinal; +var + Buf: array[0..6] of AnsiChar; +begin + GetLocaleInfo(ALcid, LOCALE_IDefaultAnsiCodePage, Buf, 6); + Result := StrToIntDef(Buf, GetACP); +end; + +function KeyboardCodePage: Cardinal; +begin + Result := LCIDToCodePage(GetKeyboardLayout(0) and $FFFF); +end; + +function KeyUnicode(CharCode: Word): WideChar; +var + AChar: AnsiChar; +begin + // converts the given character (as it comes with a WM_CHAR message) into its + // corresponding Unicode character depending on the active keyboard layout + if CharCode <= Word(High(AnsiChar)) then begin + AChar := AnsiChar(CharCode); + MultiByteToWideChar(KeyboardCodePage, MB_USEGLYPHCHARS, @AChar, 1, @Result, 1); + end else + Result := WideChar(CharCode); +end; + +procedure StrSwapByteOrder(Str: PWideChar); +var + P: PWord; +begin + P := PWord(Str); + While (P^ <> 0) do begin + P^ := MakeWord(HiByte(P^), LoByte(P^)); + Inc(P); + end; +end; + +//-------------------------------------------------------------------- +// LoadResString() +// +// This system function is used to retrieve a resourcestring and +// return the result as an AnsiString. If we believe that the result +// is only a temporary value, and that it will be immediately +// assigned to a WideString or a Variant, then we will save the +// Unicode result as well as a reference to the original Ansi string. +// WStrFromPCharLen() or VarFromLStr() will return this saved +// Unicode string if it appears to receive the most recent result +// of LoadResString. +//-------------------------------------------------------------------- + + + //=========================================================================================== + // + // function CodeMatchesPatternForUnicode(...); + // + // GIVEN: SomeWideString := SSomeResString; { WideString := resourcestring } + // + // Delphi will compile this statement into the following: + // ------------------------------------------------- + // TempAnsiString := LoadResString(@SSomeResString); + // LINE 1: lea edx,[SomeTempAnsiString] + // LINE 2: mov eax,[@SomeResString] + // LINE 3: call LoadResString + // + // WStrFromLStr(SomeWideString, TempAnsiString); { SomeWideString := TempAnsiString } + // LINE 4: mov edx,[SomeTempAnsiString] + // LINE 5: mov/lea eax [@SomeWideString] + // LINE 6: call @WStrFromLStr + // ------------------------------------------------- + // + // The order in which the parameters are prepared for WStrFromLStr (ie LINE 4 & 5) is + // reversed when assigning a non-temporary AnsiString to a WideString. + // + // This code, for example, results in LINE 4 and LINE 5 being swapped. + // + // SomeAnsiString := SSomeResString; + // SomeWideString := SomeAnsiString; + // + // Since we know the "signature" used by the compiler, we can detect this pattern. + // If we believe it is only temporary, we can save the Unicode results for later + // retrieval from WStrFromLStr. + // + // One final note: When assigning a resourcestring to a Variant, the same patterns exist. + //=========================================================================================== + +function CodeMatchesPatternForUnicode(PLine4: PAnsiChar): Boolean; +const + SIZEOF_OPCODE = 1 {byte}; + MOV_16_OPCODE = AnsiChar($8B); { we'll assume operand size is 16 bits } + MOV_32_OPCODE = AnsiChar($B8); { we'll assume operand size is 32 bits } + LEA_OPCODE = AnsiChar($8D); { operand size can be 16 or 40 bits } + CALL_OPCODE = AnsiChar($E8); { assumed operand size is 32 bits } + BREAK_OPCODE = AnsiChar($CC); {in a breakpoint} +var + PLine1: PAnsiChar; + PLine2: PAnsiChar; + PLine3: PAnsiChar; + DataSize: Integer; // bytes in first LEA operand +begin + Result := False; + + PLine3 := PLine4 - SizeOf(CALL_OPCODE) - 4; + PLine2 := PLine3 - SizeOf(MOV_32_OPCODE) - 4; + + // figure PLine1 and operand size + DataSize := 2; { try 16 bit operand for line 1 } + PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); + if (PLine1^ <> LEA_OPCODE) and (not (IsDebugging and (PLine1^ = BREAK_OPCODE))) then + begin + DataSize := 5; { try 40 bit operand for line 1 } + PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); + end; + if (PLine1^ = LEA_OPCODE) or (IsDebugging and (PLine1^ = BREAK_OPCODE)) then + begin + if CompareMem(PLine1 + SIZEOF_OPCODE, PLine4 + SIZEOF_OPCODE, DataSize) then + begin + // After this check, it seems to match the WideString <- (temp) AnsiString pattern + Result := True; // It is probably OK. (The side effects of being wrong aren't very bad.) + end; + end; +end; + +threadvar + PLastResString: PAnsiChar; + LastResStringValue: AnsiString; + LastWideResString: WideString; + +procedure FreeTntSystemThreadVars; +begin + LastResStringValue := ''; + LastWideResString := ''; +end; + +procedure Custom_System_EndThread(ExitCode: Integer); +begin + FreeTntSystemThreadVars; + {$IFDEF COMPILER_10_UP} + if Assigned(SystemThreadEndProc) then + SystemThreadEndProc(ExitCode); + {$ENDIF} + ExitThread(ExitCode); +end; + +function Custom_System_LoadResString(ResStringRec: PResStringRec): AnsiString; +var + ReturnAddr: Pointer; +begin + // get return address + asm + PUSH ECX + MOV ECX, [EBP + 4] + MOV ReturnAddr, ECX + POP ECX + end; + // check calling code pattern + if CodeMatchesPatternForUnicode(ReturnAddr) then begin + // result will probably be assigned to an intermediate AnsiString + // on its way to either a WideString or Variant. + LastWideResString := WideLoadResString(ResStringRec); + Result := LastWideResString; + LastResStringValue := Result; + if Result = '' then + PLastResString := nil + else + PLastResString := PAnsiChar(Result); + end else begin + // result will probably be assigned to an actual AnsiString variable. + PLastResString := nil; + Result := WideLoadResString(ResStringRec); + end; +end; + +//-------------------------------------------------------------------- +// WStrFromPCharLen() +// +// This system function is used to assign an AnsiString to a WideString. +// It has been modified to assign Unicode results from LoadResString. +// Another purpose of this function is to specify the code page. +//-------------------------------------------------------------------- + +procedure Custom_System_WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; + Local_PLastResString: Pointer; +begin + Local_PLastResString := PLastResString; + if (Local_PLastResString <> nil) + and (Local_PLastResString = Source) + and (System.Length(LastResStringValue) = Length) + and (LastResStringValue = Source) then begin + // use last unicode resource string + PLastResString := nil; { clear for further use } + Dest := LastWideResString; + end else begin + if Local_PLastResString <> nil then + PLastResString := nil; { clear for further use } + if Length <= 0 then + begin + Dest := ''; + Exit; + end; + if Length + 1 < High(Buffer) then + begin + DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Buffer, + High(Buffer)); + if DestLen > 0 then + begin + SetLength(Dest, DestLen); + Move(Pointer(@Buffer[0])^, Pointer(Dest)^, DestLen * SizeOf(WideChar)); + Exit; + end; + end; + DestLen := (Length + 1); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), + DestLen); + if DestLen < 0 then + DestLen := 0; + SetLength(Dest, DestLen); + end; +end; + +{$IFNDEF COMPILER_9_UP} + +//-------------------------------------------------------------------- +// LStrFromPWCharLen() +// +// This system function is used to assign an WideString to an AnsiString. +// It has not been modified from its original purpose other than to specify the code page. +//-------------------------------------------------------------------- + +procedure Custom_System_LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..4095] of AnsiChar; +begin + if Length <= 0 then + begin + Dest := ''; + Exit; + end; + if Length + 1 < (High(Buffer) div sizeof(WideChar)) then + begin + DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, + Length, Buffer, High(Buffer), + nil, nil); + if DestLen >= 0 then + begin + SetLength(Dest, DestLen); + Move(Pointer(@Buffer[0])^, PAnsiChar(Dest)^, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1) * sizeof(WideChar); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), DestLen, + nil, nil); + if DestLen < 0 then + DestLen := 0; + SetLength(Dest, DestLen); +end; + +//-------------------------------------------------------------------- +// WStrToString() +// +// This system function is used to assign an WideString to an short string. +// It has not been modified from its original purpose other than to specify the code page. +//-------------------------------------------------------------------- + +procedure Custom_System_WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of AnsiChar; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else begin + DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Pointer(Source), SourceLen, + Buffer, SizeOf(Buffer), nil, nil); + if DestLen > MaxLen then DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +{$ENDIF} + +//-------------------------------------------------------------------- +// VarFromLStr() +// +// This system function is used to assign an AnsiString to a Variant. +// It has been modified to assign Unicode results from LoadResString. +//-------------------------------------------------------------------- + +procedure Custom_System_VarFromLStr(var V: TVarData; const Value: AnsiString); +const + varDeepData = $BFE8; +var + Local_PLastResString: Pointer; +begin + if (V.VType and varDeepData) <> 0 then + VarClear(PVariant(@V)^); + + Local_PLastResString := PLastResString; + if (Local_PLastResString <> nil) + and (Local_PLastResString = PAnsiChar(Value)) + and (LastResStringValue = Value) then begin + // use last unicode resource string + PLastResString := nil; { clear for further use } + V.VOleStr := nil; + V.VType := varOleStr; + WideString(Pointer(V.VOleStr)) := Copy(LastWideResString, 1, MaxInt); + end else begin + if Local_PLastResString <> nil then + PLastResString := nil; { clear for further use } + V.VString := nil; + V.VType := varString; + AnsiString(V.VString) := Value; + end; +end; + +{$IFNDEF COMPILER_9_UP} + +//-------------------------------------------------------------------- +// WStrCat3() A := B + C; +// +// This system function is used to concatenate two strings into one result. +// This function is added because A := '' + '' doesn't necessarily result in A = ''; +//-------------------------------------------------------------------- + +procedure Custom_System_WStrCat3(var Dest: WideString; const Source1, Source2: WideString); + + function NewWideString(CharLength: Longint): Pointer; + var + _NewWideString: function(CharLength: Longint): Pointer; + begin + asm + PUSH ECX + MOV ECX, offset System.@NewWideString; + MOV _NewWideString, ECX + POP ECX + end; + Result := _NewWideString(CharLength); + end; + + procedure WStrSet(var S: WideString; P: PWideChar); + var + Temp: Pointer; + begin + Temp := Pointer(InterlockedExchange(Integer(S), Integer(P))); + if Temp <> nil then + WideString(Temp) := ''; + end; + +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end else + Dest := ''; +end; + +{$ENDIF} + +//-------------------------------------------------------------------- +// System proc replacements +//-------------------------------------------------------------------- + +type + POverwrittenData = ^TOverwrittenData; + TOverwrittenData = record + Location: Pointer; + OldCode: array[0..6] of Byte; + end; + +procedure OverwriteProcedure(OldProcedure, NewProcedure: pointer; Data: POverwrittenData = nil); +{ OverwriteProcedure originally from Igor Siticov } +{ Modified by Jacques Garcia Vazquez } +var + x: PAnsiChar; + y: integer; + ov2, ov: cardinal; + p: pointer; +begin + if Assigned(Data) and (Data.Location <> nil) then + exit; { procedure already overwritten } + + // need six bytes in place of 5 + x := PAnsiChar(OldProcedure); + if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then + RaiseLastOSError; + + // if a jump is present then a redirect is found + // $FF25 = jmp dword ptr [xxx] + // This redirect is normally present in bpl files, but not in exe files + p := OldProcedure; + + if Word(p^) = $25FF then + begin + Inc(Integer(p), 2); // skip the jump + // get the jump address p^ and dereference it p^^ + p := Pointer(Pointer(p^)^); + + // release the memory + if not VirtualProtect(Pointer(x), 6, ov, @ov2) then + RaiseLastOSError; + + // re protect the correct one + x := PAnsiChar(p); + if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then + RaiseLastOSError; + end; + + if Assigned(Data) then + begin + Move(x^, Data.OldCode, 6); + { Assign Location last so that Location <> nil only if OldCode is properly initialized. } + Data.Location := x; + end; + + x[0] := AnsiChar($E9); + y := integer(NewProcedure) - integer(p) - 5; + x[1] := AnsiChar(y and 255); + x[2] := AnsiChar((y shr 8) and 255); + x[3] := AnsiChar((y shr 16) and 255); + x[4] := AnsiChar((y shr 24) and 255); + + if not VirtualProtect(Pointer(x), 6, ov, @ov2) then + RaiseLastOSError; +end; + +procedure RestoreProcedure(OriginalProc: Pointer; Data: TOverwrittenData); +var + ov, ov2: Cardinal; +begin + if Data.Location <> nil then begin + if not VirtualProtect(Data.Location, 6, PAGE_EXECUTE_READWRITE, @ov) then + RaiseLastOSError; + Move(Data.OldCode, Data.Location^, 6); + if not VirtualProtect(Data.Location, 6, ov, @ov2) then + RaiseLastOSError; + end; +end; + +function Addr_System_EndThread: Pointer; +begin + Result := @System.EndThread; +end; + +function Addr_System_LoadResString: Pointer; +begin + Result := @System.LoadResString{TNT-ALLOW LoadResString}; +end; + +function Addr_System_WStrFromPCharLen: Pointer; +asm + mov eax, offset System.@WStrFromPCharLen; +end; + +{$IFNDEF COMPILER_9_UP} +function Addr_System_LStrFromPWCharLen: Pointer; +asm + mov eax, offset System.@LStrFromPWCharLen; +end; + +function Addr_System_WStrToString: Pointer; +asm + mov eax, offset System.@WStrToString; +end; +{$ENDIF} + +function Addr_System_VarFromLStr: Pointer; +asm + mov eax, offset System.@VarFromLStr; +end; + +function Addr_System_WStrCat3: Pointer; +asm + mov eax, offset System.@WStrCat3; +end; + +var + System_EndThread_Code, + System_LoadResString_Code, + System_WStrFromPCharLen_Code, + {$IFNDEF COMPILER_9_UP} + System_LStrFromPWCharLen_Code, + System_WStrToString_Code, + {$ENDIF} + System_VarFromLStr_Code + {$IFNDEF COMPILER_9_UP} + , + System_WStrCat3_Code, + SysUtils_WideFmtStr_Code + {$ENDIF} + : TOverwrittenData; + +procedure InstallEndThreadOverride; +begin + OverwriteProcedure(Addr_System_EndThread, @Custom_System_EndThread, @System_EndThread_Code); +end; + +procedure InstallStringConversionOverrides; +begin + OverwriteProcedure(Addr_System_WStrFromPCharLen, @Custom_System_WStrFromPCharLen, @System_WStrFromPCharLen_Code); + {$IFNDEF COMPILER_9_UP} + OverwriteProcedure(Addr_System_LStrFromPWCharLen, @Custom_System_LStrFromPWCharLen, @System_LStrFromPWCharLen_Code); + OverwriteProcedure(Addr_System_WStrToString, @Custom_System_WStrToString, @System_WStrToString_Code); + {$ENDIF} +end; + +procedure InstallWideResourceStrings; +begin + OverwriteProcedure(Addr_System_LoadResString, @Custom_System_LoadResString, @System_LoadResString_Code); + OverwriteProcedure(Addr_System_VarFromLStr, @Custom_System_VarFromLStr, @System_VarFromLStr_Code); +end; + +{$IFNDEF COMPILER_9_UP} +procedure InstallWideStringConcatenationFix; +begin + OverwriteProcedure(Addr_System_WStrCat3, @Custom_System_WStrCat3, @System_WStrCat3_Code); +end; + +procedure InstallWideFormatFixes; +begin + OverwriteProcedure(@SysUtils.WideFmtStr, @TntSysUtils.Tnt_WideFmtStr, @SysUtils_WideFmtStr_Code); +end; +{$ENDIF} + +procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); +begin + InstallEndThreadOverride; + if tsWideResourceStrings in Updates then begin + InstallStringConversionOverrides; + InstallWideResourceStrings; + end; + {$IFNDEF COMPILER_9_UP} + if tsFixImplicitCodePage in Updates then begin + InstallStringConversionOverrides; + { CP_ACP is the code page used by the non-Unicode Windows API. } + GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; + end; + if tsFixWideStrConcat in Updates then begin + InstallWideStringConcatenationFix; + end; + if tsFixWideFormat in Updates then begin + InstallWideFormatFixes; + end; + {$ENDIF} +end; + +{$IFNDEF COMPILER_9_UP} +var + StartupDefaultUserCodePage: Cardinal; +{$ENDIF} + +procedure UninstallSystemOverrides; +begin + RestoreProcedure(Addr_System_EndThread, System_EndThread_Code); + // String Conversion + RestoreProcedure(Addr_System_WStrFromPCharLen, System_WStrFromPCharLen_Code); + {$IFNDEF COMPILER_9_UP} + RestoreProcedure(Addr_System_LStrFromPWCharLen, System_LStrFromPWCharLen_Code); + RestoreProcedure(Addr_System_WStrToString, System_WStrToString_Code); + GDefaultSystemCodePage := StartupDefaultUserCodePage; + {$ENDIF} + // Wide resourcestring + RestoreProcedure(Addr_System_LoadResString, System_LoadResString_Code); + RestoreProcedure(Addr_System_VarFromLStr, System_VarFromLStr_Code); + {$IFNDEF COMPILER_9_UP} + // WideString concat fix + RestoreProcedure(Addr_System_WStrCat3, System_WStrCat3_Code); + // WideFormat fixes + RestoreProcedure(@SysUtils.WideFmtStr, SysUtils_WideFmtStr_Code); + {$ENDIF} +end; + +initialization + {$IFDEF COMPILER_9_UP} + GDefaultSystemCodePage := GetACP; + {$ELSE} + {$IFDEF COMPILER_7_UP} + if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then + GDefaultSystemCodePage := CP_THREAD_ACP // Win 2K/XP/... + else + GDefaultSystemCodePage := LCIDToCodePage(GetThreadLocale); // Win NT4/95/98/ME + {$ELSE} + GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; + {$ENDIF} + {$ENDIF} + {$IFNDEF COMPILER_9_UP} + StartupDefaultUserCodePage := DefaultSystemCodePage; + {$ENDIF} + IsDebugging := DebugHook > 0; + +finalization + UninstallSystemOverrides; + FreeTntSystemThreadVars; { Make MemorySleuth happy. } + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas new file mode 100644 index 0000000000..02a64bbc3e --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas @@ -0,0 +1,451 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntWideStrUtils; + +{$INCLUDE TntCompilers.inc} + +interface + +{ Wide string manipulation functions } + +{$IFNDEF COMPILER_9_UP} +function WStrAlloc(Size: Cardinal): PWideChar; +function WStrBufSize(const Str: PWideChar): Cardinal; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_9_UP} +function WStrNew(const Str: PWideChar): PWideChar; +procedure WStrDispose(Str: PWideChar); +{$ENDIF} +//--------------------------------------------------------------------------------------------- +{$IFNDEF COMPILER_9_UP} +function WStrLen(Str: PWideChar): Cardinal; +function WStrEnd(Str: PWideChar): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_9_UP} +function WStrCopy(Dest, Source: PWideChar): PWideChar; +function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; +function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; +function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; +// WStrComp and WStrPos were introduced as broken in Delphi 2006, but fixed in Delphi 2006 Update 2 +function WStrComp(Str1, Str2: PWideChar): Integer; +function WStrPos(Str, SubStr: PWideChar): PWideChar; +{$ENDIF} +function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; +function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; + +{ ------------ introduced --------------- } +function WStrECopy(Dest, Source: PWideChar): PWideChar; +function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +function WStrIComp(Str1, Str2: PWideChar): Integer; +function WStrLower(Str: PWideChar): PWideChar; +function WStrUpper(Str: PWideChar): PWideChar; +function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; +function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; +function WStrPas(const Str: PWideChar): WideString; + +{ SysUtils.pas } //------------------------------------------------------------------------- + +{$IFNDEF COMPILER_10_UP} +function WideLastChar(const S: WideString): PWideChar; +function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; +{$ENDIF} +{$IFNDEF COMPILER_9_UP} +function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; +{$ENDIF} + +implementation + +uses + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} Math, Windows, TntWindows; + +{$IFNDEF COMPILER_9_UP} +function WStrAlloc(Size: Cardinal): PWideChar; +begin + Size := SizeOf(Cardinal) + (Size * SizeOf(WideChar)); + GetMem(Result, Size); + PCardinal(Result)^ := Size; + Inc(PAnsiChar(Result), SizeOf(Cardinal)); +end; + +function WStrBufSize(const Str: PWideChar): Cardinal; +var + P: PWideChar; +begin + P := Str; + Dec(PAnsiChar(P), SizeOf(Cardinal)); + Result := PCardinal(P)^ - SizeOf(Cardinal); + Result := Result div SizeOf(WideChar); +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; +var + Length: Integer; +begin + Result := Dest; + Length := Count * SizeOf(WideChar); + Move(Source^, Dest^, Length); +end; +{$ENDIF} + +{$IFNDEF COMPILER_9_UP} +function WStrNew(const Str: PWideChar): PWideChar; +var + Size: Cardinal; +begin + if Str = nil then Result := nil else + begin + Size := WStrLen(Str) + 1; + Result := WStrMove(WStrAlloc(Size), Str, Size); + end; +end; + +procedure WStrDispose(Str: PWideChar); +begin + if Str <> nil then + begin + Dec(PAnsiChar(Str), SizeOf(Cardinal)); + FreeMem(Str, Cardinal(Pointer(Str)^)); + end; +end; +{$ENDIF} + +//--------------------------------------------------------------------------------------------- + +{$IFNDEF COMPILER_9_UP} +function WStrLen(Str: PWideChar): Cardinal; +begin + Result := WStrEnd(Str) - Str; +end; + +function WStrEnd(Str: PWideChar): PWideChar; +begin + // returns a pointer to the end of a null terminated string + Result := Str; + While Result^ <> #0 do + Inc(Result); +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; +begin + Result := Dest; + WStrCopy(WStrEnd(Dest), Source); +end; +{$ENDIF} + +{$IFNDEF COMPILER_9_UP} +function WStrCopy(Dest, Source: PWideChar): PWideChar; +begin + Result := WStrLCopy(Dest, Source, MaxInt); +end; + +function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; +var + Count: Cardinal; +begin + // copies a specified maximum number of characters from Source to Dest + Result := Dest; + Count := 0; + While (Count < MaxLen) and (Source^ <> #0) do begin + Dest^ := Source^; + Inc(Source); + Inc(Dest); + Inc(Count); + end; + Dest^ := #0; +end; + +function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; +begin + Result := WStrLCopy(Dest, PWideChar(Source), Length(Source)); +end; + +function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; +begin + Result := WStrLCopy(Dest, PWideChar(Source), MaxLen); +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; +begin + Result := Str; + while Result^ <> Chr do + begin + if Result^ = #0 then + begin + Result := nil; + Exit; + end; + Inc(Result); + end; +end; + +function WStrComp(Str1, Str2: PWideChar): Integer; +begin + Result := WStrLComp(Str1, Str2, MaxInt); +end; + +function WStrPos(Str, SubStr: PWideChar): PWideChar; +var + PSave: PWideChar; + P: PWideChar; + PSub: PWideChar; +begin + // returns a pointer to the first occurance of SubStr in Str + Result := nil; + if (Str <> nil) and (Str^ <> #0) and (SubStr <> nil) and (SubStr^ <> #0) then begin + P := Str; + While P^ <> #0 do begin + if P^ = SubStr^ then begin + // investigate possibility here + PSave := P; + PSub := SubStr; + While (P^ = PSub^) do begin + Inc(P); + Inc(PSub); + if (PSub^ = #0) then begin + Result := PSave; + exit; // found a match + end; + if (P^ = #0) then + exit; // no match, hit end of string + end; + P := PSave; + end; + Inc(P); + end; + end; +end; +{$ENDIF} + +function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; +begin + Result := WStrComp(Str1, Str2); +end; + +function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; +begin + Result := WStrPos(Str, SubStr); +end; + +//------------------------------------------------------------------------------ + +function WStrECopy(Dest, Source: PWideChar): PWideChar; +begin + Result := WStrEnd(WStrCopy(Dest, Source)); +end; + +function WStrComp_EX(Str1, Str2: PWideChar; MaxLen: Cardinal; dwCmpFlags: Cardinal): Integer; +var + Len1, Len2: Integer; +begin + if MaxLen = Cardinal(MaxInt) then begin + Len1 := -1; + Len2 := -1; + end else begin + Len1 := Min(WStrLen(Str1), MaxLen); + Len2 := Min(WStrLen(Str2), MaxLen); + end; + Result := Tnt_CompareStringW(GetThreadLocale, dwCmpFlags, Str1, Len1, Str2, Len2) - 2; +end; + +function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +begin + Result := WStrComp_EX(Str1, Str2, MaxLen, 0); +end; + +function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +begin + Result := WStrComp_EX(Str1, Str2, MaxLen, NORM_IGNORECASE); +end; + +function WStrIComp(Str1, Str2: PWideChar): Integer; +begin + Result := WStrLIComp(Str1, Str2, MaxInt); +end; + +function WStrLower(Str: PWideChar): PWideChar; +begin + Result := Str; + Tnt_CharLowerBuffW(Str, WStrLen(Str)) +end; + +function WStrUpper(Str: PWideChar): PWideChar; +begin + Result := Str; + Tnt_CharUpperBuffW(Str, WStrLen(Str)) +end; + +function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; +var + MostRecentFound: PWideChar; +begin + if Chr = #0 then + Result := WStrEnd(Str) + else + begin + Result := nil; + MostRecentFound := Str; + while True do + begin + while MostRecentFound^ <> Chr do + begin + if MostRecentFound^ = #0 then + Exit; + Inc(MostRecentFound); + end; + Result := MostRecentFound; + Inc(MostRecentFound); + end; + end; +end; + +function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; +begin + Result := Dest; + WStrLCopy(WStrEnd(Dest), Source, MaxLen - WStrLen(Dest)); +end; + +function WStrPas(const Str: PWideChar): WideString; +begin + Result := Str; +end; + +//--------------------------------------------------------------------------------------------- + +{$IFNDEF COMPILER_10_UP} +function WideLastChar(const S: WideString): PWideChar; +begin + if S = '' then + Result := nil + else + Result := @S[Length(S)]; +end; + +function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; +var + P, Src, + Dest: PWideChar; + AddCount: Integer; +begin + AddCount := 0; + P := WStrScan(PWideChar(S), Quote); + while (P <> nil) do + begin + Inc(P); + Inc(AddCount); + P := WStrScan(P, Quote); + end; + + if AddCount = 0 then + Result := Quote + S + Quote + else + begin + SetLength(Result, Length(S) + AddCount + 2); + Dest := PWideChar(Result); + Dest^ := Quote; + Inc(Dest); + Src := PWideChar(S); + P := WStrScan(Src, Quote); + repeat + Inc(P); + Move(Src^, Dest^, 2 * (P - Src)); + Inc(Dest, P - Src); + Dest^ := Quote; + Inc(Dest); + Src := P; + P := WStrScan(Src, Quote); + until P = nil; + P := WStrEnd(Src); + Move(Src^, Dest^, 2 * (P - Src)); + Inc(Dest, P - Src); + Dest^ := Quote; + end; +end; +{$ENDIF} + +{$IFNDEF COMPILER_9_UP} +function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; +var + P, Dest: PWideChar; + DropCount: Integer; +begin + Result := ''; + if (Src = nil) or (Src^ <> Quote) then Exit; + Inc(Src); + DropCount := 1; + P := Src; + Src := WStrScan(Src, Quote); + while Src <> nil do // count adjacent pairs of quote chars + begin + Inc(Src); + if Src^ <> Quote then Break; + Inc(Src); + Inc(DropCount); + Src := WStrScan(Src, Quote); + end; + if Src = nil then Src := WStrEnd(P); + if ((Src - P) <= 1) then Exit; + if DropCount = 1 then + SetString(Result, P, Src - P - 1) + else + begin + SetLength(Result, Src - P - DropCount); + Dest := PWideChar(Result); + Src := WStrScan(P, Quote); + while Src <> nil do + begin + Inc(Src); + if Src^ <> Quote then Break; + Move(P^, Dest^, (Src - P) * SizeOf(WideChar)); + Inc(Dest, Src - P); + Inc(Src); + P := Src; + Src := WStrScan(Src, Quote); + end; + if Src = nil then Src := WStrEnd(P); + Move(P^, Dest^, (Src - P - 1) * SizeOf(WideChar)); + end; +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; +var + LText : PWideChar; +begin + LText := PWideChar(S); + Result := WideExtractQuotedStr(LText, AQuote); + if Result = '' then + Result := S; +end; +{$ENDIF} + + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas new file mode 100644 index 0000000000..dfe3755403 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas @@ -0,0 +1,831 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntWideStrings; + +{$INCLUDE TntCompilers.inc} + +interface + +{$IFDEF COMPILER_10_UP} + {$MESSAGE FATAL 'Do not refer to TntWideStrings.pas. It works correctly in Delphi 2006.'} +{$ENDIF} + +uses + Classes; + +{******************************************************************************} +{ } +{ Delphi 2005 introduced TWideStrings in WideStrings.pas. } +{ Unfortunately, it was not ready for prime time. } +{ Setting CommaText is not consistent, and it relies on CharNextW } +{ Which is only available on Windows NT+. } +{ } +{******************************************************************************} + +type + TWideStrings = class; + +{ IWideStringsAdapter interface } +{ Maintains link between TWideStrings and IWideStrings implementations } + + IWideStringsAdapter = interface + ['{25FE0E3B-66CB-48AA-B23B-BCFA67E8F5DA}'] + procedure ReferenceStrings(S: TWideStrings); + procedure ReleaseStrings; + end; + + TWideStringsEnumerator = class + private + FIndex: Integer; + FStrings: TWideStrings; + public + constructor Create(AStrings: TWideStrings); + function GetCurrent: WideString; + function MoveNext: Boolean; + property Current: WideString read GetCurrent; + end; + +{ TWideStrings class } + + TWideStrings = class(TPersistent) + private + FDefined: TStringsDefined; + FDelimiter: WideChar; + FQuoteChar: WideChar; + {$IFDEF COMPILER_7_UP} + FNameValueSeparator: WideChar; + {$ENDIF} + FUpdateCount: Integer; + FAdapter: IWideStringsAdapter; + function GetCommaText: WideString; + function GetDelimitedText: WideString; + function GetName(Index: Integer): WideString; + function GetValue(const Name: WideString): WideString; + procedure ReadData(Reader: TReader); + procedure SetCommaText(const Value: WideString); + procedure SetDelimitedText(const Value: WideString); + procedure SetStringsAdapter(const Value: IWideStringsAdapter); + procedure SetValue(const Name, Value: WideString); + procedure WriteData(Writer: TWriter); + function GetDelimiter: WideChar; + procedure SetDelimiter(const Value: WideChar); + function GetQuoteChar: WideChar; + procedure SetQuoteChar(const Value: WideChar); + function GetNameValueSeparator: WideChar; + {$IFDEF COMPILER_7_UP} + procedure SetNameValueSeparator(const Value: WideChar); + {$ENDIF} + function GetValueFromIndex(Index: Integer): WideString; + procedure SetValueFromIndex(Index: Integer; const Value: WideString); + protected + procedure AssignTo(Dest: TPersistent); override; + procedure DefineProperties(Filer: TFiler); override; + procedure Error(const Msg: WideString; Data: Integer); overload; + procedure Error(Msg: PResStringRec; Data: Integer); overload; + function ExtractName(const S: WideString): WideString; + function Get(Index: Integer): WideString; virtual; abstract; + function GetCapacity: Integer; virtual; + function GetCount: Integer; virtual; abstract; + function GetObject(Index: Integer): TObject; virtual; + function GetTextStr: WideString; virtual; + procedure Put(Index: Integer; const S: WideString); virtual; + procedure PutObject(Index: Integer; AObject: TObject); virtual; + procedure SetCapacity(NewCapacity: Integer); virtual; + procedure SetTextStr(const Value: WideString); virtual; + procedure SetUpdateState(Updating: Boolean); virtual; + property UpdateCount: Integer read FUpdateCount; + function CompareStrings(const S1, S2: WideString): Integer; virtual; + public + destructor Destroy; override; + function Add(const S: WideString): Integer; virtual; + function AddObject(const S: WideString; AObject: TObject): Integer; virtual; + procedure Append(const S: WideString); + procedure AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); overload; virtual; + procedure AddStrings(Strings: TWideStrings); overload; virtual; + procedure Assign(Source: TPersistent); override; + procedure BeginUpdate; + procedure Clear; virtual; abstract; + procedure Delete(Index: Integer); virtual; abstract; + procedure EndUpdate; + function Equals(Strings: TWideStrings): Boolean; + procedure Exchange(Index1, Index2: Integer); virtual; + function GetEnumerator: TWideStringsEnumerator; + function GetTextW: PWideChar; virtual; + function IndexOf(const S: WideString): Integer; virtual; + function IndexOfName(const Name: WideString): Integer; virtual; + function IndexOfObject(AObject: TObject): Integer; virtual; + procedure Insert(Index: Integer; const S: WideString); virtual; abstract; + procedure InsertObject(Index: Integer; const S: WideString; + AObject: TObject); virtual; + procedure LoadFromFile(const FileName: WideString); virtual; + procedure LoadFromStream(Stream: TStream); virtual; + procedure Move(CurIndex, NewIndex: Integer); virtual; + procedure SaveToFile(const FileName: WideString); virtual; + procedure SaveToStream(Stream: TStream); virtual; + procedure SetTextW(const Text: PWideChar); virtual; + property Capacity: Integer read GetCapacity write SetCapacity; + property CommaText: WideString read GetCommaText write SetCommaText; + property Count: Integer read GetCount; + property Delimiter: WideChar read GetDelimiter write SetDelimiter; + property DelimitedText: WideString read GetDelimitedText write SetDelimitedText; + property Names[Index: Integer]: WideString read GetName; + property Objects[Index: Integer]: TObject read GetObject write PutObject; + property QuoteChar: WideChar read GetQuoteChar write SetQuoteChar; + property Values[const Name: WideString]: WideString read GetValue write SetValue; + property ValueFromIndex[Index: Integer]: WideString read GetValueFromIndex write SetValueFromIndex; + property NameValueSeparator: WideChar read GetNameValueSeparator {$IFDEF COMPILER_7_UP} write SetNameValueSeparator {$ENDIF}; + property Strings[Index: Integer]: WideString read Get write Put; default; + property Text: WideString read GetTextStr write SetTextStr; + property StringsAdapter: IWideStringsAdapter read FAdapter write SetStringsAdapter; + end; + + PWideStringItem = ^TWideStringItem; + TWideStringItem = record + FString: WideString; + FObject: TObject; + end; + + PWideStringItemList = ^TWideStringItemList; + TWideStringItemList = array[0..MaxListSize] of TWideStringItem; + +implementation + +uses + Windows, SysUtils, TntSystem, {$IFDEF COMPILER_9_UP} WideStrUtils, {$ELSE} TntWideStrUtils, {$ENDIF} + TntSysUtils, TntClasses; + +{ TWideStringsEnumerator } + +constructor TWideStringsEnumerator.Create(AStrings: TWideStrings); +begin + inherited Create; + FIndex := -1; + FStrings := AStrings; +end; + +function TWideStringsEnumerator.GetCurrent: WideString; +begin + Result := FStrings[FIndex]; +end; + +function TWideStringsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FStrings.Count - 1; + if Result then + Inc(FIndex); +end; + +{ TWideStrings } + +destructor TWideStrings.Destroy; +begin + StringsAdapter := nil; + inherited; +end; + +function TWideStrings.Add(const S: WideString): Integer; +begin + Result := GetCount; + Insert(Result, S); +end; + +function TWideStrings.AddObject(const S: WideString; AObject: TObject): Integer; +begin + Result := Add(S); + PutObject(Result, AObject); +end; + +procedure TWideStrings.Append(const S: WideString); +begin + Add(S); +end; + +procedure TWideStrings.AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); +var + I: Integer; +begin + BeginUpdate; + try + for I := 0 to Strings.Count - 1 do + AddObject(Strings[I], Strings.Objects[I]); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.AddStrings(Strings: TWideStrings); +var + I: Integer; +begin + BeginUpdate; + try + for I := 0 to Strings.Count - 1 do + AddObject(Strings[I], Strings.Objects[I]); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.Assign(Source: TPersistent); +begin + if Source is TWideStrings then + begin + BeginUpdate; + try + Clear; + FDefined := TWideStrings(Source).FDefined; + {$IFDEF COMPILER_7_UP} + FNameValueSeparator := TWideStrings(Source).FNameValueSeparator; + {$ENDIF} + FQuoteChar := TWideStrings(Source).FQuoteChar; + FDelimiter := TWideStrings(Source).FDelimiter; + AddStrings(TWideStrings(Source)); + finally + EndUpdate; + end; + end + else if Source is TStrings{TNT-ALLOW TStrings} then + begin + BeginUpdate; + try + Clear; + {$IFDEF COMPILER_7_UP} + FNameValueSeparator := WideChar(TStrings{TNT-ALLOW TStrings}(Source).NameValueSeparator); + {$ENDIF} + FQuoteChar := WideChar(TStrings{TNT-ALLOW TStrings}(Source).QuoteChar); + FDelimiter := WideChar(TStrings{TNT-ALLOW TStrings}(Source).Delimiter); + AddStrings(TStrings{TNT-ALLOW TStrings}(Source)); + finally + EndUpdate; + end; + end + else + inherited Assign(Source); +end; + +procedure TWideStrings.AssignTo(Dest: TPersistent); +var + I: Integer; +begin + if Dest is TWideStrings then Dest.Assign(Self) + else if Dest is TStrings{TNT-ALLOW TStrings} then + begin + TStrings{TNT-ALLOW TStrings}(Dest).BeginUpdate; + try + TStrings{TNT-ALLOW TStrings}(Dest).Clear; + {$IFDEF COMPILER_7_UP} + TStrings{TNT-ALLOW TStrings}(Dest).NameValueSeparator := AnsiChar(NameValueSeparator); + {$ENDIF} + TStrings{TNT-ALLOW TStrings}(Dest).QuoteChar := AnsiChar(QuoteChar); + TStrings{TNT-ALLOW TStrings}(Dest).Delimiter := AnsiChar(Delimiter); + for I := 0 to Count - 1 do + TStrings{TNT-ALLOW TStrings}(Dest).AddObject(Strings[I], Objects[I]); + finally + TStrings{TNT-ALLOW TStrings}(Dest).EndUpdate; + end; + end + else + inherited AssignTo(Dest); +end; + +procedure TWideStrings.BeginUpdate; +begin + if FUpdateCount = 0 then SetUpdateState(True); + Inc(FUpdateCount); +end; + +procedure TWideStrings.DefineProperties(Filer: TFiler); + + function DoWrite: Boolean; + begin + if Filer.Ancestor <> nil then + begin + Result := True; + if Filer.Ancestor is TWideStrings then + Result := not Equals(TWideStrings(Filer.Ancestor)) + end + else Result := Count > 0; + end; + +begin + Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite); +end; + +procedure TWideStrings.EndUpdate; +begin + Dec(FUpdateCount); + if FUpdateCount = 0 then SetUpdateState(False); +end; + +function TWideStrings.Equals(Strings: TWideStrings): Boolean; +var + I, Count: Integer; +begin + Result := False; + Count := GetCount; + if Count <> Strings.GetCount then Exit; + for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit; + Result := True; +end; + +procedure TWideStrings.Error(const Msg: WideString; Data: Integer); + + function ReturnAddr: Pointer; + asm + MOV EAX,[EBP+4] + end; + +begin + raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr; +end; + +procedure TWideStrings.Error(Msg: PResStringRec; Data: Integer); +begin + Error(WideLoadResString(Msg), Data); +end; + +procedure TWideStrings.Exchange(Index1, Index2: Integer); +var + TempObject: TObject; + TempString: WideString; +begin + BeginUpdate; + try + TempString := Strings[Index1]; + TempObject := Objects[Index1]; + Strings[Index1] := Strings[Index2]; + Objects[Index1] := Objects[Index2]; + Strings[Index2] := TempString; + Objects[Index2] := TempObject; + finally + EndUpdate; + end; +end; + +function TWideStrings.ExtractName(const S: WideString): WideString; +var + P: Integer; +begin + Result := S; + P := Pos(NameValueSeparator, Result); + if P <> 0 then + SetLength(Result, P-1) else + SetLength(Result, 0); +end; + +function TWideStrings.GetCapacity: Integer; +begin // descendents may optionally override/replace this default implementation + Result := Count; +end; + +function TWideStrings.GetCommaText: WideString; +var + LOldDefined: TStringsDefined; + LOldDelimiter: WideChar; + LOldQuoteChar: WideChar; +begin + LOldDefined := FDefined; + LOldDelimiter := FDelimiter; + LOldQuoteChar := FQuoteChar; + Delimiter := ','; + QuoteChar := '"'; + try + Result := GetDelimitedText; + finally + FDelimiter := LOldDelimiter; + FQuoteChar := LOldQuoteChar; + FDefined := LOldDefined; + end; +end; + +function TWideStrings.GetDelimitedText: WideString; +var + S: WideString; + P: PWideChar; + I, Count: Integer; +begin + Count := GetCount; + if (Count = 1) and (Get(0) = '') then + Result := WideString(QuoteChar) + QuoteChar + else + begin + Result := ''; + for I := 0 to Count - 1 do + begin + S := Get(I); + P := PWideChar(S); + while not ((P^ in [WideChar(#0)..WideChar(' ')]) or (P^ = QuoteChar) or (P^ = Delimiter)) do + Inc(P); + if (P^ <> #0) then S := WideQuotedStr(S, QuoteChar); + Result := Result + S + Delimiter; + end; + System.Delete(Result, Length(Result), 1); + end; +end; + +function TWideStrings.GetName(Index: Integer): WideString; +begin + Result := ExtractName(Get(Index)); +end; + +function TWideStrings.GetObject(Index: Integer): TObject; +begin + Result := nil; +end; + +function TWideStrings.GetEnumerator: TWideStringsEnumerator; +begin + Result := TWideStringsEnumerator.Create(Self); +end; + +function TWideStrings.GetTextW: PWideChar; +begin + Result := WStrNew(PWideChar(GetTextStr)); +end; + +function TWideStrings.GetTextStr: WideString; +var + I, L, Size, Count: Integer; + P: PWideChar; + S, LB: WideString; +begin + Count := GetCount; + Size := 0; + LB := sLineBreak; + for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + Length(LB)); + SetString(Result, nil, Size); + P := Pointer(Result); + for I := 0 to Count - 1 do + begin + S := Get(I); + L := Length(S); + if L <> 0 then + begin + System.Move(Pointer(S)^, P^, L * SizeOf(WideChar)); + Inc(P, L); + end; + L := Length(LB); + if L <> 0 then + begin + System.Move(Pointer(LB)^, P^, L * SizeOf(WideChar)); + Inc(P, L); + end; + end; +end; + +function TWideStrings.GetValue(const Name: WideString): WideString; +var + I: Integer; +begin + I := IndexOfName(Name); + if I >= 0 then + Result := Copy(Get(I), Length(Name) + 2, MaxInt) else + Result := ''; +end; + +function TWideStrings.IndexOf(const S: WideString): Integer; +begin + for Result := 0 to GetCount - 1 do + if CompareStrings(Get(Result), S) = 0 then Exit; + Result := -1; +end; + +function TWideStrings.IndexOfName(const Name: WideString): Integer; +var + P: Integer; + S: WideString; +begin + for Result := 0 to GetCount - 1 do + begin + S := Get(Result); + P := Pos(NameValueSeparator, S); + if (P <> 0) and (CompareStrings(Copy(S, 1, P - 1), Name) = 0) then Exit; + end; + Result := -1; +end; + +function TWideStrings.IndexOfObject(AObject: TObject): Integer; +begin + for Result := 0 to GetCount - 1 do + if GetObject(Result) = AObject then Exit; + Result := -1; +end; + +procedure TWideStrings.InsertObject(Index: Integer; const S: WideString; + AObject: TObject); +begin + Insert(Index, S); + PutObject(Index, AObject); +end; + +procedure TWideStrings.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TWideStrings.LoadFromStream(Stream: TStream); +var + Size: Integer; + S: WideString; +begin + BeginUpdate; + try + Size := Stream.Size - Stream.Position; + SetString(S, nil, Size div SizeOf(WideChar)); + Stream.Read(Pointer(S)^, Length(S) * SizeOf(WideChar)); + SetTextStr(S); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.Move(CurIndex, NewIndex: Integer); +var + TempObject: TObject; + TempString: WideString; +begin + if CurIndex <> NewIndex then + begin + BeginUpdate; + try + TempString := Get(CurIndex); + TempObject := GetObject(CurIndex); + Delete(CurIndex); + InsertObject(NewIndex, TempString, TempObject); + finally + EndUpdate; + end; + end; +end; + +procedure TWideStrings.Put(Index: Integer; const S: WideString); +var + TempObject: TObject; +begin + TempObject := GetObject(Index); + Delete(Index); + InsertObject(Index, S, TempObject); +end; + +procedure TWideStrings.PutObject(Index: Integer; AObject: TObject); +begin +end; + +procedure TWideStrings.ReadData(Reader: TReader); +begin + if Reader.NextValue in [vaString, vaLString] then + SetTextStr(Reader.ReadString) {JCL compatiblity} + else if Reader.NextValue = vaWString then + SetTextStr(Reader.ReadWideString) {JCL compatiblity} + else begin + BeginUpdate; + try + Clear; + Reader.ReadListBegin; + while not Reader.EndOfList do + if Reader.NextValue in [vaString, vaLString] then + Add(Reader.ReadString) {TStrings compatiblity} + else + Add(Reader.ReadWideString); + Reader.ReadListEnd; + finally + EndUpdate; + end; + end; +end; + +procedure TWideStrings.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TWideStrings.SaveToStream(Stream: TStream); +var + SW: WideString; +begin + SW := GetTextStr; + Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); +end; + +procedure TWideStrings.SetCapacity(NewCapacity: Integer); +begin + // do nothing - descendents may optionally implement this method +end; + +procedure TWideStrings.SetCommaText(const Value: WideString); +begin + Delimiter := ','; + QuoteChar := '"'; + SetDelimitedText(Value); +end; + +procedure TWideStrings.SetStringsAdapter(const Value: IWideStringsAdapter); +begin + if FAdapter <> nil then FAdapter.ReleaseStrings; + FAdapter := Value; + if FAdapter <> nil then FAdapter.ReferenceStrings(Self); +end; + +procedure TWideStrings.SetTextW(const Text: PWideChar); +begin + SetTextStr(Text); +end; + +procedure TWideStrings.SetTextStr(const Value: WideString); +var + P, Start: PWideChar; + S: WideString; +begin + BeginUpdate; + try + Clear; + P := Pointer(Value); + if P <> nil then + while P^ <> #0 do + begin + Start := P; + while not (P^ in [WideChar(#0), WideChar(#10), WideChar(#13)]) and (P^ <> WideLineSeparator) do + Inc(P); + SetString(S, Start, P - Start); + Add(S); + if P^ = #13 then Inc(P); + if P^ = #10 then Inc(P); + if P^ = WideLineSeparator then Inc(P); + end; + finally + EndUpdate; + end; +end; + +procedure TWideStrings.SetUpdateState(Updating: Boolean); +begin +end; + +procedure TWideStrings.SetValue(const Name, Value: WideString); +var + I: Integer; +begin + I := IndexOfName(Name); + if Value <> '' then + begin + if I < 0 then I := Add(''); + Put(I, Name + NameValueSeparator + Value); + end else + begin + if I >= 0 then Delete(I); + end; +end; + +procedure TWideStrings.WriteData(Writer: TWriter); +var + I: Integer; +begin + Writer.WriteListBegin; + for I := 0 to Count-1 do begin + Writer.WriteWideString(Get(I)); + end; + Writer.WriteListEnd; +end; + +procedure TWideStrings.SetDelimitedText(const Value: WideString); +var + P, P1: PWideChar; + S: WideString; +begin + BeginUpdate; + try + Clear; + P := PWideChar(Value); + while P^ in [WideChar(#1)..WideChar(' ')] do + Inc(P); + while P^ <> #0 do + begin + if P^ = QuoteChar then + S := WideExtractQuotedStr(P, QuoteChar) + else + begin + P1 := P; + while (P^ > ' ') and (P^ <> Delimiter) do + Inc(P); + SetString(S, P1, P - P1); + end; + Add(S); + while P^ in [WideChar(#1)..WideChar(' ')] do + Inc(P); + if P^ = Delimiter then + begin + P1 := P; + Inc(P1); + if P1^ = #0 then + Add(''); + repeat + Inc(P); + until not (P^ in [WideChar(#1)..WideChar(' ')]); + end; + end; + finally + EndUpdate; + end; +end; + +function TWideStrings.GetDelimiter: WideChar; +begin + if not (sdDelimiter in FDefined) then + Delimiter := ','; + Result := FDelimiter; +end; + +function TWideStrings.GetQuoteChar: WideChar; +begin + if not (sdQuoteChar in FDefined) then + QuoteChar := '"'; + Result := FQuoteChar; +end; + +procedure TWideStrings.SetDelimiter(const Value: WideChar); +begin + if (FDelimiter <> Value) or not (sdDelimiter in FDefined) then + begin + Include(FDefined, sdDelimiter); + FDelimiter := Value; + end +end; + +procedure TWideStrings.SetQuoteChar(const Value: WideChar); +begin + if (FQuoteChar <> Value) or not (sdQuoteChar in FDefined) then + begin + Include(FDefined, sdQuoteChar); + FQuoteChar := Value; + end +end; + +function TWideStrings.CompareStrings(const S1, S2: WideString): Integer; +begin + Result := WideCompareText(S1, S2); +end; + +function TWideStrings.GetNameValueSeparator: WideChar; +begin + {$IFDEF COMPILER_7_UP} + if not (sdNameValueSeparator in FDefined) then + NameValueSeparator := '='; + Result := FNameValueSeparator; + {$ELSE} + Result := '='; + {$ENDIF} +end; + +{$IFDEF COMPILER_7_UP} +procedure TWideStrings.SetNameValueSeparator(const Value: WideChar); +begin + if (FNameValueSeparator <> Value) or not (sdNameValueSeparator in FDefined) then + begin + Include(FDefined, sdNameValueSeparator); + FNameValueSeparator := Value; + end +end; +{$ENDIF} + +function TWideStrings.GetValueFromIndex(Index: Integer): WideString; +begin + if Index >= 0 then + Result := Copy(Get(Index), Length(Names[Index]) + 2, MaxInt) else + Result := ''; +end; + +procedure TWideStrings.SetValueFromIndex(Index: Integer; const Value: WideString); +begin + if Value <> '' then + begin + if Index < 0 then Index := Add(''); + Put(Index, Names[Index] + NameValueSeparator + Value); + end + else + if Index >= 0 then Delete(Index); +end; + +end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas new file mode 100644 index 0000000000..12d74d8344 --- /dev/null +++ b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas @@ -0,0 +1,1452 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntWindows; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Windows, ShellApi, ShlObj; + +// ......... compatibility + +const + DT_NOFULLWIDTHCHARBREAK = $00080000; + +const + INVALID_FILE_ATTRIBUTES = DWORD(-1); + +// ................ ANSI TYPES ................ +{TNT-WARN LPSTR} +{TNT-WARN PLPSTR} +{TNT-WARN LPCSTR} +{TNT-WARN LPCTSTR} +{TNT-WARN LPTSTR} + +// ........ EnumResourceTypesW, EnumResourceNamesW and EnumResourceLanguagesW are supposed .... +// ........ to work on Win95/98/ME but have caused access violations in testing on Win95 ...... +// .. TNT--WARN EnumResourceTypes .. +// .. TNT--WARN EnumResourceTypesA .. +// .. TNT--WARN EnumResourceNames .. +// .. TNT--WARN EnumResourceNamesA .. +// .. TNT--WARN EnumResourceLanguages .. +// .. TNT--WARN EnumResourceLanguagesA .. + +//------------------------------------------------------------------------------------------ + +// ......... The Unicode form of these functions are supported on Windows 95/98/ME ......... +{TNT-WARN ExtTextOut} +{TNT-WARN ExtTextOutA} +{TNT-WARN Tnt_ExtTextOutW} + +{TNT-WARN FindResource} +{TNT-WARN FindResourceA} +{TNT-WARN Tnt_FindResourceW} + +{TNT-WARN FindResourceEx} +{TNT-WARN FindResourceExA} +{TNT-WARN Tnt_FindResourceExW} + +{TNT-WARN GetCharWidth} +{TNT-WARN GetCharWidthA} +{TNT-WARN Tnt_GetCharWidthW} + +{TNT-WARN GetCommandLine} +{TNT-WARN GetCommandLineA} +{TNT-WARN Tnt_GetCommandLineW} + +{TNT-WARN GetTextExtentPoint} +{TNT-WARN GetTextExtentPointA} +{TNT-WARN Tnt_GetTextExtentPointW} + +{TNT-WARN GetTextExtentPoint32} +{TNT-WARN GetTextExtentPoint32A} +{TNT-WARN Tnt_GetTextExtentPoint32W} + +{TNT-WARN lstrcat} +{TNT-WARN lstrcatA} +{TNT-WARN Tnt_lstrcatW} + +{TNT-WARN lstrcpy} +{TNT-WARN lstrcpyA} +{TNT-WARN Tnt_lstrcpyW} + +{TNT-WARN lstrlen} +{TNT-WARN lstrlenA} +{TNT-WARN Tnt_lstrlenW} + +{TNT-WARN MessageBox} +{TNT-WARN MessageBoxA} +{TNT-WARN Tnt_MessageBoxW} + +{TNT-WARN MessageBoxEx} +{TNT-WARN MessageBoxExA} +{TNT-WARN Tnt_MessageBoxExA} + +{TNT-WARN TextOut} +{TNT-WARN TextOutA} +{TNT-WARN Tnt_TextOutW} + +//------------------------------------------------------------------------------------------ + +{TNT-WARN LOCALE_USER_DEFAULT} // <-- use GetThreadLocale +{TNT-WARN LOCALE_SYSTEM_DEFAULT} // <-- use GetThreadLocale + +//------------------------------------------------------------------------------------------ +// compatiblity +//------------------------------------------------------------------------------------------ +{$IFNDEF COMPILER_9_UP} +type + TStartupInfoA = _STARTUPINFOA; + TStartupInfoW = record + cb: DWORD; + lpReserved: PWideChar; + lpDesktop: PWideChar; + lpTitle: PWideChar; + dwX: DWORD; + dwY: DWORD; + dwXSize: DWORD; + dwYSize: DWORD; + dwXCountChars: DWORD; + dwYCountChars: DWORD; + dwFillAttribute: DWORD; + dwFlags: DWORD; + wShowWindow: Word; + cbReserved2: Word; + lpReserved2: PByte; + hStdInput: THandle; + hStdOutput: THandle; + hStdError: THandle; + end; + +function CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName: PWideChar; lpCommandLine: PWideChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; + var lpProcessInformation: TProcessInformation): BOOL; stdcall; external kernel32 name 'CreateProcessW'; + +{$ENDIF} +//------------------------------------------------------------------------------------------ + +{TNT-WARN SetWindowText} +{TNT-WARN SetWindowTextA} +{TNT-WARN SetWindowTextW} +function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; + +{TNT-WARN RemoveDirectory} +{TNT-WARN RemoveDirectoryA} +{TNT-WARN RemoveDirectoryW} +function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; + +{TNT-WARN GetShortPathName} +{TNT-WARN GetShortPathNameA} +{TNT-WARN GetShortPathNameW} +function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; + cchBuffer: DWORD): DWORD; + +{TNT-WARN GetFullPathName} +{TNT-WARN GetFullPathNameA} +{TNT-WARN GetFullPathNameW} +function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; + lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; + +{TNT-WARN CreateFile} +{TNT-WARN CreateFileA} +{TNT-WARN CreateFileW} +function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; + lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; + hTemplateFile: THandle): THandle; + +{TNT-WARN FindFirstFile} +{TNT-WARN FindFirstFileA} +{TNT-WARN FindFirstFileW} +function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; + +{TNT-WARN FindNextFile} +{TNT-WARN FindNextFileA} +{TNT-WARN FindNextFileW} +function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; + +{TNT-WARN GetFileAttributes} +{TNT-WARN GetFileAttributesA} +{TNT-WARN GetFileAttributesW} +function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; + +{TNT-WARN SetFileAttributes} +{TNT-WARN SetFileAttributesA} +{TNT-WARN SetFileAttributesW} +function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; + +{TNT-WARN CreateDirectory} +{TNT-WARN CreateDirectoryA} +{TNT-WARN CreateDirectoryW} +function Tnt_CreateDirectoryW(lpPathName: PWideChar; + lpSecurityAttributes: PSecurityAttributes): BOOL; + +{TNT-WARN MoveFile} +{TNT-WARN MoveFileA} +{TNT-WARN MoveFileW} +function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; + +{TNT-WARN CopyFile} +{TNT-WARN CopyFileA} +{TNT-WARN CopyFileW} +function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; + +{TNT-WARN DeleteFile} +{TNT-WARN DeleteFileA} +{TNT-WARN DeleteFileW} +function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; + +{TNT-WARN DrawText} +{TNT-WARN DrawTextA} +{TNT-WARN DrawTextW} +function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; + var lpRect: TRect; uFormat: UINT): Integer; + +{TNT-WARN GetDiskFreeSpace} +{TNT-WARN GetDiskFreeSpaceA} +{TNT-WARN GetDiskFreeSpaceW} +function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, + lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; + +{TNT-WARN GetVolumeInformation} +{TNT-WARN GetVolumeInformationA} +{TNT-WARN GetVolumeInformationW} +function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; + nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; + var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; + nFileSystemNameSize: DWORD): BOOL; + +{TNT-WARN GetModuleFileName} +{TNT-WARN GetModuleFileNameA} +{TNT-WARN GetModuleFileNameW} +function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; + +{TNT-WARN GetTempPath} +{TNT-WARN GetTempPathA} +{TNT-WARN GetTempPathW} +function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; + +{TNT-WARN GetTempFileName} +{TNT-WARN GetTempFileNameA} +{TNT-WARN GetTempFileNameW} +function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; + lpTempFileName: PWideChar): UINT; + +{TNT-WARN GetWindowsDirectory} +{TNT-WARN GetWindowsDirectoryA} +{TNT-WARN GetWindowsDirectoryW} +function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; + +{TNT-WARN GetSystemDirectory} +{TNT-WARN GetSystemDirectoryA} +{TNT-WARN GetSystemDirectoryW} +function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; + +{TNT-WARN GetCurrentDirectory} +{TNT-WARN GetCurrentDirectoryA} +{TNT-WARN GetCurrentDirectoryW} +function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; + +{TNT-WARN SetCurrentDirectory} +{TNT-WARN SetCurrentDirectoryA} +{TNT-WARN SetCurrentDirectoryW} +function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; + +{TNT-WARN GetComputerName} +{TNT-WARN GetComputerNameA} +{TNT-WARN GetComputerNameW} +function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; + +{TNT-WARN GetUserName} +{TNT-WARN GetUserNameA} +{TNT-WARN GetUserNameW} +function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; + +{TNT-WARN ShellExecute} +{TNT-WARN ShellExecuteA} +{TNT-WARN ShellExecuteW} +function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, + Directory: PWideChar; ShowCmd: Integer): HINST; + +{TNT-WARN LoadLibrary} +{TNT-WARN LoadLibraryA} +{TNT-WARN LoadLibraryW} +function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; + +{TNT-WARN LoadLibraryEx} +{TNT-WARN LoadLibraryExA} +{TNT-WARN LoadLibraryExW} +function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; + +{TNT-WARN CreateProcess} +{TNT-WARN CreateProcessA} +{TNT-WARN CreateProcessW} +function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; + var lpProcessInformation: TProcessInformation): BOOL; + +{TNT-WARN GetCurrencyFormat} +{TNT-WARN GetCurrencyFormatA} +{TNT-WARN GetCurrencyFormatW} +function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; + lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; + +{TNT-WARN CompareString} +{TNT-WARN CompareStringA} +{TNT-WARN CompareStringW} +function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; + cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; + +{TNT-WARN CharUpper} +{TNT-WARN CharUpperA} +{TNT-WARN CharUpperW} +function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; + +{TNT-WARN CharUpperBuff} +{TNT-WARN CharUpperBuffA} +{TNT-WARN CharUpperBuffW} +function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; + +{TNT-WARN CharLower} +{TNT-WARN CharLowerA} +{TNT-WARN CharLowerW} +function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; + +{TNT-WARN CharLowerBuff} +{TNT-WARN CharLowerBuffA} +{TNT-WARN CharLowerBuffW} +function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; + +{TNT-WARN GetStringTypeEx} +{TNT-WARN GetStringTypeExA} +{TNT-WARN GetStringTypeExW} +function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; + lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; + +{TNT-WARN LoadString} +{TNT-WARN LoadStringA} +{TNT-WARN LoadStringW} +function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; + +{TNT-WARN InsertMenuItem} +{TNT-WARN InsertMenuItemA} +{TNT-WARN InsertMenuItemW} +function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: tagMenuItemINFOW): BOOL; + +{TNT-WARN ExtractIconEx} +{TNT-WARN ExtractIconExA} +{TNT-WARN ExtractIconExW} +function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; + var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; + +{TNT-WARN ExtractAssociatedIcon} +{TNT-WARN ExtractAssociatedIconA} +{TNT-WARN ExtractAssociatedIconW} +function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; + var lpiIcon: Word): HICON; + +{TNT-WARN GetFileVersionInfoSize} +{TNT-WARN GetFileVersionInfoSizeA} +{TNT-WARN GetFileVersionInfoSizeW} +function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; + +{TNT-WARN GetFileVersionInfo} +{TNT-WARN GetFileVersionInfoA} +{TNT-WARN GetFileVersionInfoW} +function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; + lpData: Pointer): BOOL; + +const + VQV_FIXEDFILEINFO = '\'; + VQV_VARFILEINFO_TRANSLATION = '\VarFileInfo\Translation'; + VQV_STRINGFILEINFO = '\StringFileInfo'; + + VER_COMMENTS = 'Comments'; + VER_INTERNALNAME = 'InternalName'; + VER_PRODUCTNAME = 'ProductName'; + VER_COMPANYNAME = 'CompanyName'; + VER_LEGALCOPYRIGHT = 'LegalCopyright'; + VER_PRODUCTVERSION = 'ProductVersion'; + VER_FILEDESCRIPTION = 'FileDescription'; + VER_LEGALTRADEMARKS = 'LegalTrademarks'; + VER_PRIVATEBUILD = 'PrivateBuild'; + VER_FILEVERSION = 'FileVersion'; + VER_ORIGINALFILENAME = 'OriginalFilename'; + VER_SPECIALBUILD = 'SpecialBuild'; + +{TNT-WARN VerQueryValue} +{TNT-WARN VerQueryValueA} +{TNT-WARN VerQueryValueW} +function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; + var lplpBuffer: Pointer; var puLen: UINT): BOOL; + +type + TSHNameMappingHeaderA = record + cNumOfMappings: Cardinal; + lpNM: PSHNAMEMAPPINGA; + end; + PSHNameMappingHeaderA = ^TSHNameMappingHeaderA; + + TSHNameMappingHeaderW = record + cNumOfMappings: Cardinal; + lpNM: PSHNAMEMAPPINGW; + end; + PSHNameMappingHeaderW = ^TSHNameMappingHeaderW; + +{TNT-WARN SHFileOperation} +{TNT-WARN SHFileOperationA} +{TNT-WARN SHFileOperationW} // <-- no stub on early Windows 95 +function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; + +{TNT-WARN SHFreeNameMappings} +procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); + +{TNT-WARN SHBrowseForFolder} +{TNT-WARN SHBrowseForFolderA} +{TNT-WARN SHBrowseForFolderW} // <-- no stub on early Windows 95 +function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; + +{TNT-WARN SHGetPathFromIDList} +{TNT-WARN SHGetPathFromIDListA} +{TNT-WARN SHGetPathFromIDListW} // <-- no stub on early Windows 95 +function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; + +{TNT-WARN SHGetFileInfo} +{TNT-WARN SHGetFileInfoA} +{TNT-WARN SHGetFileInfoW} // <-- no stub on early Windows 95 +function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; + var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; + +// ......... introduced ......... +function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; + +function LANGIDFROMLCID(lcid: LCID): WORD; +function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; +function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; +function PRIMARYLANGID(lgid: WORD): WORD; +function SORTIDFROMLCID(lcid: LCID): WORD; +function SUBLANGID(lgid: WORD): WORD; + +implementation + +uses + SysUtils, Math, TntSysUtils, + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; + +function _PAnsiCharWithNil(const S: AnsiString): PAnsiChar; +begin + if S = '' then + Result := nil {Win9x needs nil for some parameters instead of empty strings} + else + Result := PAnsiChar(S); +end; + +function _PWideCharWithNil(const S: WideString): PWideChar; +begin + if S = '' then + Result := nil {Win9x needs nil for some parameters instead of empty strings} + else + Result := PWideChar(S); +end; + +function _WStr(lpString: PWideChar; cchCount: Integer): WideString; +begin + if cchCount = -1 then + Result := lpString + else + Result := Copy(WideString(lpString), 1, cchCount); +end; + +procedure _MakeWideWin32FindData(var WideFindData: TWIN32FindDataW; AnsiFindData: TWIN32FindDataA); +begin + CopyMemory(@WideFindData, @AnsiFindData, + Integer(@WideFindData.cFileName) - Integer(@WideFindData)); + WStrPCopy(WideFindData.cFileName, AnsiFindData.cFileName); + WStrPCopy(WideFindData.cAlternateFileName, AnsiFindData.cAlternateFileName); +end; + +function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := SetWindowTextW{TNT-ALLOW SetWindowTextW}(hWnd, lpString) + else + Result := SetWindowTextA{TNT-ALLOW SetWindowTextA}(hWnd, PAnsiChar(AnsiString(lpString))); +end; + +//----------------------------- + +type + TPathLengthResultOption = (poAllowDirectoryMode, poZeroSmallBuff, poExactCopy, poExactCopySubPaths); + TPathLengthResultOptions = set of TPathLengthResultOption; + +procedure _ExactStrCopyW(pDest, pSource: PWideChar; Count: Integer); +var + i: integer; +begin + for i := 1 to Count do begin + pDest^ := pSource^; + Inc(PSource); + Inc(pDest); + end; +end; + +procedure _ExactCopySubPaths(pDest, pSource: PWideChar; Count: Integer); +var + i: integer; + OriginalSource: PWideChar; + PNextSlash: PWideChar; +begin + if Count >= 4 then begin + OriginalSource := pSource; + PNextSlash := WStrScan(pSource, '\'); + for i := 1 to Count - 1 do begin + // determine next path delimiter + if pSource > pNextSlash then begin + PNextSlash := WStrScan(pSource, '\'); + end; + // leave if no more sub paths + if (PNextSlash = nil) + or ((pNextSlash - OriginalSource) >= Count) then begin + exit; + end; + // copy char + pDest^ := pSource^; + Inc(PSource); + Inc(pDest); + end; + end; +end; + +function _HandlePathLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; +var + WideBuff: WideString; +begin + WideBuff := AnsiBuff; + if nBufferLength > Cardinal(Length(WideBuff)) then begin + // normal + Result := Length(WideBuff); + WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); + end else if (poExactCopy in Options) then begin + // exact + Result := nBufferLength; + _ExactStrCopyW(lpBuffer, PWideChar(WideBuff), nBufferLength); + end else begin + // other + if (poAllowDirectoryMode in Options) + and (nBufferLength = Cardinal(Length(WideBuff))) then begin + Result := Length(WideBuff) + 1; + WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength - 1); + end else begin + Result := Length(WideBuff) + 1; + if (nBufferLength > 0) then begin + if (poZeroSmallBuff in Options) then + lpBuffer^ := #0 + else if (poExactCopySubPaths in Options) then + _ExactCopySubPaths(lpBuffer, PWideChar(WideBuff), nBufferLength); + end; + end; + end; +end; + +function _HandleStringLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; +var + WideBuff: WideString; +begin + WideBuff := AnsiBuff; + if nBufferLength >= Cardinal(Length(WideBuff)) then begin + // normal + Result := Length(WideBuff); + WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); + end else if nBufferLength = 0 then + Result := Length(WideBuff) + else + Result := 0; +end; + +//------------------------------------------- + +function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := RemoveDirectoryW{TNT-ALLOW RemoveDirectoryW}(PWideChar(lpPathName)) + else + Result := RemoveDirectoryA{TNT-ALLOW RemoveDirectoryA}(PAnsiChar(AnsiString(lpPathName))); +end; + +function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; + cchBuffer: DWORD): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetShortPathNameW{TNT-ALLOW GetShortPathNameW}(lpszLongPath, lpszShortPath, cchBuffer) + else begin + SetLength(AnsiBuff, MAX_PATH * 2); + SetLength(AnsiBuff, GetShortPathNameA{TNT-ALLOW GetShortPathNameA}(PAnsiChar(AnsiString(lpszLongPath)), + PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(cchBuffer, lpszShortPath, AnsiBuff, [poExactCopySubPaths]); + end; +end; + +function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; + lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; +var + AnsiBuff: AnsiString; + AnsiFilePart: PAnsiChar; + AnsiLeadingChars: Integer; + WideLeadingChars: Integer; +begin + if Win32PlatformIsUnicode then + Result := GetFullPathNameW{TNT-ALLOW GetFullPathNameW}(lpFileName, nBufferLength, lpBuffer, lpFilePart) + else begin + SetLength(AnsiBuff, MAX_PATH * 2); + SetLength(AnsiBuff, GetFullPathNameA{TNT-ALLOW GetFullPathNameA}(PAnsiChar(AnsiString(lpFileName)), + Length(AnsiBuff), PAnsiChar(AnsiBuff), AnsiFilePart)); + Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poZeroSmallBuff]); + // deal w/ lpFilePart + if (AnsiFilePart = nil) or (nBufferLength < Result) then + lpFilePart := nil + else begin + AnsiLeadingChars := AnsiFilePart - PAnsiChar(AnsiBuff); + WideLeadingChars := Length(WideString(Copy(AnsiBuff, 1, AnsiLeadingChars))); + lpFilePart := lpBuffer + WideLeadingChars; + end; + end; +end; + +function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; + lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; + hTemplateFile: THandle): THandle; +begin + if Win32PlatformIsUnicode then + Result := CreateFileW{TNT-ALLOW CreateFileW}(lpFileName, dwDesiredAccess, dwShareMode, + lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) + else + Result := CreateFileA{TNT-ALLOW CreateFileA}(PAnsiChar(AnsiString(lpFileName)), dwDesiredAccess, dwShareMode, + lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) +end; + +function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; +var + Ansi_lpFindFileData: TWIN32FindDataA; +begin + if Win32PlatformIsUnicode then + Result := FindFirstFileW{TNT-ALLOW FindFirstFileW}(lpFileName, lpFindFileData) + else begin + Result := FindFirstFileA{TNT-ALLOW FindFirstFileA}(PAnsiChar(AnsiString(lpFileName)), + Ansi_lpFindFileData); + if Result <> INVALID_HANDLE_VALUE then + _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); + end; +end; + +function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; +var + Ansi_lpFindFileData: TWIN32FindDataA; +begin + if Win32PlatformIsUnicode then + Result := FindNextFileW{TNT-ALLOW FindNextFileW}(hFindFile, lpFindFileData) + else begin + Result := FindNextFileA{TNT-ALLOW FindNextFileA}(hFindFile, Ansi_lpFindFileData); + if Result then + _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); + end; +end; + +function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetFileAttributesW{TNT-ALLOW GetFileAttributesW}(lpFileName) + else + Result := GetFileAttributesA{TNT-ALLOW GetFileAttributesA}(PAnsiChar(AnsiString(lpFileName))); +end; + +function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; +begin + if Win32PlatformIsUnicode then + Result := SetFileAttributesW{TNT-ALLOW SetFileAttributesW}(lpFileName, dwFileAttributes) + else + Result := SetFileAttributesA{TNT-ALLOW SetFileAttributesA}(PAnsiChar(AnsiString(lpFileName)), dwFileAttributes); +end; + +function Tnt_CreateDirectoryW(lpPathName: PWideChar; + lpSecurityAttributes: PSecurityAttributes): BOOL; +begin + if Win32PlatformIsUnicode then + Result := CreateDirectoryW{TNT-ALLOW CreateDirectoryW}(lpPathName, lpSecurityAttributes) + else + Result := CreateDirectoryA{TNT-ALLOW CreateDirectoryA}(PAnsiChar(AnsiString(lpPathName)), lpSecurityAttributes); +end; + +function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := MoveFileW{TNT-ALLOW MoveFileW}(lpExistingFileName, lpNewFileName) + else + Result := MoveFileA{TNT-ALLOW MoveFileA}(PAnsiChar(AnsiString(lpExistingFileName)), PAnsiChar(AnsiString(lpNewFileName))); +end; + +function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; +begin + if Win32PlatformIsUnicode then + Result := CopyFileW{TNT-ALLOW CopyFileW}(lpExistingFileName, lpNewFileName, bFailIfExists) + else + Result := CopyFileA{TNT-ALLOW CopyFileA}(PAnsiChar(AnsiString(lpExistingFileName)), + PAnsiChar(AnsiString(lpNewFileName)), bFailIfExists); +end; + +function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := DeleteFileW{TNT-ALLOW DeleteFileW}(lpFileName) + else + Result := DeleteFileA{TNT-ALLOW DeleteFileA}(PAnsiChar(AnsiString(lpFileName))); +end; + +function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; + var lpRect: TRect; uFormat: UINT): Integer; +begin + if Win32PlatformIsUnicode then + Result := DrawTextW{TNT-ALLOW DrawTextW}(hDC, lpString, nCount, lpRect, uFormat) + else + Result := DrawTextA{TNT-ALLOW DrawTextA}(hDC, + PAnsiChar(AnsiString(_WStr(lpString, nCount))), -1, lpRect, uFormat); +end; + +function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, + lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; +begin + if Win32PlatformIsUnicode then + Result := GetDiskFreeSpaceW{TNT-ALLOW GetDiskFreeSpaceW}(lpRootPathName, + lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) + else + Result := GetDiskFreeSpaceA{TNT-ALLOW GetDiskFreeSpaceA}(PAnsiChar(AnsiString(lpRootPathName)), + lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) +end; + +function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; + nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; + var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; + nFileSystemNameSize: DWORD): BOOL; +var + AnsiFileSystemNameBuffer: AnsiString; + AnsiVolumeNameBuffer: AnsiString; + AnsiBuffLen: DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetVolumeInformationW{TNT-ALLOW GetVolumeInformationW}(lpRootPathName, lpVolumeNameBuffer, nVolumeNameSize, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, lpFileSystemNameBuffer, nFileSystemNameSize) + else begin + SetLength(AnsiVolumeNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); + SetLength(AnsiFileSystemNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); + AnsiBuffLen := Length(AnsiFileSystemNameBuffer); + Result := GetVolumeInformationA{TNT-ALLOW GetVolumeInformationA}(PAnsiChar(AnsiString(lpRootPathName)), PAnsiChar(AnsiVolumeNameBuffer), AnsiBuffLen, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, PAnsiChar(AnsiFileSystemNameBuffer), AnsiBuffLen); + if Result then begin + SetLength(AnsiFileSystemNameBuffer, AnsiBuffLen); + if (nFileSystemNameSize <= AnsiBuffLen) or (Length(AnsiFileSystemNameBuffer) = 0) then + Result := False + else begin + WStrPLCopy(lpFileSystemNameBuffer, AnsiFileSystemNameBuffer, nFileSystemNameSize); + WStrPLCopy(lpVolumeNameBuffer, AnsiVolumeNameBuffer, nVolumeNameSize); + end; + end; + end; +end; + +function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetModuleFileNameW{TNT-ALLOW GetModuleFileNameW}(hModule, lpFilename, nSize) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetModuleFileNameA{TNT-ALLOW GetModuleFileNameA}(hModule, PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(nSize, lpFilename, AnsiBuff, [poExactCopy]); + end; +end; + +function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetTempPathW{TNT-ALLOW GetTempPathW}(nBufferLength, lpBuffer) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetTempPathA{TNT-ALLOW GetTempPathA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); + Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); + end; +end; + +function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; + lpTempFileName: PWideChar): UINT; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetTempFileNameW{TNT-ALLOW GetTempFileNameW}(lpPathName, lpPrefixString, uUnique, lpTempFileName) + else begin + SetLength(AnsiBuff, MAX_PATH); + Result := GetTempFileNameA{TNT-ALLOW GetTempFileNameA}(PAnsiChar(AnsiString(lpPathName)), PAnsiChar(lpPrefixString), uUnique, PAnsiChar(AnsiBuff)); + AnsiBuff := PAnsiChar(AnsiBuff); + _HandlePathLengthResult(MAX_PATH, lpTempFileName, AnsiBuff, [poZeroSmallBuff]); + end; +end; + +function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetWindowsDirectoryW{TNT-ALLOW GetWindowsDirectoryW}(lpBuffer, uSize) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetWindowsDirectoryA{TNT-ALLOW GetWindowsDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); + end; +end; + +function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetSystemDirectoryW{TNT-ALLOW GetSystemDirectoryW}(lpBuffer, uSize) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetSystemDirectoryA{TNT-ALLOW GetSystemDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); + end; +end; + +function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetCurrentDirectoryW{TNT-ALLOW GetCurrentDirectoryW}(nBufferLength, lpBuffer) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetCurrentDirectoryA{TNT-ALLOW GetCurrentDirectoryA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); + Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); + end; +end; + +function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := SetCurrentDirectoryW{TNT-ALLOW SetCurrentDirectoryW}(lpPathName) + else + Result := SetCurrentDirectoryA{TNT-ALLOW SetCurrentDirectoryA}(PAnsiChar(AnsiString(lpPathName))); +end; + +function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; +var + AnsiBuff: AnsiString; + AnsiBuffLen: DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetComputerNameW{TNT-ALLOW GetComputerNameW}(lpBuffer, nSize) + else begin + SetLength(AnsiBuff, MAX_COMPUTERNAME_LENGTH + 1); + AnsiBuffLen := Length(AnsiBuff); + Result := GetComputerNameA{TNT-ALLOW GetComputerNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); + if Result then begin + SetLength(AnsiBuff, AnsiBuffLen); + if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin + nSize := AnsiBuffLen + 1; + Result := False; + end else begin + WStrPLCopy(lpBuffer, AnsiBuff, nSize); + nSize := WStrLen(lpBuffer); + end; + end; + end; +end; + +function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; +var + AnsiBuff: AnsiString; + AnsiBuffLen: DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetUserNameW{TNT-ALLOW GetUserNameW}(lpBuffer, nSize) + else begin + SetLength(AnsiBuff, 255); + AnsiBuffLen := Length(AnsiBuff); + Result := GetUserNameA{TNT-ALLOW GetUserNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); + if Result then begin + SetLength(AnsiBuff, AnsiBuffLen); + if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin + nSize := AnsiBuffLen + 1; + Result := False; + end else begin + WStrPLCopy(lpBuffer, AnsiBuff, nSize); + nSize := WStrLen(lpBuffer); + end; + end; + end; +end; + +function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, + Directory: PWideChar; ShowCmd: Integer): HINST; +begin + if Win32PlatformIsUnicode then + Result := ShellExecuteW{TNT-ALLOW ShellExecuteW}(hWnd, _PWideCharWithNil(WideString(Operation)), + FileName, Parameters, + Directory, ShowCmd) + else begin + Result := ShellExecuteA{TNT-ALLOW ShellExecuteA}(hWnd, _PAnsiCharWithNil(AnsiString(Operation)), + _PAnsiCharWithNil(AnsiString(FileName)), _PAnsiCharWithNil(AnsiString(Parameters)), + _PAnsiCharWithNil(AnsiString(Directory)), ShowCmd) + end; +end; + +function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; +begin + if Win32PlatformIsUnicode then + Result := LoadLibraryW{TNT-ALLOW LoadLibraryW}(lpLibFileName) + else + Result := LoadLibraryA{TNT-ALLOW LoadLibraryA}(PAnsiChar(AnsiString(lpLibFileName))); +end; + +function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; +begin + if Win32PlatformIsUnicode then + Result := LoadLibraryExW{TNT-ALLOW LoadLibraryExW}(lpLibFileName, hFile, dwFlags) + else + Result := LoadLibraryExA{TNT-ALLOW LoadLibraryExA}(PAnsiChar(AnsiString(lpLibFileName)), hFile, dwFlags); +end; + +function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; + var lpProcessInformation: TProcessInformation): BOOL; +var + AnsiStartupInfo: TStartupInfoA; +begin + if Win32PlatformIsUnicode then begin + Result := CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName, lpCommandLine, + lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, + lpCurrentDirectory, lpStartupInfo, lpProcessInformation) + end else begin + CopyMemory(@AnsiStartupInfo, @lpStartupInfo, SizeOf(TStartupInfo)); + AnsiStartupInfo.lpReserved := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpReserved)); + AnsiStartupInfo.lpDesktop := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpDesktop)); + AnsiStartupInfo.lpTitle := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpTitle)); + Result := CreateProcessA{TNT-ALLOW CreateProcessA}(_PAnsiCharWithNil(AnsiString(lpApplicationName)), + _PAnsiCharWithNil(AnsiString(lpCommandLine)), + lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, + _PAnsiCharWithNil(AnsiString(lpCurrentDirectory)), AnsiStartupInfo, lpProcessInformation); + end; +end; + +function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; + lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; +const + MAX_ANSI_BUFF_SIZE = 64; // can a currency string actually be larger? +var + AnsiFormat: TCurrencyFmtA; + PAnsiFormat: PCurrencyFmtA; + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetCurrencyFormatW{TNT-ALLOW GetCurrencyFormatW}(Locale, dwFlags, lpValue, lpFormat, lpCurrencyStr, cchCurrency) + else begin + if lpFormat = nil then + PAnsiFormat := nil + else begin + ZeroMemory(@AnsiFormat, SizeOf(AnsiFormat)); + AnsiFormat.NumDigits := lpFormat.NumDigits; + AnsiFormat.LeadingZero := lpFormat.LeadingZero; + AnsiFormat.Grouping := lpFormat.Grouping; + AnsiFormat.lpDecimalSep := PAnsiChar(AnsiString(lpFormat.lpDecimalSep)); + AnsiFormat.lpThousandSep := PAnsiChar(AnsiString(lpFormat.lpThousandSep)); + AnsiFormat.NegativeOrder := lpFormat.NegativeOrder; + AnsiFormat.PositiveOrder := lpFormat.PositiveOrder; + AnsiFormat.lpCurrencySymbol := PAnsiChar(AnsiString(lpFormat.lpCurrencySymbol)); + PAnsiFormat := @AnsiFormat; + end; + SetLength(AnsiBuff, MAX_ANSI_BUFF_SIZE); + SetLength(AnsiBuff, GetCurrencyFormatA{TNT-ALLOW GetCurrencyFormatA}(Locale, dwFlags, + PAnsiChar(AnsiString(lpValue)), PAnsiFormat, PAnsiChar(AnsiBuff), MAX_ANSI_BUFF_SIZE)); + Result := _HandleStringLengthResult(cchCurrency, lpCurrencyStr, AnsiBuff, []); + end; +end; + +function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; + cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; +var + WideStr1, WideStr2: WideString; + AnsiStr1, AnsiStr2: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := CompareStringW{TNT-ALLOW CompareStringW}(Locale, dwCmpFlags, lpString1, cchCount1, lpString2, cchCount2) + else begin + WideStr1 := _WStr(lpString1, cchCount1); + WideStr2 := _WStr(lpString2, cchCount2); + if (dwCmpFlags = 0) then begin + // binary comparison + if WideStr1 < WideStr2 then + Result := 1 + else if WideStr1 = WideStr2 then + Result := 2 + else + Result := 3; + end else begin + AnsiStr1 := WideStr1; + AnsiStr2 := WideStr2; + Result := CompareStringA{TNT-ALLOW CompareStringA}(Locale, dwCmpFlags, + PAnsiChar(AnsiStr1), -1, PAnsiChar(AnsiStr2), -1); + end; + end; +end; + +function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; +var + AStr: AnsiString; + WStr: WideString; +begin + if Win32PlatformIsUnicode then + Result := CharUpperW{TNT-ALLOW CharUpperW}(lpsz) + else begin + if HiWord(Cardinal(lpsz)) = 0 then begin + // literal char mode + Result := lpsz; + if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin + AStr := WideChar(lpsz); // single character may be more than one byte + CharUpperA{TNT-ALLOW CharUpperA}(PAnsiChar(AStr)); + WStr := AStr; // should always be single wide char + if Length(WStr) = 1 then + Result := PWideChar(WStr[1]); + end + end else begin + // null-terminated string mode + Result := lpsz; + while lpsz^ <> #0 do begin + lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; + end; +end; + +function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; +var + i: integer; +begin + if Win32PlatformIsUnicode then + Result := CharUpperBuffW{TNT-ALLOW CharUpperBuffW}(lpsz, cchLength) + else begin + Result := cchLength; + for i := 1 to cchLength do begin + lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; +end; + +function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; +var + AStr: AnsiString; + WStr: WideString; +begin + if Win32PlatformIsUnicode then + Result := CharLowerW{TNT-ALLOW CharLowerW}(lpsz) + else begin + if HiWord(Cardinal(lpsz)) = 0 then begin + // literal char mode + Result := lpsz; + if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin + AStr := WideChar(lpsz); // single character may be more than one byte + CharLowerA{TNT-ALLOW CharLowerA}(PAnsiChar(AStr)); + WStr := AStr; // should always be single wide char + if Length(WStr) = 1 then + Result := PWideChar(WStr[1]); + end + end else begin + // null-terminated string mode + Result := lpsz; + while lpsz^ <> #0 do begin + lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; + end; +end; + +function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; +var + i: integer; +begin + if Win32PlatformIsUnicode then + Result := CharLowerBuffW{TNT-ALLOW CharLowerBuffW}(lpsz, cchLength) + else begin + Result := cchLength; + for i := 1 to cchLength do begin + lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; +end; + +function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; + lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; +var + AStr: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetStringTypeExW{TNT-ALLOW GetStringTypeExW}(Locale, dwInfoType, lpSrcStr, cchSrc, lpCharType) + else begin + AStr := _WStr(lpSrcStr, cchSrc); + Result := GetStringTypeExA{TNT-ALLOW GetStringTypeExA}(Locale, dwInfoType, + PAnsiChar(AStr), -1, lpCharType); + end; +end; + +function Win9x_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; +// This function originated by the WINE Project. +// It was translated to Pascal by Francisco Leong. +// It was further modified by Troy Wolbrink. +var + hmem: HGLOBAL; + hrsrc: THandle; + p: PWideChar; + string_num, i: Integer; + block: Integer; +begin + Result := 0; + // Netscape v3 fix... + if (HIWORD(uID) = $FFFF) then begin + uID := UINT(-(Integer(uID))); + end; + // figure block, string_num + block := ((uID shr 4) and $FFFF) + 1; // bits 4 - 19, mask out bits 20 - 31, inc by 1 + string_num := uID and $000F; + // get handle & pointer to string block + hrsrc := FindResource{TNT-ALLOW FindResource}(hInstance, MAKEINTRESOURCE(block), RT_STRING); + if (hrsrc <> 0) then + begin + hmem := LoadResource(hInstance, hrsrc); + if (hmem <> 0) then + begin + p := LockResource(hmem); + // walk the block to the requested string + for i := 0 to string_num - 1 do begin + p := p + Integer(p^) + 1; + end; + Result := Integer(p^); { p points to the length of string } + Inc(p); { p now points to the actual string } + if (lpBuffer <> nil) and (nBufferMax > 0) then + begin + Result := min(nBufferMax - 1, Result); { max length to copy } + if (Result > 0) then begin + CopyMemory(lpBuffer, p, Result * sizeof(WideChar)); + end; + lpBuffer[Result] := WideChar(0); { null terminate } + end; + end; + end; +end; + +function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; +begin + if Win32PlatformIsUnicode then + Result := Windows.LoadStringW{TNT-ALLOW LoadStringW}(hInstance, uID, lpBuffer, nBufferMax) + else + Result := Win9x_LoadStringW(hInstance, uID, lpBuffer, nBufferMax); +end; + +function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: TMenuItemInfoW): BOOL; +begin + if Win32PlatformIsUnicode then + Result := InsertMenuItemW{TNT-ALLOW InsertMenuItemW}(hMenu, uItem, fByPosition, lpmii) + else begin + TMenuItemInfoA(lpmii).dwTypeData := PAnsiChar(AnsiString(lpmii.dwTypeData)); + Result := InsertMenuItemA{TNT-ALLOW InsertMenuItemA}(hMenu, uItem, fByPosition, TMenuItemInfoA(lpmii)); + end; +end; + +function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; + var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; +begin + if Win32PlatformIsUnicode then + Result := ExtractIconExW{TNT-ALLOW ExtractIconExW}(lpszFile, + nIconIndex, phiconLarge, phiconSmall, nIcons) + else + Result := ExtractIconExA{TNT-ALLOW ExtractIconExA}(PAnsiChar(AnsiString(lpszFile)), + nIconIndex, phiconLarge, phiconSmall, nIcons); +end; + +function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; + var lpiIcon: Word): HICON; +begin + if Win32PlatformIsUnicode then + Result := ExtractAssociatedIconW{TNT-ALLOW ExtractAssociatedIconW}(hInst, lpIconPath, lpiIcon) + else + Result := ExtractAssociatedIconA{TNT-ALLOW ExtractAssociatedIconA}(hInst, + PAnsiChar(AnsiString(lpIconPath)), lpiIcon) +end; + +function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetFileVersionInfoSizeW{TNT-ALLOW GetFileVersionInfoSizeW}(lptstrFilename, lpdwHandle) + else + Result := GetFileVersionInfoSizeA{TNT-ALLOW GetFileVersionInfoSizeA}(PAnsiChar(AnsiString(lptstrFilename)), lpdwHandle); +end; + +function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; + lpData: Pointer): BOOL; +begin + if Win32PlatformIsUnicode then + Result := GetFileVersionInfoW{TNT-ALLOW GetFileVersionInfoW}(lptstrFilename, dwHandle, dwLen, lpData) + else + Result := GetFileVersionInfoA{TNT-ALLOW GetFileVersionInfoA}(PAnsiChar(AnsiString(lptstrFilename)), dwHandle, dwLen, lpData); +end; + +var + Last_VerQueryValue_String: WideString; + +function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; + var lplpBuffer: Pointer; var puLen: UINT): BOOL; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := VerQueryValueW{TNT-ALLOW VerQueryValueW}(pBlock, lpSubBlock, lplpBuffer, puLen) + else begin + Result := VerQueryValueA{TNT-ALLOW VerQueryValueA}(pBlock, PAnsiChar(AnsiString(lpSubBlock)), lplpBuffer, puLen); + if WideTextPos(VQV_STRINGFILEINFO, lpSubBlock) <> 1 then + else begin + { /StringFileInfo, convert ansi result to unicode } + SetString(AnsiBuff, PAnsiChar(lplpBuffer), puLen); + Last_VerQueryValue_String := AnsiBuff; + lplpBuffer := PWideChar(Last_VerQueryValue_String); + puLen := Length(Last_VerQueryValue_String); + end; + end; +end; + +//--------------------------------------------------------------------------------------- +// Wide functions from Shell32.dll should be loaded dynamically (no stub on early Win95) +//--------------------------------------------------------------------------------------- + +type + TSHFileOperationW = function(var lpFileOp: TSHFileOpStructW): Integer; stdcall; + TSHBrowseForFolderW = function(var lpbi: TBrowseInfoW): PItemIDList; stdcall; + TSHGetPathFromIDListW = function(pidl: PItemIDList; pszPath: PWideChar): BOOL; stdcall; + TSHGetFileInfoW = function(pszPath: PWideChar; dwFileAttributes: DWORD; + var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; stdcall; + +var + Safe_SHFileOperationW: TSHFileOperationW = nil; + Safe_SHBrowseForFolderW: TSHBrowseForFolderW = nil; + Safe_SHGetPathFromIDListW: TSHGetPathFromIDListW = nil; + Safe_SHGetFileInfoW: TSHGetFileInfoW = nil; + +var Shell32DLL: HModule = 0; + +procedure LoadWideShell32Procs; +begin + if Shell32DLL = 0 then begin + Shell32DLL := WinCheckH(Tnt_LoadLibraryW('shell32.dll')); + Safe_SHFileOperationW := WinCheckP(GetProcAddress(Shell32DLL, 'SHFileOperationW')); + Safe_SHBrowseForFolderW := WinCheckP(GetProcAddress(Shell32DLL, 'SHBrowseForFolderW')); + Safe_SHGetPathFromIDListW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetPathFromIDListW')); + Safe_SHGetFileInfoW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetFileInfoW')); + end; +end; + +function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; +var + AnsiFileOp: TSHFileOpStructA; + MapCount: Integer; + PAnsiMap: PSHNameMappingA; + PWideMap: PSHNameMappingW; + OldPath: WideString; + NewPath: WideString; + i: integer; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHFileOperationW(lpFileOp); + end else begin + AnsiFileOp := TSHFileOpStructA(lpFileOp); + // convert PChar -> PWideChar + if lpFileOp.pFrom = nil then + AnsiFileOp.pFrom := nil + else + AnsiFileOp.pFrom := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pFrom))); + if lpFileOp.pTo = nil then + AnsiFileOp.pTo := nil + else + AnsiFileOp.pTo := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pTo))); + AnsiFileOp.lpszProgressTitle := PAnsiChar(AnsiString(lpFileOp.lpszProgressTitle)); + Result := SHFileOperationA{TNT-ALLOW SHFileOperationA}(AnsiFileOp); + // return struct results + lpFileOp.fAnyOperationsAborted := AnsiFileOp.fAnyOperationsAborted; + lpFileOp.hNameMappings := nil; + if (AnsiFileOp.hNameMappings <> nil) + and ((FOF_WANTMAPPINGHANDLE and AnsiFileOp.fFlags) <> 0) then begin + // alloc mem + MapCount := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).cNumOfMappings; + lpFileOp.hNameMappings := + AllocMem(SizeOf({hNameMappings}Cardinal) + SizeOf(TSHNameMappingW) * MapCount); + PSHNameMappingHeaderW(lpFileOp.hNameMappings).cNumOfMappings := MapCount; + // init pointers + PAnsiMap := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).lpNM; + PWideMap := PSHNameMappingHeaderW(lpFileOp.hNameMappings).lpNM; + for i := 1 to MapCount do begin + // old path + OldPath := Copy(PAnsiMap.pszOldPath, 1, PAnsiMap.cchOldPath); + PWideMap.pszOldPath := WStrNew(PWideChar(OldPath)); + PWideMap.cchOldPath := WStrLen(PWideMap.pszOldPath); + // new path + NewPath := Copy(PAnsiMap.pszNewPath, 1, PAnsiMap.cchNewPath); + PWideMap.pszNewPath := WStrNew(PWideChar(NewPath)); + PWideMap.cchNewPath := WStrLen(PWideMap.pszNewPath); + // next record + Inc(PAnsiMap); + Inc(PWideMap); + end; + end; + end; +end; + +procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); +var + i: integer; + MapCount: Integer; + PWideMap: PSHNameMappingW; +begin + if Win32PlatformIsUnicode then + SHFreeNameMappings{TNT-ALLOW SHFreeNameMappings}(hNameMappings) + else begin + // free strings + MapCount := PSHNameMappingHeaderW(hNameMappings).cNumOfMappings; + PWideMap := PSHNameMappingHeaderW(hNameMappings).lpNM; + for i := 1 to MapCount do begin + WStrDispose(PWideMap.pszOldPath); + WStrDispose(PWideMap.pszNewPath); + Inc(PWideMap); + end; + // free struct + FreeMem(Pointer(hNameMappings)); + end; +end; + +function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; +var + AnsiInfo: TBrowseInfoA; + AnsiBuffer: array[0..MAX_PATH] of AnsiChar; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHBrowseForFolderW(lpbi); + end else begin + AnsiInfo := TBrowseInfoA(lpbi); + AnsiInfo.lpszTitle := PAnsiChar(AnsiString(lpbi.lpszTitle)); + if lpbi.pszDisplayName <> nil then + AnsiInfo.pszDisplayName := AnsiBuffer; + Result := SHBrowseForFolderA{TNT-ALLOW SHBrowseForFolderA}(AnsiInfo); + if lpbi.pszDisplayName <> nil then + WStrPCopy(lpbi.pszDisplayName, AnsiInfo.pszDisplayName); + lpbi.iImage := AnsiInfo.iImage; + end; +end; + +function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; +var + AnsiPath: AnsiString; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHGetPathFromIDListW(pidl, pszPath); + end else begin + SetLength(AnsiPath, MAX_PATH); + Result := SHGetPathFromIDListA{TNT-ALLOW SHGetPathFromIDListA}(pidl, PAnsiChar(AnsiPath)); + if Result then + WStrPCopy(pszPath, PAnsiChar(AnsiPath)) + end; +end; + +function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; + var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; +var + SHFileInfoA: TSHFileInfoA; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHGetFileInfoW(pszPath, dwFileAttributes, psfi, cbFileInfo, uFlags) + end else begin + Result := SHGetFileInfoA{TNT-ALLOW SHGetFileInfoA}(PAnsiChar(AnsiString(pszPath)), + dwFileAttributes, SHFileInfoA, SizeOf(TSHFileInfoA), uFlags); + // update pfsi... + ZeroMemory(@psfi, SizeOf(TSHFileInfoW)); + psfi.hIcon := SHFileInfoA.hIcon; + psfi.iIcon := SHFileInfoA.iIcon; + psfi.dwAttributes := SHFileInfoA.dwAttributes; + WStrPLCopy(psfi.szDisplayName, SHFileInfoA.szDisplayName, MAX_PATH); + WStrPLCopy(psfi.szTypeName, SHFileInfoA.szTypeName, 80); + end; +end; + + +function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; +begin + Result := HiWord(Cardinal(ResStr)) = 0; +end; + +function LANGIDFROMLCID(lcid: LCID): WORD; +begin + Result := LoWord(lcid); +end; + +function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; +begin + Result := (usSubLanguage shl 10) or usPrimaryLanguage; +end; + +function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; +begin + Result := MakeLong(wLanguageID, wSortID); +end; + +function PRIMARYLANGID(lgid: WORD): WORD; +begin + Result := lgid and $03FF; +end; + +function SORTIDFROMLCID(lcid: LCID): WORD; +begin + Result := HiWord(lcid); +end; + +function SUBLANGID(lgid: WORD): WORD; +begin + Result := lgid shr 10; +end; + +initialization + +finalization + if Shell32DLL <> 0 then + FreeLibrary(Shell32DLL); + +end. -- cgit v1.2.3