diff options
Diffstat (limited to 'plugins/Chess4Net/lib/TntUnicodeControls/Source')
39 files changed, 37081 insertions, 0 deletions
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.
|