From 194923c172167eb3fc33807ec8009b255f86337e Mon Sep 17 00:00:00 2001 From: Vadim Dashevskiy Date: Mon, 8 Oct 2012 09:10:06 +0000 Subject: Plugin is not adapted until someone can compile it and tell others how to do the same git-svn-id: http://svn.miranda-ng.org/main/trunk@1809 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c --- .../TntUnicodeControls/Source/ActiveIMM_TLB.pas | 1374 ------ .../lib/TntUnicodeControls/Source/TntActnList.pas | 835 ---- .../lib/TntUnicodeControls/Source/TntAxCtrls.pas | 191 - .../lib/TntUnicodeControls/Source/TntBandActn.pas | 92 - .../lib/TntUnicodeControls/Source/TntButtons.pas | 982 ---- .../lib/TntUnicodeControls/Source/TntCheckLst.pas | 184 - .../lib/TntUnicodeControls/Source/TntClasses.pas | 1780 ------- .../lib/TntUnicodeControls/Source/TntClipBrd.pas | 86 - .../lib/TntUnicodeControls/Source/TntComCtrls.pas | 5058 -------------------- .../lib/TntUnicodeControls/Source/TntCompilers.inc | 356 -- .../lib/TntUnicodeControls/Source/TntControls.pas | 1099 ----- .../lib/TntUnicodeControls/Source/TntDB.pas | 900 ---- .../lib/TntUnicodeControls/Source/TntDBActns.pas | 594 --- .../TntUnicodeControls/Source/TntDBClientActns.pas | 197 - .../lib/TntUnicodeControls/Source/TntDBCtrls.pas | 2195 --------- .../lib/TntUnicodeControls/Source/TntDBGrids.pas | 1175 ----- .../lib/TntUnicodeControls/Source/TntDBLogDlg.dfm | 108 - .../lib/TntUnicodeControls/Source/TntDBLogDlg.pas | 133 - .../lib/TntUnicodeControls/Source/TntDialogs.pas | 981 ---- .../lib/TntUnicodeControls/Source/TntExtActns.pas | 1400 ------ .../lib/TntUnicodeControls/Source/TntExtCtrls.pas | 1062 ---- .../lib/TntUnicodeControls/Source/TntExtDlgs.pas | 317 -- .../lib/TntUnicodeControls/Source/TntFileCtrl.pas | 118 - .../Source/TntFormatStrUtils.pas | 503 -- .../lib/TntUnicodeControls/Source/TntForms.pas | 873 ---- .../lib/TntUnicodeControls/Source/TntGraphics.pas | 142 - .../lib/TntUnicodeControls/Source/TntGrids.pas | 675 --- .../lib/TntUnicodeControls/Source/TntIniFiles.pas | 1011 ---- .../TntUnicodeControls/Source/TntIniFilesEx.pas | 205 - .../lib/TntUnicodeControls/Source/TntListActns.pas | 207 - .../lib/TntUnicodeControls/Source/TntMenus.pas | 1146 ----- .../lib/TntUnicodeControls/Source/TntRegistry.pas | 148 - .../lib/TntUnicodeControls/Source/TntStdActns.pas | 1922 -------- .../lib/TntUnicodeControls/Source/TntStdCtrls.pas | 3215 ------------- .../lib/TntUnicodeControls/Source/TntSysUtils.pas | 1699 ------- .../lib/TntUnicodeControls/Source/TntSystem.pas | 1384 ------ .../TntUnicodeControls/Source/TntWideStrUtils.pas | 451 -- .../TntUnicodeControls/Source/TntWideStrings.pas | 831 ---- .../lib/TntUnicodeControls/Source/TntWindows.pas | 1452 ------ 39 files changed, 37081 deletions(-) delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas (limited to 'plugins/Chess4Net/lib/TntUnicodeControls') diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas deleted file mode 100644 index c515cf9a36..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas +++ /dev/null @@ -1,1374 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 0f3e69893c..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas +++ /dev/null @@ -1,835 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index bc4b03c883..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas +++ /dev/null @@ -1,191 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 2528c42ffb..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas +++ /dev/null @@ -1,92 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index dd2ab6028c..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas +++ /dev/null @@ -1,982 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 9d1ae95aa3..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas +++ /dev/null @@ -1,184 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index e99c0fa3a5..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas +++ /dev/null @@ -1,1780 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index cf2c16e9f6..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas +++ /dev/null @@ -1,86 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 42bec4cd46..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas +++ /dev/null @@ -1,5058 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 5ab13901ba..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc +++ /dev/null @@ -1,356 +0,0 @@ -//---------------------------------------------------------------------------------------------------------------------- -// 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 deleted file mode 100644 index 55025ecdc2..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas +++ /dev/null @@ -1,1099 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 4490bd12e2..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas +++ /dev/null @@ -1,900 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 681257ec1a..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas +++ /dev/null @@ -1,594 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 98904c7380..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas +++ /dev/null @@ -1,197 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 49111d4aba..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas +++ /dev/null @@ -1,2195 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 2664bf7b5a..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas +++ /dev/null @@ -1,1175 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index fd0a07196b..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm +++ /dev/null @@ -1,108 +0,0 @@ -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 deleted file mode 100644 index c8747e2f2a..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas +++ /dev/null @@ -1,133 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 0c06d07f7d..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas +++ /dev/null @@ -1,981 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index cf1f342142..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas +++ /dev/null @@ -1,1400 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 4789fa714a..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas +++ /dev/null @@ -1,1062 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 528c4f9f8f..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas +++ /dev/null @@ -1,317 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 892bd801ae..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas +++ /dev/null @@ -1,118 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 1149ec8f32..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas +++ /dev/null @@ -1,503 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 780005714e..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas +++ /dev/null @@ -1,873 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 617b901f77..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas +++ /dev/null @@ -1,142 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 8096cd445b..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas +++ /dev/null @@ -1,675 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 7219950865..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas +++ /dev/null @@ -1,1011 +0,0 @@ -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 87ec613976..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas +++ /dev/null @@ -1,205 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 00601c0449..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas +++ /dev/null @@ -1,207 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 577764661c..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas +++ /dev/null @@ -1,1146 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index e3f445f92b..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas +++ /dev/null @@ -1,148 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 118e806336..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas +++ /dev/null @@ -1,1922 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 09c7da4573..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas +++ /dev/null @@ -1,3215 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index f6cd3e2ebb..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas +++ /dev/null @@ -1,1699 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index cc99aa48f7..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas +++ /dev/null @@ -1,1384 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 02a64bbc3e..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas +++ /dev/null @@ -1,451 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index dfe3755403..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas +++ /dev/null @@ -1,831 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 deleted file mode 100644 index 12d74d8344..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas +++ /dev/null @@ -1,1452 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntWindows; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Windows, ShellApi, ShlObj; - -// ......... compatibility - -const - DT_NOFULLWIDTHCHARBREAK = $00080000; - -const - INVALID_FILE_ATTRIBUTES = DWORD(-1); - -// ................ ANSI TYPES ................ -{TNT-WARN LPSTR} -{TNT-WARN PLPSTR} -{TNT-WARN LPCSTR} -{TNT-WARN LPCTSTR} -{TNT-WARN LPTSTR} - -// ........ EnumResourceTypesW, EnumResourceNamesW and EnumResourceLanguagesW are supposed .... -// ........ to work on Win95/98/ME but have caused access violations in testing on Win95 ...... -// .. TNT--WARN EnumResourceTypes .. -// .. TNT--WARN EnumResourceTypesA .. -// .. TNT--WARN EnumResourceNames .. -// .. TNT--WARN EnumResourceNamesA .. -// .. TNT--WARN EnumResourceLanguages .. -// .. TNT--WARN EnumResourceLanguagesA .. - -//------------------------------------------------------------------------------------------ - -// ......... The Unicode form of these functions are supported on Windows 95/98/ME ......... -{TNT-WARN ExtTextOut} -{TNT-WARN ExtTextOutA} -{TNT-WARN Tnt_ExtTextOutW} - -{TNT-WARN FindResource} -{TNT-WARN FindResourceA} -{TNT-WARN Tnt_FindResourceW} - -{TNT-WARN FindResourceEx} -{TNT-WARN FindResourceExA} -{TNT-WARN Tnt_FindResourceExW} - -{TNT-WARN GetCharWidth} -{TNT-WARN GetCharWidthA} -{TNT-WARN Tnt_GetCharWidthW} - -{TNT-WARN GetCommandLine} -{TNT-WARN GetCommandLineA} -{TNT-WARN Tnt_GetCommandLineW} - -{TNT-WARN GetTextExtentPoint} -{TNT-WARN GetTextExtentPointA} -{TNT-WARN Tnt_GetTextExtentPointW} - -{TNT-WARN GetTextExtentPoint32} -{TNT-WARN GetTextExtentPoint32A} -{TNT-WARN Tnt_GetTextExtentPoint32W} - -{TNT-WARN lstrcat} -{TNT-WARN lstrcatA} -{TNT-WARN Tnt_lstrcatW} - -{TNT-WARN lstrcpy} -{TNT-WARN lstrcpyA} -{TNT-WARN Tnt_lstrcpyW} - -{TNT-WARN lstrlen} -{TNT-WARN lstrlenA} -{TNT-WARN Tnt_lstrlenW} - -{TNT-WARN MessageBox} -{TNT-WARN MessageBoxA} -{TNT-WARN Tnt_MessageBoxW} - -{TNT-WARN MessageBoxEx} -{TNT-WARN MessageBoxExA} -{TNT-WARN Tnt_MessageBoxExA} - -{TNT-WARN TextOut} -{TNT-WARN TextOutA} -{TNT-WARN Tnt_TextOutW} - -//------------------------------------------------------------------------------------------ - -{TNT-WARN LOCALE_USER_DEFAULT} // <-- use GetThreadLocale -{TNT-WARN LOCALE_SYSTEM_DEFAULT} // <-- use GetThreadLocale - -//------------------------------------------------------------------------------------------ -// compatiblity -//------------------------------------------------------------------------------------------ -{$IFNDEF COMPILER_9_UP} -type - TStartupInfoA = _STARTUPINFOA; - TStartupInfoW = record - cb: DWORD; - lpReserved: PWideChar; - lpDesktop: PWideChar; - lpTitle: PWideChar; - dwX: DWORD; - dwY: DWORD; - dwXSize: DWORD; - dwYSize: DWORD; - dwXCountChars: DWORD; - dwYCountChars: DWORD; - dwFillAttribute: DWORD; - dwFlags: DWORD; - wShowWindow: Word; - cbReserved2: Word; - lpReserved2: PByte; - hStdInput: THandle; - hStdOutput: THandle; - hStdError: THandle; - end; - -function CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; stdcall; external kernel32 name 'CreateProcessW'; - -{$ENDIF} -//------------------------------------------------------------------------------------------ - -{TNT-WARN SetWindowText} -{TNT-WARN SetWindowTextA} -{TNT-WARN SetWindowTextW} -function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; - -{TNT-WARN RemoveDirectory} -{TNT-WARN RemoveDirectoryA} -{TNT-WARN RemoveDirectoryW} -function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; - -{TNT-WARN GetShortPathName} -{TNT-WARN GetShortPathNameA} -{TNT-WARN GetShortPathNameW} -function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; - cchBuffer: DWORD): DWORD; - -{TNT-WARN GetFullPathName} -{TNT-WARN GetFullPathNameA} -{TNT-WARN GetFullPathNameW} -function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; - lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; - -{TNT-WARN CreateFile} -{TNT-WARN CreateFileA} -{TNT-WARN CreateFileW} -function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; - -{TNT-WARN FindFirstFile} -{TNT-WARN FindFirstFileA} -{TNT-WARN FindFirstFileW} -function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; - -{TNT-WARN FindNextFile} -{TNT-WARN FindNextFileA} -{TNT-WARN FindNextFileW} -function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; - -{TNT-WARN GetFileAttributes} -{TNT-WARN GetFileAttributesA} -{TNT-WARN GetFileAttributesW} -function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; - -{TNT-WARN SetFileAttributes} -{TNT-WARN SetFileAttributesA} -{TNT-WARN SetFileAttributesW} -function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; - -{TNT-WARN CreateDirectory} -{TNT-WARN CreateDirectoryA} -{TNT-WARN CreateDirectoryW} -function Tnt_CreateDirectoryW(lpPathName: PWideChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; - -{TNT-WARN MoveFile} -{TNT-WARN MoveFileA} -{TNT-WARN MoveFileW} -function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; - -{TNT-WARN CopyFile} -{TNT-WARN CopyFileA} -{TNT-WARN CopyFileW} -function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; - -{TNT-WARN DeleteFile} -{TNT-WARN DeleteFileA} -{TNT-WARN DeleteFileW} -function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; - -{TNT-WARN DrawText} -{TNT-WARN DrawTextA} -{TNT-WARN DrawTextW} -function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; - -{TNT-WARN GetDiskFreeSpace} -{TNT-WARN GetDiskFreeSpaceA} -{TNT-WARN GetDiskFreeSpaceW} -function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, - lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; - -{TNT-WARN GetVolumeInformation} -{TNT-WARN GetVolumeInformationA} -{TNT-WARN GetVolumeInformationW} -function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; - nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; - nFileSystemNameSize: DWORD): BOOL; - -{TNT-WARN GetModuleFileName} -{TNT-WARN GetModuleFileNameA} -{TNT-WARN GetModuleFileNameW} -function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; - -{TNT-WARN GetTempPath} -{TNT-WARN GetTempPathA} -{TNT-WARN GetTempPathW} -function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; - -{TNT-WARN GetTempFileName} -{TNT-WARN GetTempFileNameA} -{TNT-WARN GetTempFileNameW} -function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; - lpTempFileName: PWideChar): UINT; - -{TNT-WARN GetWindowsDirectory} -{TNT-WARN GetWindowsDirectoryA} -{TNT-WARN GetWindowsDirectoryW} -function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; - -{TNT-WARN GetSystemDirectory} -{TNT-WARN GetSystemDirectoryA} -{TNT-WARN GetSystemDirectoryW} -function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; - -{TNT-WARN GetCurrentDirectory} -{TNT-WARN GetCurrentDirectoryA} -{TNT-WARN GetCurrentDirectoryW} -function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; - -{TNT-WARN SetCurrentDirectory} -{TNT-WARN SetCurrentDirectoryA} -{TNT-WARN SetCurrentDirectoryW} -function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; - -{TNT-WARN GetComputerName} -{TNT-WARN GetComputerNameA} -{TNT-WARN GetComputerNameW} -function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; - -{TNT-WARN GetUserName} -{TNT-WARN GetUserNameA} -{TNT-WARN GetUserNameW} -function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; - -{TNT-WARN ShellExecute} -{TNT-WARN ShellExecuteA} -{TNT-WARN ShellExecuteW} -function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, - Directory: PWideChar; ShowCmd: Integer): HINST; - -{TNT-WARN LoadLibrary} -{TNT-WARN LoadLibraryA} -{TNT-WARN LoadLibraryW} -function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; - -{TNT-WARN LoadLibraryEx} -{TNT-WARN LoadLibraryExA} -{TNT-WARN LoadLibraryExW} -function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; - -{TNT-WARN CreateProcess} -{TNT-WARN CreateProcessA} -{TNT-WARN CreateProcessW} -function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; - -{TNT-WARN GetCurrencyFormat} -{TNT-WARN GetCurrencyFormatA} -{TNT-WARN GetCurrencyFormatW} -function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; - lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; - -{TNT-WARN CompareString} -{TNT-WARN CompareStringA} -{TNT-WARN CompareStringW} -function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; - -{TNT-WARN CharUpper} -{TNT-WARN CharUpperA} -{TNT-WARN CharUpperW} -function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; - -{TNT-WARN CharUpperBuff} -{TNT-WARN CharUpperBuffA} -{TNT-WARN CharUpperBuffW} -function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; - -{TNT-WARN CharLower} -{TNT-WARN CharLowerA} -{TNT-WARN CharLowerW} -function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; - -{TNT-WARN CharLowerBuff} -{TNT-WARN CharLowerBuffA} -{TNT-WARN CharLowerBuffW} -function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; - -{TNT-WARN GetStringTypeEx} -{TNT-WARN GetStringTypeExA} -{TNT-WARN GetStringTypeExW} -function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; - -{TNT-WARN LoadString} -{TNT-WARN LoadStringA} -{TNT-WARN LoadStringW} -function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; - -{TNT-WARN InsertMenuItem} -{TNT-WARN InsertMenuItemA} -{TNT-WARN InsertMenuItemW} -function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: tagMenuItemINFOW): BOOL; - -{TNT-WARN ExtractIconEx} -{TNT-WARN ExtractIconExA} -{TNT-WARN ExtractIconExW} -function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; - var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; - -{TNT-WARN ExtractAssociatedIcon} -{TNT-WARN ExtractAssociatedIconA} -{TNT-WARN ExtractAssociatedIconW} -function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; - var lpiIcon: Word): HICON; - -{TNT-WARN GetFileVersionInfoSize} -{TNT-WARN GetFileVersionInfoSizeA} -{TNT-WARN GetFileVersionInfoSizeW} -function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; - -{TNT-WARN GetFileVersionInfo} -{TNT-WARN GetFileVersionInfoA} -{TNT-WARN GetFileVersionInfoW} -function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; - -const - VQV_FIXEDFILEINFO = '\'; - VQV_VARFILEINFO_TRANSLATION = '\VarFileInfo\Translation'; - VQV_STRINGFILEINFO = '\StringFileInfo'; - - VER_COMMENTS = 'Comments'; - VER_INTERNALNAME = 'InternalName'; - VER_PRODUCTNAME = 'ProductName'; - VER_COMPANYNAME = 'CompanyName'; - VER_LEGALCOPYRIGHT = 'LegalCopyright'; - VER_PRODUCTVERSION = 'ProductVersion'; - VER_FILEDESCRIPTION = 'FileDescription'; - VER_LEGALTRADEMARKS = 'LegalTrademarks'; - VER_PRIVATEBUILD = 'PrivateBuild'; - VER_FILEVERSION = 'FileVersion'; - VER_ORIGINALFILENAME = 'OriginalFilename'; - VER_SPECIALBUILD = 'SpecialBuild'; - -{TNT-WARN VerQueryValue} -{TNT-WARN VerQueryValueA} -{TNT-WARN VerQueryValueW} -function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; - -type - TSHNameMappingHeaderA = record - cNumOfMappings: Cardinal; - lpNM: PSHNAMEMAPPINGA; - end; - PSHNameMappingHeaderA = ^TSHNameMappingHeaderA; - - TSHNameMappingHeaderW = record - cNumOfMappings: Cardinal; - lpNM: PSHNAMEMAPPINGW; - end; - PSHNameMappingHeaderW = ^TSHNameMappingHeaderW; - -{TNT-WARN SHFileOperation} -{TNT-WARN SHFileOperationA} -{TNT-WARN SHFileOperationW} // <-- no stub on early Windows 95 -function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; - -{TNT-WARN SHFreeNameMappings} -procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); - -{TNT-WARN SHBrowseForFolder} -{TNT-WARN SHBrowseForFolderA} -{TNT-WARN SHBrowseForFolderW} // <-- no stub on early Windows 95 -function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; - -{TNT-WARN SHGetPathFromIDList} -{TNT-WARN SHGetPathFromIDListA} -{TNT-WARN SHGetPathFromIDListW} // <-- no stub on early Windows 95 -function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; - -{TNT-WARN SHGetFileInfo} -{TNT-WARN SHGetFileInfoA} -{TNT-WARN SHGetFileInfoW} // <-- no stub on early Windows 95 -function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; - -// ......... introduced ......... -function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; - -function LANGIDFROMLCID(lcid: LCID): WORD; -function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; -function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; -function PRIMARYLANGID(lgid: WORD): WORD; -function SORTIDFROMLCID(lcid: LCID): WORD; -function SUBLANGID(lgid: WORD): WORD; - -implementation - -uses - SysUtils, Math, TntSysUtils, - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; - -function _PAnsiCharWithNil(const S: AnsiString): PAnsiChar; -begin - if S = '' then - Result := nil {Win9x needs nil for some parameters instead of empty strings} - else - Result := PAnsiChar(S); -end; - -function _PWideCharWithNil(const S: WideString): PWideChar; -begin - if S = '' then - Result := nil {Win9x needs nil for some parameters instead of empty strings} - else - Result := PWideChar(S); -end; - -function _WStr(lpString: PWideChar; cchCount: Integer): WideString; -begin - if cchCount = -1 then - Result := lpString - else - Result := Copy(WideString(lpString), 1, cchCount); -end; - -procedure _MakeWideWin32FindData(var WideFindData: TWIN32FindDataW; AnsiFindData: TWIN32FindDataA); -begin - CopyMemory(@WideFindData, @AnsiFindData, - Integer(@WideFindData.cFileName) - Integer(@WideFindData)); - WStrPCopy(WideFindData.cFileName, AnsiFindData.cFileName); - WStrPCopy(WideFindData.cAlternateFileName, AnsiFindData.cAlternateFileName); -end; - -function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetWindowTextW{TNT-ALLOW SetWindowTextW}(hWnd, lpString) - else - Result := SetWindowTextA{TNT-ALLOW SetWindowTextA}(hWnd, PAnsiChar(AnsiString(lpString))); -end; - -//----------------------------- - -type - TPathLengthResultOption = (poAllowDirectoryMode, poZeroSmallBuff, poExactCopy, poExactCopySubPaths); - TPathLengthResultOptions = set of TPathLengthResultOption; - -procedure _ExactStrCopyW(pDest, pSource: PWideChar; Count: Integer); -var - i: integer; -begin - for i := 1 to Count do begin - pDest^ := pSource^; - Inc(PSource); - Inc(pDest); - end; -end; - -procedure _ExactCopySubPaths(pDest, pSource: PWideChar; Count: Integer); -var - i: integer; - OriginalSource: PWideChar; - PNextSlash: PWideChar; -begin - if Count >= 4 then begin - OriginalSource := pSource; - PNextSlash := WStrScan(pSource, '\'); - for i := 1 to Count - 1 do begin - // determine next path delimiter - if pSource > pNextSlash then begin - PNextSlash := WStrScan(pSource, '\'); - end; - // leave if no more sub paths - if (PNextSlash = nil) - or ((pNextSlash - OriginalSource) >= Count) then begin - exit; - end; - // copy char - pDest^ := pSource^; - Inc(PSource); - Inc(pDest); - end; - end; -end; - -function _HandlePathLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; -var - WideBuff: WideString; -begin - WideBuff := AnsiBuff; - if nBufferLength > Cardinal(Length(WideBuff)) then begin - // normal - Result := Length(WideBuff); - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else if (poExactCopy in Options) then begin - // exact - Result := nBufferLength; - _ExactStrCopyW(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else begin - // other - if (poAllowDirectoryMode in Options) - and (nBufferLength = Cardinal(Length(WideBuff))) then begin - Result := Length(WideBuff) + 1; - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength - 1); - end else begin - Result := Length(WideBuff) + 1; - if (nBufferLength > 0) then begin - if (poZeroSmallBuff in Options) then - lpBuffer^ := #0 - else if (poExactCopySubPaths in Options) then - _ExactCopySubPaths(lpBuffer, PWideChar(WideBuff), nBufferLength); - end; - end; - end; -end; - -function _HandleStringLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; -var - WideBuff: WideString; -begin - WideBuff := AnsiBuff; - if nBufferLength >= Cardinal(Length(WideBuff)) then begin - // normal - Result := Length(WideBuff); - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else if nBufferLength = 0 then - Result := Length(WideBuff) - else - Result := 0; -end; - -//------------------------------------------- - -function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := RemoveDirectoryW{TNT-ALLOW RemoveDirectoryW}(PWideChar(lpPathName)) - else - Result := RemoveDirectoryA{TNT-ALLOW RemoveDirectoryA}(PAnsiChar(AnsiString(lpPathName))); -end; - -function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; - cchBuffer: DWORD): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetShortPathNameW{TNT-ALLOW GetShortPathNameW}(lpszLongPath, lpszShortPath, cchBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH * 2); - SetLength(AnsiBuff, GetShortPathNameA{TNT-ALLOW GetShortPathNameA}(PAnsiChar(AnsiString(lpszLongPath)), - PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(cchBuffer, lpszShortPath, AnsiBuff, [poExactCopySubPaths]); - end; -end; - -function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; - lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; -var - AnsiBuff: AnsiString; - AnsiFilePart: PAnsiChar; - AnsiLeadingChars: Integer; - WideLeadingChars: Integer; -begin - if Win32PlatformIsUnicode then - Result := GetFullPathNameW{TNT-ALLOW GetFullPathNameW}(lpFileName, nBufferLength, lpBuffer, lpFilePart) - else begin - SetLength(AnsiBuff, MAX_PATH * 2); - SetLength(AnsiBuff, GetFullPathNameA{TNT-ALLOW GetFullPathNameA}(PAnsiChar(AnsiString(lpFileName)), - Length(AnsiBuff), PAnsiChar(AnsiBuff), AnsiFilePart)); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poZeroSmallBuff]); - // deal w/ lpFilePart - if (AnsiFilePart = nil) or (nBufferLength < Result) then - lpFilePart := nil - else begin - AnsiLeadingChars := AnsiFilePart - PAnsiChar(AnsiBuff); - WideLeadingChars := Length(WideString(Copy(AnsiBuff, 1, AnsiLeadingChars))); - lpFilePart := lpBuffer + WideLeadingChars; - end; - end; -end; - -function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; -begin - if Win32PlatformIsUnicode then - Result := CreateFileW{TNT-ALLOW CreateFileW}(lpFileName, dwDesiredAccess, dwShareMode, - lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) - else - Result := CreateFileA{TNT-ALLOW CreateFileA}(PAnsiChar(AnsiString(lpFileName)), dwDesiredAccess, dwShareMode, - lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) -end; - -function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; -var - Ansi_lpFindFileData: TWIN32FindDataA; -begin - if Win32PlatformIsUnicode then - Result := FindFirstFileW{TNT-ALLOW FindFirstFileW}(lpFileName, lpFindFileData) - else begin - Result := FindFirstFileA{TNT-ALLOW FindFirstFileA}(PAnsiChar(AnsiString(lpFileName)), - Ansi_lpFindFileData); - if Result <> INVALID_HANDLE_VALUE then - _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); - end; -end; - -function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; -var - Ansi_lpFindFileData: TWIN32FindDataA; -begin - if Win32PlatformIsUnicode then - Result := FindNextFileW{TNT-ALLOW FindNextFileW}(hFindFile, lpFindFileData) - else begin - Result := FindNextFileA{TNT-ALLOW FindNextFileA}(hFindFile, Ansi_lpFindFileData); - if Result then - _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); - end; -end; - -function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetFileAttributesW{TNT-ALLOW GetFileAttributesW}(lpFileName) - else - Result := GetFileAttributesA{TNT-ALLOW GetFileAttributesA}(PAnsiChar(AnsiString(lpFileName))); -end; - -function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetFileAttributesW{TNT-ALLOW SetFileAttributesW}(lpFileName, dwFileAttributes) - else - Result := SetFileAttributesA{TNT-ALLOW SetFileAttributesA}(PAnsiChar(AnsiString(lpFileName)), dwFileAttributes); -end; - -function Tnt_CreateDirectoryW(lpPathName: PWideChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; -begin - if Win32PlatformIsUnicode then - Result := CreateDirectoryW{TNT-ALLOW CreateDirectoryW}(lpPathName, lpSecurityAttributes) - else - Result := CreateDirectoryA{TNT-ALLOW CreateDirectoryA}(PAnsiChar(AnsiString(lpPathName)), lpSecurityAttributes); -end; - -function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := MoveFileW{TNT-ALLOW MoveFileW}(lpExistingFileName, lpNewFileName) - else - Result := MoveFileA{TNT-ALLOW MoveFileA}(PAnsiChar(AnsiString(lpExistingFileName)), PAnsiChar(AnsiString(lpNewFileName))); -end; - -function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; -begin - if Win32PlatformIsUnicode then - Result := CopyFileW{TNT-ALLOW CopyFileW}(lpExistingFileName, lpNewFileName, bFailIfExists) - else - Result := CopyFileA{TNT-ALLOW CopyFileA}(PAnsiChar(AnsiString(lpExistingFileName)), - PAnsiChar(AnsiString(lpNewFileName)), bFailIfExists); -end; - -function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := DeleteFileW{TNT-ALLOW DeleteFileW}(lpFileName) - else - Result := DeleteFileA{TNT-ALLOW DeleteFileA}(PAnsiChar(AnsiString(lpFileName))); -end; - -function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; -begin - if Win32PlatformIsUnicode then - Result := DrawTextW{TNT-ALLOW DrawTextW}(hDC, lpString, nCount, lpRect, uFormat) - else - Result := DrawTextA{TNT-ALLOW DrawTextA}(hDC, - PAnsiChar(AnsiString(_WStr(lpString, nCount))), -1, lpRect, uFormat); -end; - -function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, - lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; -begin - if Win32PlatformIsUnicode then - Result := GetDiskFreeSpaceW{TNT-ALLOW GetDiskFreeSpaceW}(lpRootPathName, - lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) - else - Result := GetDiskFreeSpaceA{TNT-ALLOW GetDiskFreeSpaceA}(PAnsiChar(AnsiString(lpRootPathName)), - lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) -end; - -function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; - nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; - nFileSystemNameSize: DWORD): BOOL; -var - AnsiFileSystemNameBuffer: AnsiString; - AnsiVolumeNameBuffer: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetVolumeInformationW{TNT-ALLOW GetVolumeInformationW}(lpRootPathName, lpVolumeNameBuffer, nVolumeNameSize, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, lpFileSystemNameBuffer, nFileSystemNameSize) - else begin - SetLength(AnsiVolumeNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); - SetLength(AnsiFileSystemNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); - AnsiBuffLen := Length(AnsiFileSystemNameBuffer); - Result := GetVolumeInformationA{TNT-ALLOW GetVolumeInformationA}(PAnsiChar(AnsiString(lpRootPathName)), PAnsiChar(AnsiVolumeNameBuffer), AnsiBuffLen, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, PAnsiChar(AnsiFileSystemNameBuffer), AnsiBuffLen); - if Result then begin - SetLength(AnsiFileSystemNameBuffer, AnsiBuffLen); - if (nFileSystemNameSize <= AnsiBuffLen) or (Length(AnsiFileSystemNameBuffer) = 0) then - Result := False - else begin - WStrPLCopy(lpFileSystemNameBuffer, AnsiFileSystemNameBuffer, nFileSystemNameSize); - WStrPLCopy(lpVolumeNameBuffer, AnsiVolumeNameBuffer, nVolumeNameSize); - end; - end; - end; -end; - -function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetModuleFileNameW{TNT-ALLOW GetModuleFileNameW}(hModule, lpFilename, nSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetModuleFileNameA{TNT-ALLOW GetModuleFileNameA}(hModule, PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(nSize, lpFilename, AnsiBuff, [poExactCopy]); - end; -end; - -function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetTempPathW{TNT-ALLOW GetTempPathW}(nBufferLength, lpBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetTempPathA{TNT-ALLOW GetTempPathA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); - end; -end; - -function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; - lpTempFileName: PWideChar): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetTempFileNameW{TNT-ALLOW GetTempFileNameW}(lpPathName, lpPrefixString, uUnique, lpTempFileName) - else begin - SetLength(AnsiBuff, MAX_PATH); - Result := GetTempFileNameA{TNT-ALLOW GetTempFileNameA}(PAnsiChar(AnsiString(lpPathName)), PAnsiChar(lpPrefixString), uUnique, PAnsiChar(AnsiBuff)); - AnsiBuff := PAnsiChar(AnsiBuff); - _HandlePathLengthResult(MAX_PATH, lpTempFileName, AnsiBuff, [poZeroSmallBuff]); - end; -end; - -function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetWindowsDirectoryW{TNT-ALLOW GetWindowsDirectoryW}(lpBuffer, uSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetWindowsDirectoryA{TNT-ALLOW GetWindowsDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); - end; -end; - -function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetSystemDirectoryW{TNT-ALLOW GetSystemDirectoryW}(lpBuffer, uSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetSystemDirectoryA{TNT-ALLOW GetSystemDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); - end; -end; - -function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetCurrentDirectoryW{TNT-ALLOW GetCurrentDirectoryW}(nBufferLength, lpBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetCurrentDirectoryA{TNT-ALLOW GetCurrentDirectoryA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); - end; -end; - -function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetCurrentDirectoryW{TNT-ALLOW SetCurrentDirectoryW}(lpPathName) - else - Result := SetCurrentDirectoryA{TNT-ALLOW SetCurrentDirectoryA}(PAnsiChar(AnsiString(lpPathName))); -end; - -function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; -var - AnsiBuff: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetComputerNameW{TNT-ALLOW GetComputerNameW}(lpBuffer, nSize) - else begin - SetLength(AnsiBuff, MAX_COMPUTERNAME_LENGTH + 1); - AnsiBuffLen := Length(AnsiBuff); - Result := GetComputerNameA{TNT-ALLOW GetComputerNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); - if Result then begin - SetLength(AnsiBuff, AnsiBuffLen); - if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin - nSize := AnsiBuffLen + 1; - Result := False; - end else begin - WStrPLCopy(lpBuffer, AnsiBuff, nSize); - nSize := WStrLen(lpBuffer); - end; - end; - end; -end; - -function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; -var - AnsiBuff: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetUserNameW{TNT-ALLOW GetUserNameW}(lpBuffer, nSize) - else begin - SetLength(AnsiBuff, 255); - AnsiBuffLen := Length(AnsiBuff); - Result := GetUserNameA{TNT-ALLOW GetUserNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); - if Result then begin - SetLength(AnsiBuff, AnsiBuffLen); - if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin - nSize := AnsiBuffLen + 1; - Result := False; - end else begin - WStrPLCopy(lpBuffer, AnsiBuff, nSize); - nSize := WStrLen(lpBuffer); - end; - end; - end; -end; - -function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, - Directory: PWideChar; ShowCmd: Integer): HINST; -begin - if Win32PlatformIsUnicode then - Result := ShellExecuteW{TNT-ALLOW ShellExecuteW}(hWnd, _PWideCharWithNil(WideString(Operation)), - FileName, Parameters, - Directory, ShowCmd) - else begin - Result := ShellExecuteA{TNT-ALLOW ShellExecuteA}(hWnd, _PAnsiCharWithNil(AnsiString(Operation)), - _PAnsiCharWithNil(AnsiString(FileName)), _PAnsiCharWithNil(AnsiString(Parameters)), - _PAnsiCharWithNil(AnsiString(Directory)), ShowCmd) - end; -end; - -function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; -begin - if Win32PlatformIsUnicode then - Result := LoadLibraryW{TNT-ALLOW LoadLibraryW}(lpLibFileName) - else - Result := LoadLibraryA{TNT-ALLOW LoadLibraryA}(PAnsiChar(AnsiString(lpLibFileName))); -end; - -function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; -begin - if Win32PlatformIsUnicode then - Result := LoadLibraryExW{TNT-ALLOW LoadLibraryExW}(lpLibFileName, hFile, dwFlags) - else - Result := LoadLibraryExA{TNT-ALLOW LoadLibraryExA}(PAnsiChar(AnsiString(lpLibFileName)), hFile, dwFlags); -end; - -function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; -var - AnsiStartupInfo: TStartupInfoA; -begin - if Win32PlatformIsUnicode then begin - Result := CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName, lpCommandLine, - lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, - lpCurrentDirectory, lpStartupInfo, lpProcessInformation) - end else begin - CopyMemory(@AnsiStartupInfo, @lpStartupInfo, SizeOf(TStartupInfo)); - AnsiStartupInfo.lpReserved := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpReserved)); - AnsiStartupInfo.lpDesktop := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpDesktop)); - AnsiStartupInfo.lpTitle := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpTitle)); - Result := CreateProcessA{TNT-ALLOW CreateProcessA}(_PAnsiCharWithNil(AnsiString(lpApplicationName)), - _PAnsiCharWithNil(AnsiString(lpCommandLine)), - lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, - _PAnsiCharWithNil(AnsiString(lpCurrentDirectory)), AnsiStartupInfo, lpProcessInformation); - end; -end; - -function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; - lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; -const - MAX_ANSI_BUFF_SIZE = 64; // can a currency string actually be larger? -var - AnsiFormat: TCurrencyFmtA; - PAnsiFormat: PCurrencyFmtA; - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetCurrencyFormatW{TNT-ALLOW GetCurrencyFormatW}(Locale, dwFlags, lpValue, lpFormat, lpCurrencyStr, cchCurrency) - else begin - if lpFormat = nil then - PAnsiFormat := nil - else begin - ZeroMemory(@AnsiFormat, SizeOf(AnsiFormat)); - AnsiFormat.NumDigits := lpFormat.NumDigits; - AnsiFormat.LeadingZero := lpFormat.LeadingZero; - AnsiFormat.Grouping := lpFormat.Grouping; - AnsiFormat.lpDecimalSep := PAnsiChar(AnsiString(lpFormat.lpDecimalSep)); - AnsiFormat.lpThousandSep := PAnsiChar(AnsiString(lpFormat.lpThousandSep)); - AnsiFormat.NegativeOrder := lpFormat.NegativeOrder; - AnsiFormat.PositiveOrder := lpFormat.PositiveOrder; - AnsiFormat.lpCurrencySymbol := PAnsiChar(AnsiString(lpFormat.lpCurrencySymbol)); - PAnsiFormat := @AnsiFormat; - end; - SetLength(AnsiBuff, MAX_ANSI_BUFF_SIZE); - SetLength(AnsiBuff, GetCurrencyFormatA{TNT-ALLOW GetCurrencyFormatA}(Locale, dwFlags, - PAnsiChar(AnsiString(lpValue)), PAnsiFormat, PAnsiChar(AnsiBuff), MAX_ANSI_BUFF_SIZE)); - Result := _HandleStringLengthResult(cchCurrency, lpCurrencyStr, AnsiBuff, []); - end; -end; - -function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; -var - WideStr1, WideStr2: WideString; - AnsiStr1, AnsiStr2: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := CompareStringW{TNT-ALLOW CompareStringW}(Locale, dwCmpFlags, lpString1, cchCount1, lpString2, cchCount2) - else begin - WideStr1 := _WStr(lpString1, cchCount1); - WideStr2 := _WStr(lpString2, cchCount2); - if (dwCmpFlags = 0) then begin - // binary comparison - if WideStr1 < WideStr2 then - Result := 1 - else if WideStr1 = WideStr2 then - Result := 2 - else - Result := 3; - end else begin - AnsiStr1 := WideStr1; - AnsiStr2 := WideStr2; - Result := CompareStringA{TNT-ALLOW CompareStringA}(Locale, dwCmpFlags, - PAnsiChar(AnsiStr1), -1, PAnsiChar(AnsiStr2), -1); - end; - end; -end; - -function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; -var - AStr: AnsiString; - WStr: WideString; -begin - if Win32PlatformIsUnicode then - Result := CharUpperW{TNT-ALLOW CharUpperW}(lpsz) - else begin - if HiWord(Cardinal(lpsz)) = 0 then begin - // literal char mode - Result := lpsz; - if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin - AStr := WideChar(lpsz); // single character may be more than one byte - CharUpperA{TNT-ALLOW CharUpperA}(PAnsiChar(AStr)); - WStr := AStr; // should always be single wide char - if Length(WStr) = 1 then - Result := PWideChar(WStr[1]); - end - end else begin - // null-terminated string mode - Result := lpsz; - while lpsz^ <> #0 do begin - lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; - end; -end; - -function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; -var - i: integer; -begin - if Win32PlatformIsUnicode then - Result := CharUpperBuffW{TNT-ALLOW CharUpperBuffW}(lpsz, cchLength) - else begin - Result := cchLength; - for i := 1 to cchLength do begin - lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; -end; - -function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; -var - AStr: AnsiString; - WStr: WideString; -begin - if Win32PlatformIsUnicode then - Result := CharLowerW{TNT-ALLOW CharLowerW}(lpsz) - else begin - if HiWord(Cardinal(lpsz)) = 0 then begin - // literal char mode - Result := lpsz; - if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin - AStr := WideChar(lpsz); // single character may be more than one byte - CharLowerA{TNT-ALLOW CharLowerA}(PAnsiChar(AStr)); - WStr := AStr; // should always be single wide char - if Length(WStr) = 1 then - Result := PWideChar(WStr[1]); - end - end else begin - // null-terminated string mode - Result := lpsz; - while lpsz^ <> #0 do begin - lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; - end; -end; - -function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; -var - i: integer; -begin - if Win32PlatformIsUnicode then - Result := CharLowerBuffW{TNT-ALLOW CharLowerBuffW}(lpsz, cchLength) - else begin - Result := cchLength; - for i := 1 to cchLength do begin - lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; -end; - -function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; -var - AStr: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetStringTypeExW{TNT-ALLOW GetStringTypeExW}(Locale, dwInfoType, lpSrcStr, cchSrc, lpCharType) - else begin - AStr := _WStr(lpSrcStr, cchSrc); - Result := GetStringTypeExA{TNT-ALLOW GetStringTypeExA}(Locale, dwInfoType, - PAnsiChar(AStr), -1, lpCharType); - end; -end; - -function Win9x_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; -// This function originated by the WINE Project. -// It was translated to Pascal by Francisco Leong. -// It was further modified by Troy Wolbrink. -var - hmem: HGLOBAL; - hrsrc: THandle; - p: PWideChar; - string_num, i: Integer; - block: Integer; -begin - Result := 0; - // Netscape v3 fix... - if (HIWORD(uID) = $FFFF) then begin - uID := UINT(-(Integer(uID))); - end; - // figure block, string_num - block := ((uID shr 4) and $FFFF) + 1; // bits 4 - 19, mask out bits 20 - 31, inc by 1 - string_num := uID and $000F; - // get handle & pointer to string block - hrsrc := FindResource{TNT-ALLOW FindResource}(hInstance, MAKEINTRESOURCE(block), RT_STRING); - if (hrsrc <> 0) then - begin - hmem := LoadResource(hInstance, hrsrc); - if (hmem <> 0) then - begin - p := LockResource(hmem); - // walk the block to the requested string - for i := 0 to string_num - 1 do begin - p := p + Integer(p^) + 1; - end; - Result := Integer(p^); { p points to the length of string } - Inc(p); { p now points to the actual string } - if (lpBuffer <> nil) and (nBufferMax > 0) then - begin - Result := min(nBufferMax - 1, Result); { max length to copy } - if (Result > 0) then begin - CopyMemory(lpBuffer, p, Result * sizeof(WideChar)); - end; - lpBuffer[Result] := WideChar(0); { null terminate } - end; - end; - end; -end; - -function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; -begin - if Win32PlatformIsUnicode then - Result := Windows.LoadStringW{TNT-ALLOW LoadStringW}(hInstance, uID, lpBuffer, nBufferMax) - else - Result := Win9x_LoadStringW(hInstance, uID, lpBuffer, nBufferMax); -end; - -function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: TMenuItemInfoW): BOOL; -begin - if Win32PlatformIsUnicode then - Result := InsertMenuItemW{TNT-ALLOW InsertMenuItemW}(hMenu, uItem, fByPosition, lpmii) - else begin - TMenuItemInfoA(lpmii).dwTypeData := PAnsiChar(AnsiString(lpmii.dwTypeData)); - Result := InsertMenuItemA{TNT-ALLOW InsertMenuItemA}(hMenu, uItem, fByPosition, TMenuItemInfoA(lpmii)); - end; -end; - -function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; - var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; -begin - if Win32PlatformIsUnicode then - Result := ExtractIconExW{TNT-ALLOW ExtractIconExW}(lpszFile, - nIconIndex, phiconLarge, phiconSmall, nIcons) - else - Result := ExtractIconExA{TNT-ALLOW ExtractIconExA}(PAnsiChar(AnsiString(lpszFile)), - nIconIndex, phiconLarge, phiconSmall, nIcons); -end; - -function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; - var lpiIcon: Word): HICON; -begin - if Win32PlatformIsUnicode then - Result := ExtractAssociatedIconW{TNT-ALLOW ExtractAssociatedIconW}(hInst, lpIconPath, lpiIcon) - else - Result := ExtractAssociatedIconA{TNT-ALLOW ExtractAssociatedIconA}(hInst, - PAnsiChar(AnsiString(lpIconPath)), lpiIcon) -end; - -function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetFileVersionInfoSizeW{TNT-ALLOW GetFileVersionInfoSizeW}(lptstrFilename, lpdwHandle) - else - Result := GetFileVersionInfoSizeA{TNT-ALLOW GetFileVersionInfoSizeA}(PAnsiChar(AnsiString(lptstrFilename)), lpdwHandle); -end; - -function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; -begin - if Win32PlatformIsUnicode then - Result := GetFileVersionInfoW{TNT-ALLOW GetFileVersionInfoW}(lptstrFilename, dwHandle, dwLen, lpData) - else - Result := GetFileVersionInfoA{TNT-ALLOW GetFileVersionInfoA}(PAnsiChar(AnsiString(lptstrFilename)), dwHandle, dwLen, lpData); -end; - -var - Last_VerQueryValue_String: WideString; - -function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := VerQueryValueW{TNT-ALLOW VerQueryValueW}(pBlock, lpSubBlock, lplpBuffer, puLen) - else begin - Result := VerQueryValueA{TNT-ALLOW VerQueryValueA}(pBlock, PAnsiChar(AnsiString(lpSubBlock)), lplpBuffer, puLen); - if WideTextPos(VQV_STRINGFILEINFO, lpSubBlock) <> 1 then - else begin - { /StringFileInfo, convert ansi result to unicode } - SetString(AnsiBuff, PAnsiChar(lplpBuffer), puLen); - Last_VerQueryValue_String := AnsiBuff; - lplpBuffer := PWideChar(Last_VerQueryValue_String); - puLen := Length(Last_VerQueryValue_String); - end; - end; -end; - -//--------------------------------------------------------------------------------------- -// Wide functions from Shell32.dll should be loaded dynamically (no stub on early Win95) -//--------------------------------------------------------------------------------------- - -type - TSHFileOperationW = function(var lpFileOp: TSHFileOpStructW): Integer; stdcall; - TSHBrowseForFolderW = function(var lpbi: TBrowseInfoW): PItemIDList; stdcall; - TSHGetPathFromIDListW = function(pidl: PItemIDList; pszPath: PWideChar): BOOL; stdcall; - TSHGetFileInfoW = function(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; stdcall; - -var - Safe_SHFileOperationW: TSHFileOperationW = nil; - Safe_SHBrowseForFolderW: TSHBrowseForFolderW = nil; - Safe_SHGetPathFromIDListW: TSHGetPathFromIDListW = nil; - Safe_SHGetFileInfoW: TSHGetFileInfoW = nil; - -var Shell32DLL: HModule = 0; - -procedure LoadWideShell32Procs; -begin - if Shell32DLL = 0 then begin - Shell32DLL := WinCheckH(Tnt_LoadLibraryW('shell32.dll')); - Safe_SHFileOperationW := WinCheckP(GetProcAddress(Shell32DLL, 'SHFileOperationW')); - Safe_SHBrowseForFolderW := WinCheckP(GetProcAddress(Shell32DLL, 'SHBrowseForFolderW')); - Safe_SHGetPathFromIDListW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetPathFromIDListW')); - Safe_SHGetFileInfoW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetFileInfoW')); - end; -end; - -function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; -var - AnsiFileOp: TSHFileOpStructA; - MapCount: Integer; - PAnsiMap: PSHNameMappingA; - PWideMap: PSHNameMappingW; - OldPath: WideString; - NewPath: WideString; - i: integer; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHFileOperationW(lpFileOp); - end else begin - AnsiFileOp := TSHFileOpStructA(lpFileOp); - // convert PChar -> PWideChar - if lpFileOp.pFrom = nil then - AnsiFileOp.pFrom := nil - else - AnsiFileOp.pFrom := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pFrom))); - if lpFileOp.pTo = nil then - AnsiFileOp.pTo := nil - else - AnsiFileOp.pTo := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pTo))); - AnsiFileOp.lpszProgressTitle := PAnsiChar(AnsiString(lpFileOp.lpszProgressTitle)); - Result := SHFileOperationA{TNT-ALLOW SHFileOperationA}(AnsiFileOp); - // return struct results - lpFileOp.fAnyOperationsAborted := AnsiFileOp.fAnyOperationsAborted; - lpFileOp.hNameMappings := nil; - if (AnsiFileOp.hNameMappings <> nil) - and ((FOF_WANTMAPPINGHANDLE and AnsiFileOp.fFlags) <> 0) then begin - // alloc mem - MapCount := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).cNumOfMappings; - lpFileOp.hNameMappings := - AllocMem(SizeOf({hNameMappings}Cardinal) + SizeOf(TSHNameMappingW) * MapCount); - PSHNameMappingHeaderW(lpFileOp.hNameMappings).cNumOfMappings := MapCount; - // init pointers - PAnsiMap := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).lpNM; - PWideMap := PSHNameMappingHeaderW(lpFileOp.hNameMappings).lpNM; - for i := 1 to MapCount do begin - // old path - OldPath := Copy(PAnsiMap.pszOldPath, 1, PAnsiMap.cchOldPath); - PWideMap.pszOldPath := WStrNew(PWideChar(OldPath)); - PWideMap.cchOldPath := WStrLen(PWideMap.pszOldPath); - // new path - NewPath := Copy(PAnsiMap.pszNewPath, 1, PAnsiMap.cchNewPath); - PWideMap.pszNewPath := WStrNew(PWideChar(NewPath)); - PWideMap.cchNewPath := WStrLen(PWideMap.pszNewPath); - // next record - Inc(PAnsiMap); - Inc(PWideMap); - end; - end; - end; -end; - -procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); -var - i: integer; - MapCount: Integer; - PWideMap: PSHNameMappingW; -begin - if Win32PlatformIsUnicode then - SHFreeNameMappings{TNT-ALLOW SHFreeNameMappings}(hNameMappings) - else begin - // free strings - MapCount := PSHNameMappingHeaderW(hNameMappings).cNumOfMappings; - PWideMap := PSHNameMappingHeaderW(hNameMappings).lpNM; - for i := 1 to MapCount do begin - WStrDispose(PWideMap.pszOldPath); - WStrDispose(PWideMap.pszNewPath); - Inc(PWideMap); - end; - // free struct - FreeMem(Pointer(hNameMappings)); - end; -end; - -function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; -var - AnsiInfo: TBrowseInfoA; - AnsiBuffer: array[0..MAX_PATH] of AnsiChar; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHBrowseForFolderW(lpbi); - end else begin - AnsiInfo := TBrowseInfoA(lpbi); - AnsiInfo.lpszTitle := PAnsiChar(AnsiString(lpbi.lpszTitle)); - if lpbi.pszDisplayName <> nil then - AnsiInfo.pszDisplayName := AnsiBuffer; - Result := SHBrowseForFolderA{TNT-ALLOW SHBrowseForFolderA}(AnsiInfo); - if lpbi.pszDisplayName <> nil then - WStrPCopy(lpbi.pszDisplayName, AnsiInfo.pszDisplayName); - lpbi.iImage := AnsiInfo.iImage; - end; -end; - -function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; -var - AnsiPath: AnsiString; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHGetPathFromIDListW(pidl, pszPath); - end else begin - SetLength(AnsiPath, MAX_PATH); - Result := SHGetPathFromIDListA{TNT-ALLOW SHGetPathFromIDListA}(pidl, PAnsiChar(AnsiPath)); - if Result then - WStrPCopy(pszPath, PAnsiChar(AnsiPath)) - end; -end; - -function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; -var - SHFileInfoA: TSHFileInfoA; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHGetFileInfoW(pszPath, dwFileAttributes, psfi, cbFileInfo, uFlags) - end else begin - Result := SHGetFileInfoA{TNT-ALLOW SHGetFileInfoA}(PAnsiChar(AnsiString(pszPath)), - dwFileAttributes, SHFileInfoA, SizeOf(TSHFileInfoA), uFlags); - // update pfsi... - ZeroMemory(@psfi, SizeOf(TSHFileInfoW)); - psfi.hIcon := SHFileInfoA.hIcon; - psfi.iIcon := SHFileInfoA.iIcon; - psfi.dwAttributes := SHFileInfoA.dwAttributes; - WStrPLCopy(psfi.szDisplayName, SHFileInfoA.szDisplayName, MAX_PATH); - WStrPLCopy(psfi.szTypeName, SHFileInfoA.szTypeName, 80); - end; -end; - - -function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; -begin - Result := HiWord(Cardinal(ResStr)) = 0; -end; - -function LANGIDFROMLCID(lcid: LCID): WORD; -begin - Result := LoWord(lcid); -end; - -function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; -begin - Result := (usSubLanguage shl 10) or usPrimaryLanguage; -end; - -function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; -begin - Result := MakeLong(wLanguageID, wSortID); -end; - -function PRIMARYLANGID(lgid: WORD): WORD; -begin - Result := lgid and $03FF; -end; - -function SORTIDFROMLCID(lcid: LCID): WORD; -begin - Result := HiWord(lcid); -end; - -function SUBLANGID(lgid: WORD): WORD; -begin - Result := lgid shr 10; -end; - -initialization - -finalization - if Shell32DLL <> 0 then - FreeLibrary(Shell32DLL); - -end. -- cgit v1.2.3