From 7415b04d2311fcfbd6e39510d0643afea67d1933 Mon Sep 17 00:00:00 2001 From: rofl0r Date: Fri, 1 Jul 2011 00:13:19 +0200 Subject: [PATCH] initial commit --- CBuilder/TntLibD.bpk | 158 + CBuilder/TntLibD.cpp | 19 + CBuilder/TntLibD.res | Bin 0 -> 1508 bytes CBuilder/TntLibR.bpk | 165 + CBuilder/TntLibR.cpp | 18 + CBuilder/TntLibR.res | Bin 0 -> 1508 bytes Delphi/bds4/TntUnicodeVcl.bdsproj | 183 ++ Delphi/bds4/TntUnicodeVcl.cfg | 33 + Delphi/bds4/TntUnicodeVcl.dpk | 71 + Delphi/bds4/TntUnicodeVcl.res | Bin 0 -> 1508 bytes Delphi/bds4/TntUnicodeVcl_Design.bdsproj | 183 ++ Delphi/bds4/TntUnicodeVcl_Design.cfg | 36 + Delphi/bds4/TntUnicodeVcl_Design.dpk | 56 + Delphi/bds4/TntUnicodeVcl_Design.res | Bin 0 -> 1508 bytes Delphi/d6/TntUnicodeVcl_D60.cfg | 32 + Delphi/d6/TntUnicodeVcl_D60.dof | 87 + Delphi/d6/TntUnicodeVcl_D60.dpk | 57 + Delphi/d6/TntUnicodeVcl_D60.res | Bin 0 -> 1536 bytes Delphi/d6/TntUnicodeVcl_R60.cfg | 32 + Delphi/d6/TntUnicodeVcl_R60.dof | 87 + Delphi/d6/TntUnicodeVcl_R60.dpk | 71 + Delphi/d6/TntUnicodeVcl_R60.res | Bin 0 -> 1536 bytes Delphi/d6/TntUnicode_6.bpg | 23 + Delphi/d7/TntUnicodeVcl_D70.cfg | 34 + Delphi/d7/TntUnicodeVcl_D70.dof | 136 + Delphi/d7/TntUnicodeVcl_D70.dpk | 56 + Delphi/d7/TntUnicodeVcl_D70.res | Bin 0 -> 1536 bytes Delphi/d7/TntUnicodeVcl_D70_DATASNAP.cfg | 35 + Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dof | 136 + Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dpk | 37 + Delphi/d7/TntUnicodeVcl_D70_DATASNAP.res | Bin 0 -> 1536 bytes Delphi/d7/TntUnicodeVcl_R70.cfg | 32 + Delphi/d7/TntUnicodeVcl_R70.dof | 87 + Delphi/d7/TntUnicodeVcl_R70.dpk | 72 + Delphi/d7/TntUnicodeVcl_R70.res | Bin 0 -> 1536 bytes Delphi/d7/TntUnicode_7.bpg | 23 + Delphi/d9/TntUnicodeVcl_D90.bdsproj | 172 + Delphi/d9/TntUnicodeVcl_D90.cfg | 35 + Delphi/d9/TntUnicodeVcl_D90.dpk | 55 + Delphi/d9/TntUnicodeVcl_D90.res | Bin 0 -> 1508 bytes Delphi/d9/TntUnicodeVcl_R90.bdsproj | 172 + Delphi/d9/TntUnicodeVcl_R90.cfg | 32 + Delphi/d9/TntUnicodeVcl_R90.dpk | 72 + Delphi/d9/TntUnicodeVcl_R90.res | Bin 0 -> 1508 bytes Design/TntActions_Design.pas | 183 ++ Design/TntActnList.dcr | Bin 0 -> 484 bytes Design/TntButtons.dcr | Bin 0 -> 928 bytes Design/TntComCtrls.dcr | Bin 0 -> 6776 bytes Design/TntComCtrls_Design.pas | 228 ++ Design/TntDBClientActns_Design.pas | 36 + Design/TntDBCtrls.dcr | Bin 0 -> 3620 bytes Design/TntDBGrids_Design.pas | 58 + Design/TntDesignEditors_Design.pas | 196 ++ Design/TntDialogs.dcr | Bin 0 -> 936 bytes Design/TntExtCtrls.dcr | Bin 0 -> 3592 bytes Design/TntExtDlgs.dcr | Bin 0 -> 960 bytes Design/TntForms.dcr | Bin 0 -> 920 bytes Design/TntForms_Design.pas | 422 +++ Design/TntGrids.dcr | Bin 0 -> 932 bytes Design/TntMenus.dcr | Bin 0 -> 928 bytes Design/TntMenus_Design.pas | 391 +++ Design/TntStdCtrls.dcr | Bin 0 -> 5392 bytes Design/TntStrEdit_Design.dfm | 135 + Design/TntStrEdit_Design.pas | 419 +++ Design/TntUnicodeVcl_Register.pas | 132 + Design/TntWideStringProperty_Design.pas | 400 +++ Example/ExampleUnicode.cfg | 35 + Example/ExampleUnicode.dof | 87 + Example/ExampleUnicode.dpr | 13 + Example/ExampleUnicode.res | Bin 0 -> 1536 bytes Example/MainFrm.dfm | 143 + Example/MainFrm.pas | 72 + License.rtf | 52 + Readme.txt | 53 + Reset Tnt Palette.reg | Bin 0 -> 1669 bytes Source/ActiveIMM_TLB.pas | 1374 ++++++++ Source/TntActnList.pas | 835 +++++ Source/TntAxCtrls.pas | 191 ++ Source/TntBandActn.pas | 92 + Source/TntButtons.pas | 982 ++++++ Source/TntCheckLst.pas | 184 ++ Source/TntClasses.pas | 1799 +++++++++++ Source/TntClipBrd.pas | 86 + Source/TntComCtrls.pas | 5058 ++++++++++++++++++++++++++++++ Source/TntCompilers.inc | 356 +++ Source/TntControls.pas | 1099 +++++++ Source/TntDB.pas | 900 ++++++ Source/TntDBActns.pas | 594 ++++ Source/TntDBClientActns.pas | 197 ++ Source/TntDBCtrls.pas | 2195 +++++++++++++ Source/TntDBGrids.pas | 1175 +++++++ Source/TntDBLogDlg.dfm | 108 + Source/TntDBLogDlg.pas | 133 + Source/TntDialogs.pas | 981 ++++++ Source/TntExtActns.pas | 1400 +++++++++ Source/TntExtCtrls.pas | 1062 +++++++ Source/TntExtDlgs.pas | 317 ++ Source/TntFileCtrl.pas | 118 + Source/TntFormatStrUtils.pas | 503 +++ Source/TntForms.pas | 954 ++++++ Source/TntGraphics.pas | 142 + Source/TntGrids.pas | 675 ++++ Source/TntListActns.pas | 207 ++ Source/TntMenus.pas | 1146 +++++++ Source/TntRegistry.pas | 148 + Source/TntStdActns.pas | 1922 ++++++++++++ Source/TntStdCtrls.pas | 3215 +++++++++++++++++++ Source/TntSysUtils.pas | 1883 +++++++++++ Source/TntSystem.pas | 1397 +++++++++ Source/TntWideStrUtils.pas | 451 +++ Source/TntWideStrings.pas | 831 +++++ Source/TntWindows.pas | 1452 +++++++++ 112 files changed, 41714 insertions(+) create mode 100644 CBuilder/TntLibD.bpk create mode 100644 CBuilder/TntLibD.cpp create mode 100644 CBuilder/TntLibD.res create mode 100644 CBuilder/TntLibR.bpk create mode 100644 CBuilder/TntLibR.cpp create mode 100644 CBuilder/TntLibR.res create mode 100644 Delphi/bds4/TntUnicodeVcl.bdsproj create mode 100644 Delphi/bds4/TntUnicodeVcl.cfg create mode 100644 Delphi/bds4/TntUnicodeVcl.dpk create mode 100644 Delphi/bds4/TntUnicodeVcl.res create mode 100644 Delphi/bds4/TntUnicodeVcl_Design.bdsproj create mode 100644 Delphi/bds4/TntUnicodeVcl_Design.cfg create mode 100644 Delphi/bds4/TntUnicodeVcl_Design.dpk create mode 100644 Delphi/bds4/TntUnicodeVcl_Design.res create mode 100644 Delphi/d6/TntUnicodeVcl_D60.cfg create mode 100644 Delphi/d6/TntUnicodeVcl_D60.dof create mode 100644 Delphi/d6/TntUnicodeVcl_D60.dpk create mode 100644 Delphi/d6/TntUnicodeVcl_D60.res create mode 100644 Delphi/d6/TntUnicodeVcl_R60.cfg create mode 100644 Delphi/d6/TntUnicodeVcl_R60.dof create mode 100644 Delphi/d6/TntUnicodeVcl_R60.dpk create mode 100644 Delphi/d6/TntUnicodeVcl_R60.res create mode 100644 Delphi/d6/TntUnicode_6.bpg create mode 100644 Delphi/d7/TntUnicodeVcl_D70.cfg create mode 100644 Delphi/d7/TntUnicodeVcl_D70.dof create mode 100644 Delphi/d7/TntUnicodeVcl_D70.dpk create mode 100644 Delphi/d7/TntUnicodeVcl_D70.res create mode 100644 Delphi/d7/TntUnicodeVcl_D70_DATASNAP.cfg create mode 100644 Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dof create mode 100644 Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dpk create mode 100644 Delphi/d7/TntUnicodeVcl_D70_DATASNAP.res create mode 100644 Delphi/d7/TntUnicodeVcl_R70.cfg create mode 100644 Delphi/d7/TntUnicodeVcl_R70.dof create mode 100644 Delphi/d7/TntUnicodeVcl_R70.dpk create mode 100644 Delphi/d7/TntUnicodeVcl_R70.res create mode 100644 Delphi/d7/TntUnicode_7.bpg create mode 100644 Delphi/d9/TntUnicodeVcl_D90.bdsproj create mode 100644 Delphi/d9/TntUnicodeVcl_D90.cfg create mode 100644 Delphi/d9/TntUnicodeVcl_D90.dpk create mode 100644 Delphi/d9/TntUnicodeVcl_D90.res create mode 100644 Delphi/d9/TntUnicodeVcl_R90.bdsproj create mode 100644 Delphi/d9/TntUnicodeVcl_R90.cfg create mode 100644 Delphi/d9/TntUnicodeVcl_R90.dpk create mode 100644 Delphi/d9/TntUnicodeVcl_R90.res create mode 100644 Design/TntActions_Design.pas create mode 100644 Design/TntActnList.dcr create mode 100644 Design/TntButtons.dcr create mode 100644 Design/TntComCtrls.dcr create mode 100644 Design/TntComCtrls_Design.pas create mode 100644 Design/TntDBClientActns_Design.pas create mode 100644 Design/TntDBCtrls.dcr create mode 100644 Design/TntDBGrids_Design.pas create mode 100644 Design/TntDesignEditors_Design.pas create mode 100644 Design/TntDialogs.dcr create mode 100644 Design/TntExtCtrls.dcr create mode 100644 Design/TntExtDlgs.dcr create mode 100644 Design/TntForms.dcr create mode 100644 Design/TntForms_Design.pas create mode 100644 Design/TntGrids.dcr create mode 100644 Design/TntMenus.dcr create mode 100644 Design/TntMenus_Design.pas create mode 100644 Design/TntStdCtrls.dcr create mode 100644 Design/TntStrEdit_Design.dfm create mode 100644 Design/TntStrEdit_Design.pas create mode 100644 Design/TntUnicodeVcl_Register.pas create mode 100644 Design/TntWideStringProperty_Design.pas create mode 100644 Example/ExampleUnicode.cfg create mode 100644 Example/ExampleUnicode.dof create mode 100644 Example/ExampleUnicode.dpr create mode 100644 Example/ExampleUnicode.res create mode 100644 Example/MainFrm.dfm create mode 100644 Example/MainFrm.pas create mode 100644 License.rtf create mode 100644 Readme.txt create mode 100644 Reset Tnt Palette.reg create mode 100644 Source/ActiveIMM_TLB.pas create mode 100644 Source/TntActnList.pas create mode 100644 Source/TntAxCtrls.pas create mode 100644 Source/TntBandActn.pas create mode 100644 Source/TntButtons.pas create mode 100644 Source/TntCheckLst.pas create mode 100644 Source/TntClasses.pas create mode 100644 Source/TntClipBrd.pas create mode 100644 Source/TntComCtrls.pas create mode 100644 Source/TntCompilers.inc create mode 100644 Source/TntControls.pas create mode 100644 Source/TntDB.pas create mode 100644 Source/TntDBActns.pas create mode 100644 Source/TntDBClientActns.pas create mode 100644 Source/TntDBCtrls.pas create mode 100644 Source/TntDBGrids.pas create mode 100644 Source/TntDBLogDlg.dfm create mode 100644 Source/TntDBLogDlg.pas create mode 100644 Source/TntDialogs.pas create mode 100644 Source/TntExtActns.pas create mode 100644 Source/TntExtCtrls.pas create mode 100644 Source/TntExtDlgs.pas create mode 100644 Source/TntFileCtrl.pas create mode 100644 Source/TntFormatStrUtils.pas create mode 100644 Source/TntForms.pas create mode 100644 Source/TntGraphics.pas create mode 100644 Source/TntGrids.pas create mode 100644 Source/TntListActns.pas create mode 100644 Source/TntMenus.pas create mode 100644 Source/TntRegistry.pas create mode 100644 Source/TntStdActns.pas create mode 100644 Source/TntStdCtrls.pas create mode 100644 Source/TntSysUtils.pas create mode 100644 Source/TntSystem.pas create mode 100644 Source/TntWideStrUtils.pas create mode 100644 Source/TntWideStrings.pas create mode 100644 Source/TntWindows.pas diff --git a/CBuilder/TntLibD.bpk b/CBuilder/TntLibD.bpk new file mode 100644 index 0000000..b04ea53 --- /dev/null +++ b/CBuilder/TntLibD.bpk @@ -0,0 +1,158 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/CBuilder/TntLibD.cpp b/CBuilder/TntLibD.cpp new file mode 100644 index 0000000..5a6e53d --- /dev/null +++ b/CBuilder/TntLibD.cpp @@ -0,0 +1,19 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +USEFORMNS("..\Design\TntStrEdit_Design.pas", Tntstredit_design, TntStrEditDlg); /* TTntForm: File Type */ +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/CBuilder/TntLibD.res b/CBuilder/TntLibD.res new file mode 100644 index 0000000000000000000000000000000000000000..27b0b6eb9ca618372c19c7b5f99f7a315e4d5132 GIT binary patch literal 1508 zcwU`T!HUyR6g{a~=tjD57hUx0i}ZlXnG z`Bc|MYB^srJ}>Y*v^M@O(zU>i5@3NPynn+(FD+p!Rb+9Eq7C(N6;JU9J9tJkvCGj# z@mxqr54D=Fr$SDVhyDC4RWCeC`;|JMZS3KI&uzTm+m3cP(0-5kF7eg>`DSxt#piVr{aU0_3rtYOl%`pb(Q2&u`I%J1= z{ky7hH3Q-uUTLoZd-j+c=GqNhE@<1tkm{x8KJHQD;QEWtk!nNs?yoqwt(qs~U0oHo z1NsyPUA$pt(dSb4l8O#qlOJ;&;w_z&_q3bU=w*GK@37S0dVEgp39G&5-bZWSsIL1i iYgTu^y7xdc+v;uoj{&#zZ`)mjtkdUM{N7jmbN@F6r+J6~ literal 0 HcwPel00001 diff --git a/CBuilder/TntLibR.bpk b/CBuilder/TntLibR.bpk new file mode 100644 index 0000000..7c5ea9e --- /dev/null +++ b/CBuilder/TntLibR.bpk @@ -0,0 +1,165 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/CBuilder/TntLibR.cpp b/CBuilder/TntLibR.cpp new file mode 100644 index 0000000..4e4d7bc --- /dev/null +++ b/CBuilder/TntLibR.cpp @@ -0,0 +1,18 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +USEFORMNS("..\Source\TntDBLogDlg.pas", Tntdblogdlg, TntLoginDialog); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/CBuilder/TntLibR.res b/CBuilder/TntLibR.res new file mode 100644 index 0000000000000000000000000000000000000000..27b0b6eb9ca618372c19c7b5f99f7a315e4d5132 GIT binary patch literal 1508 zcwU`T!HUyR6g{a~=tjD57hUx0i}ZlXnG z`Bc|MYB^srJ}>Y*v^M@O(zU>i5@3NPynn+(FD+p!Rb+9Eq7C(N6;JU9J9tJkvCGj# z@mxqr54D=Fr$SDVhyDC4RWCeC`;|JMZS3KI&uzTm+m3cP(0-5kF7eg>`DSxt#piVr{aU0_3rtYOl%`pb(Q2&u`I%J1= z{ky7hH3Q-uUTLoZd-j+c=GqNhE@<1tkm{x8KJHQD;QEWtk!nNs?yoqwt(qs~U0oHo z1NsyPUA$pt(dSb4l8O#qlOJ;&;w_z&_q3bU=w*GK@37S0dVEgp39G&5-bZWSsIL1i iYgTu^y7xdc+v;uoj{&#zZ`)mjtkdUM{N7jmbN@F6r+J6~ literal 0 HcwPel00001 diff --git a/Delphi/bds4/TntUnicodeVcl.bdsproj b/Delphi/bds4/TntUnicodeVcl.bdsproj new file mode 100644 index 0000000..d36baae --- /dev/null +++ b/Delphi/bds4/TntUnicodeVcl.bdsproj @@ -0,0 +1,183 @@ + + + + + + + + + + + + TntUnicodeVcl.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + + + + 0 + 44 + 1 + False + False + False + 16384 + 1048576 + 4194304 + TntWare Unicode Controls - Runtime + False + + + + + + + + + + + False + + + + + + False + + + + + + False + + True + + False + False + + + + $00000000 + + + + True + False + 2 + 3 + 0 + 1 + False + False + False + False + False + 1033 + 1252 + + + + + 2.3.0.1 + + + + + + 2.3.0.1 + + + + + diff --git a/Delphi/bds4/TntUnicodeVcl.cfg b/Delphi/bds4/TntUnicodeVcl.cfg new file mode 100644 index 0000000..e1ad800 --- /dev/null +++ b/Delphi/bds4/TntUnicodeVcl.cfg @@ -0,0 +1,33 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-JL +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 diff --git a/Delphi/bds4/TntUnicodeVcl.dpk b/Delphi/bds4/TntUnicodeVcl.dpk new file mode 100644 index 0000000..49617e2 --- /dev/null +++ b/Delphi/bds4/TntUnicodeVcl.dpk @@ -0,0 +1,71 @@ +package TntUnicodeVcl; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS ON} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'TntWare Unicode Controls - Runtime'} +{$LIBSUFFIX '100'} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + vcl, + vclx, + vcldb, + vclactnband; + +contains + ActiveIMM_TLB in '..\..\Source\ActiveIMM_TLB.pas', + TntSystem in '..\..\Source\TntSystem.pas', + TntAxCtrls in '..\..\Source\TntAxCtrls.pas', + TntClipbrd in '..\..\Source\TntClipbrd.pas', + TntWindows in '..\..\Source\TntWindows.pas', + TntSysUtils in '..\..\Source\TntSysUtils.pas', + TntClasses in '..\..\Source\TntClasses.pas', + TntDialogs in '..\..\Source\TntDialogs.pas', + TntFileCtrl in '..\..\Source\TntFileCtrl.pas', + TntExtDlgs in '..\..\Source\TntExtDlgs.pas', + TntRegistry in '..\..\Source\TntRegistry.pas', + TntGraphics in '..\..\Source\TntGraphics.pas', + TntControls in '..\..\Source\TntControls.pas', + TntActnList in '..\..\Source\TntActnList.pas', + TntMenus in '..\..\Source\TntMenus.pas', + TntForms in '..\..\Source\TntForms.pas', + TntStdCtrls in '..\..\Source\TntStdCtrls.pas', + TntExtCtrls in '..\..\Source\TntExtCtrls.pas', + TntButtons in '..\..\Source\TntButtons.pas', + TntCheckLst in '..\..\Source\TntCheckLst.pas', + TntGrids in '..\..\Source\TntGrids.pas', + TntComCtrls in '..\..\Source\TntComCtrls.pas', + TntDB in '..\..\Source\TntDB.pas', + TntDBCtrls in '..\..\Source\TntDBCtrls.pas', + TntDBGrids in '..\..\Source\TntDBGrids.pas', + TntStdActns in '..\..\Source\TntStdActns.pas', + TntExtActns in '..\..\Source\TntExtActns.pas', + TntListActns in '..\..\Source\TntListActns.pas', + TntDBActns in '..\..\Source\TntDBActns.pas', + TntBandActn in '..\..\Source\TntBandActn.pas', + TntDBLogDlg in '..\..\Source\TntDBLogDlg.pas', + TntFormatStrUtils in '..\..\Source\TntFormatStrUtils.pas', + TntWideStrUtils in '..\..\Source\TntWideStrUtils.pas'; + +end. diff --git a/Delphi/bds4/TntUnicodeVcl.res b/Delphi/bds4/TntUnicodeVcl.res new file mode 100644 index 0000000000000000000000000000000000000000..b69d77e0cc8f3c300c14942fe1dd1bb09669ab6a GIT binary patch literal 1508 zcwUuL&ubGw6#ll2YsCi*4LCY2Qc=Sy0&( z4;8BP=%2BbAm&f;;K7>}Y>g<6-^?bpKlI>i-cG(Z-@Ny|H#-2(Pt!WHo#RtiXT6)| zSfA(hn@&vM29~(lPOzAtHmqDN^eD^W*WMrTh+Muq_6f^ z8pMX6U%y$O7I}%&|N8&k=Etv1Z#o&=}ugp8Y?8bNuq^y4hVnK<)s{x40MAa1kT8 zPP>E~oI7Ldy)aT7^!I!AR+wAlU}Ezwd4Ii26J0}mk6{#(d=KL$|BcuTlQ!RF{x{=Y z?(;7buNz&q;Ld!$9Vds~jaapgQB*OHX_OH#+B9ZxpOMS(@rbLhEN1{iw6k^|hEa6H z)^drQS>ClN@*h*p6w&?7_$Mr<6SGLG;I7RTGUqh+mN&Tr$Zz3}(dNni!#RzU7^Dr* zPHpBlI;)mjX6~6C3XWOMRpP*|8nq#H8U+C!aOYN?e|WdZn8H2cSI(^w++5u+`z_Uf)44cWT4b9Pq0v-YChIcBx(J~7~^J?*TDGULo}-rDb; H+{fH+`TSqu literal 0 HcwPel00001 diff --git a/Delphi/bds4/TntUnicodeVcl_Design.bdsproj b/Delphi/bds4/TntUnicodeVcl_Design.bdsproj new file mode 100644 index 0000000..f41f6b0 --- /dev/null +++ b/Delphi/bds4/TntUnicodeVcl_Design.bdsproj @@ -0,0 +1,183 @@ + + + + + + + + + + + + TntUnicodeVcl_Design.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + + + + 0 + 44 + 1 + False + False + False + 16384 + 1048576 + 4194304 + TntWare Unicode Controls + False + + + + + + + + + + + False + + + + + + False + + + + + + False + + True + + False + False + + + + $00000000 + + + + True + False + 2 + 3 + 0 + 1 + False + False + False + False + False + 1033 + 1252 + + + + + 2.3.0.1 + + + + + + 2.3.0.1 + + + + + diff --git a/Delphi/bds4/TntUnicodeVcl_Design.cfg b/Delphi/bds4/TntUnicodeVcl_Design.cfg new file mode 100644 index 0000000..dc552d3 --- /dev/null +++ b/Delphi/bds4/TntUnicodeVcl_Design.cfg @@ -0,0 +1,36 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-JL +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Delphi/bds4/TntUnicodeVcl_Design.dpk b/Delphi/bds4/TntUnicodeVcl_Design.dpk new file mode 100644 index 0000000..8d5c8a0 --- /dev/null +++ b/Delphi/bds4/TntUnicodeVcl_Design.dpk @@ -0,0 +1,56 @@ +package TntUnicodeVcl_Design; + +{$R *.res} +{$R '..\..\Design\TntComCtrls.dcr'} +{$R '..\..\Design\TntDBCtrls.dcr'} +{$R '..\..\Design\TntStdCtrls.dcr'} +{$R '..\..\Design\TntActnList.dcr'} +{$R '..\..\Design\TntMenus.dcr'} +{$R '..\..\Design\TntExtCtrls.dcr'} +{$R '..\..\Design\TntForms.dcr'} +{$R '..\..\Design\TntGrids.dcr'} +{$R '..\..\Design\TntButtons.dcr'} +{$R '..\..\Design\TntDialogs.dcr'} +{$R '..\..\Design\TntExtDlgs.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS ON} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'TntWare Unicode Controls'} +{$LIBSUFFIX '100'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + TntUnicodeVcl, + designide, + dcldb; + +contains + TntForms_Design in '..\..\Design\TntForms_Design.pas', + TntComCtrls_Design in '..\..\Design\TntComCtrls_Design.pas', + TntDBGrids_Design in '..\..\Design\TntDBGrids_Design.pas', + TntDesignEditors_Design in '..\..\Design\TntDesignEditors_Design.pas', + TntStrEdit_Design in '..\..\Design\TntStrEdit_Design.pas', + TntUnicodeVcl_Register in '..\..\Design\TntUnicodeVcl_Register.pas', + TntActions_Design in '..\..\Design\TntActions_Design.pas', + TntMenus_Design in '..\..\Design\TntMenus_Design.pas'; + +end. diff --git a/Delphi/bds4/TntUnicodeVcl_Design.res b/Delphi/bds4/TntUnicodeVcl_Design.res new file mode 100644 index 0000000000000000000000000000000000000000..b69d77e0cc8f3c300c14942fe1dd1bb09669ab6a GIT binary patch literal 1508 zcwUuL&ubGw6#ll2YsCi*4LCY2Qc=Sy0&( z4;8BP=%2BbAm&f;;K7>}Y>g<6-^?bpKlI>i-cG(Z-@Ny|H#-2(Pt!WHo#RtiXT6)| zSfA(hn@&vM29~(lPOzAtHmqDN^eD^W*WMrTh+Muq_6f^ z8pMX6U%y$O7I}%&|N8&k=Etv1Z#o&=}ugp8Y?8bNuq^y4hVnK<)s{x40MAa1kT8 zPP>E~oI7Ldy)aT7^!I!AR+wAlU}Ezwd4Ii26J0}mk6{#(d=KL$|BcuTlQ!RF{x{=Y z?(;7buNz&q;Ld!$9Vds~jaapgQB*OHX_OH#+B9ZxpOMS(@rbLhEN1{iw6k^|hEa6H z)^drQS>ClN@*h*p6w&?7_$Mr<6SGLG;I7RTGUqh+mN&Tr$Zz3}(dNni!#RzU7^Dr* zPHpBlI;)mjX6~6C3XWOMRpP*|8nq#H8U+C!aOYN?e|WdZn8H2cSI(^w++5u+`z_Uf)44cWT4b9Pq0v-YChIcBx(J~7~^J?*TDGULo}-rDb; H+{fH+`TSqu literal 0 HcwPel00001 diff --git a/Delphi/d6/TntUnicodeVcl_D60.cfg b/Delphi/d6/TntUnicodeVcl_D60.cfg new file mode 100644 index 0000000..66fb3af --- /dev/null +++ b/Delphi/d6/TntUnicodeVcl_D60.cfg @@ -0,0 +1,32 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 diff --git a/Delphi/d6/TntUnicodeVcl_D60.dof b/Delphi/d6/TntUnicodeVcl_D60.dof new file mode 100644 index 0000000..f74c4af --- /dev/null +++ b/Delphi/d6/TntUnicodeVcl_D60.dof @@ -0,0 +1,87 @@ +[FileVersion] +Version=6.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=1 +R=1 +S=0 +T=1 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases= +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=Tnt Unicode Controls +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages= +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang=$00000409 +RootDir= +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=2 +MinorVer=3 +Release=0 +Build=1 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=2.3.0.1 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=2.3.0.1 +Comments= diff --git a/Delphi/d6/TntUnicodeVcl_D60.dpk b/Delphi/d6/TntUnicodeVcl_D60.dpk new file mode 100644 index 0000000..300208c --- /dev/null +++ b/Delphi/d6/TntUnicodeVcl_D60.dpk @@ -0,0 +1,57 @@ +package TntUnicodeVcl_D60; + +{$R *.res} +{$R '..\..\Design\TntComCtrls.dcr'} +{$R '..\..\Design\TntDBCtrls.dcr'} +{$R '..\..\Design\TntStdCtrls.dcr'} +{$R '..\..\Design\TntActnList.dcr'} +{$R '..\..\Design\TntMenus.dcr'} +{$R '..\..\Design\TntExtCtrls.dcr'} +{$R '..\..\Design\TntForms.dcr'} +{$R '..\..\Design\TntGrids.dcr'} +{$R '..\..\Design\TntButtons.dcr'} +{$R '..\..\Design\TntDialogs.dcr'} +{$R '..\..\Design\TntExtDlgs.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS ON} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Tnt Unicode Controls'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + dclact, + dcldb, + designide, + TntUnicodeVcl_R60; + +contains + TntForms_Design in '..\..\Design\TntForms_Design.pas', + TntComCtrls_Design in '..\..\Design\TntComCtrls_Design.pas', + TntDBGrids_Design in '..\..\Design\TntDBGrids_Design.pas', + TntDesignEditors_Design in '..\..\Design\TntDesignEditors_Design.pas', + TntWideStringProperty_Design in '..\..\Design\TntWideStringProperty_Design.pas', + TntMenus_Design in '..\..\Design\TntMenus_Design.pas', + TntStrEdit_Design in '..\..\Design\TntStrEdit_Design.pas', + TntUnicodeVcl_Register in '..\..\Design\TntUnicodeVcl_Register.pas', + TntActions_Design in '..\..\Design\TntActions_Design.pas'; + +end. diff --git a/Delphi/d6/TntUnicodeVcl_D60.res b/Delphi/d6/TntUnicodeVcl_D60.res new file mode 100644 index 0000000000000000000000000000000000000000..1694512495aca6f109f47a8bba113e17ee2382be GIT binary patch literal 1536 zcwT)|O=}ZT6g`s(8N0Cwx)2vOh={n5)CP)lQKfC5pjND8+X>ot zY<4ak?msf;pA!~zxR=5;qbFbVdU{bG72-4+jTi~!tBlB^KH_U?ESJkBGX9_2+rxHz zcgmd^epCRu!gatofn6w(AEF%!2A<-cV+0w$FWfbPLw_jT2)e%SYwqd;5%+{=>i%(@ zd!EUs6SO_A?iucC?g_8=g=Zo@NbsZjFrh#4{r(Iey1Jh5&;HPN47bR;$AjZ#WjEuw z)~%(}+?~F60$qTCgT+kWT`8D^u9agL2dDY~14;#Fr5#q(-Pt0LlICqd0wwM``Z1il zxN-y|Cx~#iAXp{t!3n;>3Vu>D2ELvFs|E{Wjrq|v7{@@pL)hm)~P+| zTRv?{g&nC^;ZXZj}GAXu_Q9!~xz*tu|}cc(xU33%C)}mWh3; zr<$jDf+eCrEJpQ}&yHwYtlgM#@K7`_$*Z!f+_vdcIjG_zPsV*tb?>OC-~)M+>ptpq zlI&^A3rzV`Tr+C66b#NIoX-ceEdPHJYmpY8o_?Aot zY<4ak?msf;pA!~zxR=5;qbFbVdU{bG72-4+jTi~!tBlB^KH_U?ESJkBGX9_2+rxHz zcgmd^epCRu!gatofn6w(AEF%!2A<-cV+0w$FWfbPLw_jT2)e%SYwqd;5%+{=>i%(@ zd!EUs6SO_A?iucC?g_8=g=Zo@NbsZjFrh#4{r(Iey1Jh5&;HPN47bR;$AjZ#WjEuw z)~%(}+?~F60$qTCgT+kWT`8D^u9agL2dDY~14;#Fr5#q(-Pt0LlICqd0wwM``Z1il zxN-y|Cx~#iAXp{t!3n;>3Vu>D2ELvFs|E{Wjrq|v7{@@pL)hm)~P+| zTRv?{g&nC^;ZXZj}GAXu_Q9!~xz*tu|}cc(xU33%C)}mWh3; zr<$jDf+eCrEJpQ}&yHwYtlgM#@K7`_$*Z!f+_vdcIjG_zPsV*tb?>OC-~)M+>ptpq zlI&^A3rzV`Tr+C66b#NIoX-ceEdPHJYmpY8o_?A&ubGw6#kMdBqdUF@Z_aMM5G6aw$OU9m8O+~TCvh=DYm-}wn^x&JCTB>6wE*l z{ZFKj!wQ2CPu~3t1U+~&Hw%`IZ{F-~lT_d4+u3j4_kPUmP5@w%ptZ%Q{mdr*93jJV zrP7#__;1JY3xo{pbSsPhSc`vXwd`OnGex&vuSYYQf2I*0%*B0a6#Z#qr6f~P2{ON& z@Ph1!X(3V$a*{r!kWwnuz2HVLE8tWrG4H5u7tV4RRuUfhc;tC*xL^}>B0ukjq33Ne zFOomsY?42SdDj>1_IuZJIiMhw-)uHR3b6^45_7WcCjOL%ZdzbY%20Z-zCZ5Vw7^<2F3zPNOy6dqJ*0b zEh-fYXw!Y>KxDT6fH{ntUx!eUU>-qrY4<5maF}Xzlrd>DEA_D>**Y;lk+CUT2g7!P zRz~Xty_`iqcclB{(ETfT*DqlH)Bu<;I2*vZ#k_&Gn9zqu$GWAz=-ydQ_ugjow+C0r zl_%r~hlC#CGvPaZf4{F$7v|&AdK^#i5G!~}Si~xgi4C3$a~d+3oGkIFFsCSkAU#W^ zf1afvJ45$%tYL%hOL$ICD_miN>n+o>u}{vgbCWNJEKHVUoR9N3Tz%NS^28bf?4ybr zJjzzZF19Ii4KC{B{lJn@wWdY5pnJBsnVtA1}F9 zgKAbOww7wkC=6)V3HzkJ(A>ivOcTn4yJ>yXXTaJT)!rTH;1+8h6ZhC_x@}OOrUMT< zNY2RAi0%a`HnBx~kH&qxf(-6d`8+jWqVC)4=(M|46l1wGrIcG owO=3D`#r82q#fEns&(%B^4kP%@|R#&Sfi+28VBFSnDfK=3-X3TXaE2J literal 0 HcwPel00001 diff --git a/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.cfg b/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.cfg new file mode 100644 index 0000000..9adbd44 --- /dev/null +++ b/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.cfg @@ -0,0 +1,35 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dof b/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dof new file mode 100644 index 0000000..64efb5f --- /dev/null +++ b/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dof @@ -0,0 +1,136 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=1 +R=1 +S=0 +T=1 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases= +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=Tnt Unicode Controls +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages= +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir=C:\dev\library\TntUnicodeVcl\Packages\ +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=2 +MinorVer=3 +Release=0 +Build=1 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=2.3.0.1 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=2.3.0.1 +Comments= diff --git a/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dpk b/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dpk new file mode 100644 index 0000000..0533900 --- /dev/null +++ b/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.dpk @@ -0,0 +1,37 @@ +package TntUnicodeVcl_D70_DATASNAP; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS ON} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Tnt Unicode Controls'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + dclmid, + TntUnicodeVcl_D70; + +contains + TntDBClientActns in '..\..\TntDBClientActns.pas', + TntDBClientActns_Design in '..\..\Design\TntDBClientActns_Design.pas'; + +end. diff --git a/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.res b/Delphi/d7/TntUnicodeVcl_D70_DATASNAP.res new file mode 100644 index 0000000000000000000000000000000000000000..32e6812f8f679478a403d720821db9c74a1ab313 GIT binary patch literal 1536 zcwTi>&ubGw6#kMdBqdUF@Z_aMM5G6aw$OU9m8O+~TCvh=DYm-}wn^x&JCTB>6wE*l z{ZFKj!wQ2CPu~3t1U+~&Hw%`IZ{F-~lT_d4+u3j4_kPUmP5@w%ptZ%Q{mdr*93jJV zrP7#__;1JY3xo{pbSsPhSc`vXwd`OnGex&vuSYYQf2I*0%*B0a6#Z#qr6f~P2{ON& z@Ph1!X(3V$a*{r!kWwnuz2HVLE8tWrG4H5u7tV4RRuUfhc;tC*xL^}>B0ukjq33Ne zFOomsY?42SdDj>1_IuZJIiMhw-)uHR3b6^45_7WcCjOL%ZdzbY%20Z-zCZ5Vw7^<2F3zPNOy6dqJ*0b zEh-fYXw!Y>KxDT6fH{ntUx!eUU>-qrY4<5maF}Xzlrd>DEA_D>**Y;lk+CUT2g7!P zRz~Xty_`iqcclB{(ETfT*DqlH)Bu<;I2*vZ#k_&Gn9zqu$GWAz=-ydQ_ugjow+C0r zl_%r~hlC#CGvPaZf4{F$7v|&AdK^#i5G!~}Si~xgi4C3$a~d+3oGkIFFsCSkAU#W^ zf1afvJ45$%tYL%hOL$ICD_miN>n+o>u}{vgbCWNJEKHVUoR9N3Tz%NS^28bf?4ybr zJjzzZF19Ii4KC{B{lJn@wWdY5pnJBsnVtA1}F9 zgKAbOww7wkC=6)V3HzkJ(A>ivOcTn4yJ>yXXTaJT)!rTH;1+8h6ZhC_x@}OOrUMT< zNY2RAi0%a`HnBx~kH&qxf(-6d`8+jWqVC)4=(M|46l1wGrIcG owO=3D`#r82q#fEns&(%B^4kP%@|R#&Sfi+28VBFSnDfK=3-X3TXaE2J literal 0 HcwPel00001 diff --git a/Delphi/d7/TntUnicodeVcl_R70.cfg b/Delphi/d7/TntUnicodeVcl_R70.cfg new file mode 100644 index 0000000..66fb3af --- /dev/null +++ b/Delphi/d7/TntUnicodeVcl_R70.cfg @@ -0,0 +1,32 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 diff --git a/Delphi/d7/TntUnicodeVcl_R70.dof b/Delphi/d7/TntUnicodeVcl_R70.dof new file mode 100644 index 0000000..1f1eaaa --- /dev/null +++ b/Delphi/d7/TntUnicodeVcl_R70.dof @@ -0,0 +1,87 @@ +[FileVersion] +Version=6.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=1 +R=1 +S=0 +T=1 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases= +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=Tnt Unicode Controls - Runtime +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages= +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=2 +MinorVer=3 +Release=0 +Build=1 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=2.3.0.1 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=2.3.0.1 +Comments= diff --git a/Delphi/d7/TntUnicodeVcl_R70.dpk b/Delphi/d7/TntUnicodeVcl_R70.dpk new file mode 100644 index 0000000..594b32e --- /dev/null +++ b/Delphi/d7/TntUnicodeVcl_R70.dpk @@ -0,0 +1,72 @@ +package TntUnicodeVcl_R70; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS ON} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Tnt Unicode Controls - Runtime'} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + vcl, + vclx, + vcldb, + dsnap, + vclactnband; + +contains + ActiveIMM_TLB in '..\..\Source\ActiveIMM_TLB.pas', + TntSystem in '..\..\Source\TntSystem.pas', + TntAxCtrls in '..\..\Source\TntAxCtrls.pas', + TntClipbrd in '..\..\Source\TntClipbrd.pas', + TntWindows in '..\..\Source\TntWindows.pas', + TntSysUtils in '..\..\Source\TntSysUtils.pas', + TntClasses in '..\..\Source\TntClasses.pas', + TntDialogs in '..\..\Source\TntDialogs.pas', + TntFileCtrl in '..\..\Source\TntFileCtrl.pas', + TntExtDlgs in '..\..\Source\TntExtDlgs.pas', + TntRegistry in '..\..\Source\TntRegistry.pas', + TntGraphics in '..\..\Source\TntGraphics.pas', + TntControls in '..\..\Source\TntControls.pas', + TntActnList in '..\..\Source\TntActnList.pas', + TntMenus in '..\..\Source\TntMenus.pas', + TntForms in '..\..\Source\TntForms.pas', + TntStdCtrls in '..\..\Source\TntStdCtrls.pas', + TntExtCtrls in '..\..\Source\TntExtCtrls.pas', + TntButtons in '..\..\Source\TntButtons.pas', + TntCheckLst in '..\..\Source\TntCheckLst.pas', + TntGrids in '..\..\Source\TntGrids.pas', + TntComCtrls in '..\..\Source\TntComCtrls.pas', + TntDB in '..\..\Source\TntDB.pas', + TntDBCtrls in '..\..\Source\TntDBCtrls.pas', + TntDBGrids in '..\..\Source\TntDBGrids.pas', + TntStdActns in '..\..\Source\TntStdActns.pas', + TntExtActns in '..\..\Source\TntExtActns.pas', + TntListActns in '..\..\Source\TntListActns.pas', + TntDBActns in '..\..\Source\TntDBActns.pas', + TntBandActn in '..\..\Source\TntBandActn.pas', + TntDBLogDlg in '..\..\Source\TntDBLogDlg.pas', + TntFormatStrUtils in '..\..\Source\TntFormatStrUtils.pas', + TntWideStrings in '..\..\Source\TntWideStrings.pas', + TntWideStrUtils in '..\..\Source\TntWideStrUtils.pas'; + +end. diff --git a/Delphi/d7/TntUnicodeVcl_R70.res b/Delphi/d7/TntUnicodeVcl_R70.res new file mode 100644 index 0000000000000000000000000000000000000000..32e6812f8f679478a403d720821db9c74a1ab313 GIT binary patch literal 1536 zcwTi>&ubGw6#kMdBqdUF@Z_aMM5G6aw$OU9m8O+~TCvh=DYm-}wn^x&JCTB>6wE*l z{ZFKj!wQ2CPu~3t1U+~&Hw%`IZ{F-~lT_d4+u3j4_kPUmP5@w%ptZ%Q{mdr*93jJV zrP7#__;1JY3xo{pbSsPhSc`vXwd`OnGex&vuSYYQf2I*0%*B0a6#Z#qr6f~P2{ON& z@Ph1!X(3V$a*{r!kWwnuz2HVLE8tWrG4H5u7tV4RRuUfhc;tC*xL^}>B0ukjq33Ne zFOomsY?42SdDj>1_IuZJIiMhw-)uHR3b6^45_7WcCjOL%ZdzbY%20Z-zCZ5Vw7^<2F3zPNOy6dqJ*0b zEh-fYXw!Y>KxDT6fH{ntUx!eUU>-qrY4<5maF}Xzlrd>DEA_D>**Y;lk+CUT2g7!P zRz~Xty_`iqcclB{(ETfT*DqlH)Bu<;I2*vZ#k_&Gn9zqu$GWAz=-ydQ_ugjow+C0r zl_%r~hlC#CGvPaZf4{F$7v|&AdK^#i5G!~}Si~xgi4C3$a~d+3oGkIFFsCSkAU#W^ zf1afvJ45$%tYL%hOL$ICD_miN>n+o>u}{vgbCWNJEKHVUoR9N3Tz%NS^28bf?4ybr zJjzzZF19Ii4KC{B{lJn@wWdY5pnJBsnVtA1}F9 zgKAbOww7wkC=6)V3HzkJ(A>ivOcTn4yJ>yXXTaJT)!rTH;1+8h6ZhC_x@}OOrUMT< zNY2RAi0%a`HnBx~kH&qxf(-6d`8+jWqVC)4=(M|46l1wGrIcG owO=3D`#r82q#fEns&(%B^4kP%@|R#&Sfi+28VBFSnDfK=3-X3TXaE2J literal 0 HcwPel00001 diff --git a/Delphi/d7/TntUnicode_7.bpg b/Delphi/d7/TntUnicode_7.bpg new file mode 100644 index 0000000..5bae531 --- /dev/null +++ b/Delphi/d7/TntUnicode_7.bpg @@ -0,0 +1,23 @@ +#------------------------------------------------------------------------------ +VERSION = BWS.01 +#------------------------------------------------------------------------------ +!ifndef ROOT +ROOT = $(MAKEDIR)\.. +!endif +#------------------------------------------------------------------------------ +MAKE = $(ROOT)\bin\make.exe -$(MAKEFLAGS) -f$** +DCC = $(ROOT)\bin\dcc32.exe $** +BRCC = $(ROOT)\bin\brcc32.exe $** +#------------------------------------------------------------------------------ +PROJECTS = TntUnicodeVcl_R70.bpl TntUnicodeVcl_D70.bpl +#------------------------------------------------------------------------------ +default: $(PROJECTS) +#------------------------------------------------------------------------------ + +TntUnicodeVcl_R70.bpl: TntUnicodeVcl_R70.dpk + $(DCC) + +TntUnicodeVcl_D70.bpl: TntUnicodeVcl_D70.dpk + $(DCC) + + diff --git a/Delphi/d9/TntUnicodeVcl_D90.bdsproj b/Delphi/d9/TntUnicodeVcl_D90.bdsproj new file mode 100644 index 0000000..284dce2 --- /dev/null +++ b/Delphi/d9/TntUnicodeVcl_D90.bdsproj @@ -0,0 +1,172 @@ + + + + + + + + + + + + TntUnicodeVcl_D90.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + Tnt Unicode Controls + + + + + + + + + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + True + False + 2 + 3 + 0 + 1 + False + False + False + False + False + 1033 + 1252 + + + + + 2.3.0.1 + + + + + + 2.3.0.1 + + + diff --git a/Delphi/d9/TntUnicodeVcl_D90.cfg b/Delphi/d9/TntUnicodeVcl_D90.cfg new file mode 100644 index 0000000..9adbd44 --- /dev/null +++ b/Delphi/d9/TntUnicodeVcl_D90.cfg @@ -0,0 +1,35 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Delphi/d9/TntUnicodeVcl_D90.dpk b/Delphi/d9/TntUnicodeVcl_D90.dpk new file mode 100644 index 0000000..5c97e9b --- /dev/null +++ b/Delphi/d9/TntUnicodeVcl_D90.dpk @@ -0,0 +1,55 @@ +package TntUnicodeVcl_D90; + +{$R *.res} +{$R '..\..\Design\TntComCtrls.dcr'} +{$R '..\..\Design\TntDBCtrls.dcr'} +{$R '..\..\Design\TntStdCtrls.dcr'} +{$R '..\..\Design\TntActnList.dcr'} +{$R '..\..\Design\TntMenus.dcr'} +{$R '..\..\Design\TntExtCtrls.dcr'} +{$R '..\..\Design\TntForms.dcr'} +{$R '..\..\Design\TntGrids.dcr'} +{$R '..\..\Design\TntButtons.dcr'} +{$R '..\..\Design\TntDialogs.dcr'} +{$R '..\..\Design\TntExtDlgs.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS ON} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Tnt Unicode Controls'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + dcldb, + designide, + TntUnicodeVcl_R90; + +contains + TntForms_Design in '..\..\Design\TntForms_Design.pas', + TntComCtrls_Design in '..\..\Design\TntComCtrls_Design.pas', + TntDBGrids_Design in '..\..\Design\TntDBGrids_Design.pas', + TntDesignEditors_Design in '..\..\Design\TntDesignEditors_Design.pas', + TntStrEdit_Design in '..\..\Design\TntStrEdit_Design.pas', + TntUnicodeVcl_Register in '..\..\Design\TntUnicodeVcl_Register.pas', + TntActions_Design in '..\..\Design\TntActions_Design.pas', + TntMenus_Design in '..\..\Design\TntMenus_Design.pas'; + +end. diff --git a/Delphi/d9/TntUnicodeVcl_D90.res b/Delphi/d9/TntUnicodeVcl_D90.res new file mode 100644 index 0000000000000000000000000000000000000000..b69d77e0cc8f3c300c14942fe1dd1bb09669ab6a GIT binary patch literal 1508 zcwUuL&ubGw6#ll2YsCi*4LCY2Qc=Sy0&( z4;8BP=%2BbAm&f;;K7>}Y>g<6-^?bpKlI>i-cG(Z-@Ny|H#-2(Pt!WHo#RtiXT6)| zSfA(hn@&vM29~(lPOzAtHmqDN^eD^W*WMrTh+Muq_6f^ z8pMX6U%y$O7I}%&|N8&k=Etv1Z#o&=}ugp8Y?8bNuq^y4hVnK<)s{x40MAa1kT8 zPP>E~oI7Ldy)aT7^!I!AR+wAlU}Ezwd4Ii26J0}mk6{#(d=KL$|BcuTlQ!RF{x{=Y z?(;7buNz&q;Ld!$9Vds~jaapgQB*OHX_OH#+B9ZxpOMS(@rbLhEN1{iw6k^|hEa6H z)^drQS>ClN@*h*p6w&?7_$Mr<6SGLG;I7RTGUqh+mN&Tr$Zz3}(dNni!#RzU7^Dr* zPHpBlI;)mjX6~6C3XWOMRpP*|8nq#H8U+C!aOYN?e|WdZn8H2cSI(^w++5u+`z_Uf)44cWT4b9Pq0v-YChIcBx(J~7~^J?*TDGULo}-rDb; H+{fH+`TSqu literal 0 HcwPel00001 diff --git a/Delphi/d9/TntUnicodeVcl_R90.bdsproj b/Delphi/d9/TntUnicodeVcl_R90.bdsproj new file mode 100644 index 0000000..9dee604 --- /dev/null +++ b/Delphi/d9/TntUnicodeVcl_R90.bdsproj @@ -0,0 +1,172 @@ + + + + + + + + + + + + TntUnicodeVcl_R90.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + Tnt Unicode Controls - Runtime + + + + + + + + + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + True + False + 2 + 3 + 0 + 1 + False + False + False + False + False + 1033 + 1252 + + + + + 2.3.0.1 + + + + + + 2.3.0.1 + + + diff --git a/Delphi/d9/TntUnicodeVcl_R90.cfg b/Delphi/d9/TntUnicodeVcl_R90.cfg new file mode 100644 index 0000000..66fb3af --- /dev/null +++ b/Delphi/d9/TntUnicodeVcl_R90.cfg @@ -0,0 +1,32 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 diff --git a/Delphi/d9/TntUnicodeVcl_R90.dpk b/Delphi/d9/TntUnicodeVcl_R90.dpk new file mode 100644 index 0000000..a2be8c9 --- /dev/null +++ b/Delphi/d9/TntUnicodeVcl_R90.dpk @@ -0,0 +1,72 @@ +package TntUnicodeVcl_R90; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS ON} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Tnt Unicode Controls - Runtime'} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + vcl, + vclx, + vcldb, + dsnap, + vclactnband; + +contains + ActiveIMM_TLB in '..\..\Source\ActiveIMM_TLB.pas', + TntSystem in '..\..\Source\TntSystem.pas', + TntAxCtrls in '..\..\Source\TntAxCtrls.pas', + TntClipbrd in '..\..\Source\TntClipbrd.pas', + TntWindows in '..\..\Source\TntWindows.pas', + TntSysUtils in '..\..\Source\TntSysUtils.pas', + TntClasses in '..\..\Source\TntClasses.pas', + TntDialogs in '..\..\Source\TntDialogs.pas', + TntFileCtrl in '..\..\Source\TntFileCtrl.pas', + TntExtDlgs in '..\..\Source\TntExtDlgs.pas', + TntRegistry in '..\..\Source\TntRegistry.pas', + TntGraphics in '..\..\Source\TntGraphics.pas', + TntControls in '..\..\Source\TntControls.pas', + TntActnList in '..\..\Source\TntActnList.pas', + TntMenus in '..\..\Source\TntMenus.pas', + TntForms in '..\..\Source\TntForms.pas', + TntStdCtrls in '..\..\Source\TntStdCtrls.pas', + TntExtCtrls in '..\..\Source\TntExtCtrls.pas', + TntButtons in '..\..\Source\TntButtons.pas', + TntCheckLst in '..\..\Source\TntCheckLst.pas', + TntGrids in '..\..\Source\TntGrids.pas', + TntComCtrls in '..\..\Source\TntComCtrls.pas', + TntDB in '..\..\Source\TntDB.pas', + TntDBCtrls in '..\..\Source\TntDBCtrls.pas', + TntDBGrids in '..\..\Source\TntDBGrids.pas', + TntStdActns in '..\..\Source\TntStdActns.pas', + TntExtActns in '..\..\Source\TntExtActns.pas', + TntListActns in '..\..\Source\TntListActns.pas', + TntDBActns in '..\..\Source\TntDBActns.pas', + TntBandActn in '..\..\Source\TntBandActn.pas', + TntDBLogDlg in '..\..\Source\TntDBLogDlg.pas', + TntFormatStrUtils in '..\..\Source\TntFormatStrUtils.pas', + TntWideStrings in '..\..\Source\TntWideStrings.pas', + TntWideStrUtils in '..\..\Source\TntWideStrUtils.pas'; + +end. diff --git a/Delphi/d9/TntUnicodeVcl_R90.res b/Delphi/d9/TntUnicodeVcl_R90.res new file mode 100644 index 0000000000000000000000000000000000000000..b69d77e0cc8f3c300c14942fe1dd1bb09669ab6a GIT binary patch literal 1508 zcwUuL&ubGw6#ll2YsCi*4LCY2Qc=Sy0&( z4;8BP=%2BbAm&f;;K7>}Y>g<6-^?bpKlI>i-cG(Z-@Ny|H#-2(Pt!WHo#RtiXT6)| zSfA(hn@&vM29~(lPOzAtHmqDN^eD^W*WMrTh+Muq_6f^ z8pMX6U%y$O7I}%&|N8&k=Etv1Z#o&=}ugp8Y?8bNuq^y4hVnK<)s{x40MAa1kT8 zPP>E~oI7Ldy)aT7^!I!AR+wAlU}Ezwd4Ii26J0}mk6{#(d=KL$|BcuTlQ!RF{x{=Y z?(;7buNz&q;Ld!$9Vds~jaapgQB*OHX_OH#+B9ZxpOMS(@rbLhEN1{iw6k^|hEa6H z)^drQS>ClN@*h*p6w&?7_$Mr<6SGLG;I7RTGUqh+mN&Tr$Zz3}(dNni!#RzU7^Dr* zPHpBlI;)mjX6~6C3XWOMRpP*|8nq#H8U+C!aOYN?e|WdZn8H2cSI(^w++5u+`z_Uf)44cWT4b9Pq0v-YChIcBx(J~7~^J?*TDGULo}-rDb; H+{fH+`TSqu literal 0 HcwPel00001 diff --git a/Design/TntActions_Design.pas b/Design/TntActions_Design.pas new file mode 100644 index 0000000..7a17388 --- /dev/null +++ b/Design/TntActions_Design.pas @@ -0,0 +1,183 @@ + +{*****************************************************************************} +{ } +{ 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 TntActions_Design; + +{$INCLUDE ..\Source\TntCompilers.inc} + +interface + +procedure Register; + +implementation + +uses + Classes, ActnList, TntActnList, StdActns, TntStdActns, + ExtActns, TntExtActns, ListActns, TntListActns, BandActn, TntBandActn, + DBActns, TntDBActns, TntDesignEditors_Design; + +procedure Register; +begin + RegisterClass(TTntAction); + // StdActns + RegisterClass(TTntEditAction); + RegisterClass(TTntEditCut); + RegisterClass(TTntEditCopy); + RegisterClass(TTntEditPaste); + RegisterClass(TTntEditSelectAll); + RegisterClass(TTntEditUndo); + RegisterClass(TTntEditDelete); + RegisterClass(TTntWindowAction); + RegisterClass(TTntWindowClose); + RegisterClass(TTntWindowCascade); + RegisterClass(TTntWindowTileHorizontal); + RegisterClass(TTntWindowTileVertical); + RegisterClass(TTntWindowMinimizeAll); + RegisterClass(TTntWindowArrange); + RegisterClass(TTntHelpAction); + RegisterClass(TTntHelpContents); + RegisterClass(TTntHelpTopicSearch); + RegisterClass(TTntHelpOnHelp); + RegisterClass(TTntHelpContextAction); + RegisterClass(TTntFileOpen); + RegisterClass(TTntFileOpenWith); + RegisterClass(TTntFileSaveAs); + RegisterClass(TTntFilePrintSetup); + RegisterClass(TTntFileExit); + RegisterClass(TTntSearchFind); + RegisterClass(TTntSearchReplace); + RegisterClass(TTntSearchFindFirst); + RegisterClass(TTntSearchFindNext); + RegisterClass(TTntFontEdit); + RegisterClass(TTntColorSelect); + RegisterClass(TTntPrintDlg); + // ExtActns + RegisterClass(TTntFileRun); + RegisterClass(TTntRichEditAction); + RegisterClass(TTntRichEditBold); + RegisterClass(TTntRichEditItalic); + RegisterClass(TTntRichEditUnderline); + RegisterClass(TTntRichEditStrikeOut); + RegisterClass(TTntRichEditBullets); + RegisterClass(TTntRichEditAlignLeft); + RegisterClass(TTntRichEditAlignRight); + RegisterClass(TTntRichEditAlignCenter); + RegisterClass(TTntPreviousTab); + RegisterClass(TTntNextTab); + RegisterClass(TTntOpenPicture); + RegisterClass(TTntSavePicture); + RegisterClass(TTntURLAction); + RegisterClass(TTntBrowseURL); + RegisterClass(TTntDownLoadURL); + RegisterClass(TTntSendMail); + RegisterClass(TTntListControlCopySelection); + RegisterClass(TTntListControlDeleteSelection); + RegisterClass(TTntListControlSelectAll); + RegisterClass(TTntListControlClearSelection); + RegisterClass(TTntListControlMoveSelection); + // ListActns + RegisterClass(TTntStaticListAction); + RegisterClass(TTntVirtualListAction); + {$IFDEF COMPILER_7_UP} + RegisterClass(TTntFilePageSetup); + {$ENDIF} + // DBActns + RegisterClass(TTntDataSetAction); + RegisterClass(TTntDataSetFirst); + RegisterClass(TTntDataSetPrior); + RegisterClass(TTntDataSetNext); + RegisterClass(TTntDataSetLast); + RegisterClass(TTntDataSetInsert); + RegisterClass(TTntDataSetDelete); + RegisterClass(TTntDataSetEdit); + RegisterClass(TTntDataSetPost); + RegisterClass(TTntDataSetCancel); + RegisterClass(TTntDataSetRefresh); + // BandActn + RegisterClass(TTntCustomizeActionBars); +end; + +//------------------------ + +function GetTntActionClass(OldActionClass: TContainedActionClass): TContainedActionClass; +begin + Result := TContainedActionClass(GetClass('TTnt' + Copy(OldActionClass.ClassName, 2, Length(OldActionClass.ClassName)))); +end; + +type + TAccessContainedAction = class(TContainedAction); + +function UpgradeAction(ActionList: TTntActionList; OldAction: TContainedAction): TContainedAction; +var + Name: TComponentName; + i: integer; + NewActionClass: TContainedActionClass; +begin + Result := nil; + if (OldAction = nil) or (OldAction.Owner = nil) or (OldAction.Name = '') then + Exit; + + NewActionClass := GetTntActionClass(TContainedActionClass(OldAction.ClassType)); + if NewActionClass <> nil then begin + // create new action + Result := NewActionClass.Create(OldAction.Owner) as TContainedAction; + Include(TAccessContainedAction(Result).FComponentStyle, csTransient); + // copy base class info + Result.ActionComponent := OldAction.ActionComponent; + Result.Category := OldAction.Category; { Assign Category before ActionList/Index to avoid flicker. } + Result.ActionList := ActionList; + Result.Index := OldAction.Index; + // assign props + Result.Assign(OldAction); + // point all links to this new action + for i := TAccessContainedAction(OldAction).FClients.Count - 1 downto 0 do + TBasicActionLink(TAccessContainedAction(OldAction).FClients[i]).Action := Result; + // free old object, preserve name... + Name := OldAction.Name; + OldAction.Free; + Result.Name := Name; { link up to old name } + Exclude(TAccessContainedAction(Result).FComponentStyle, csTransient); + end; +end; + +procedure TntActionList_UpgradeActionListItems(ActionList: TTntActionList); +var + DesignerNotify: IDesignerNotify; + Designer: ITntDesigner; + TntSelections: TTntDesignerSelections; + i: integer; + OldAction, NewAction: TContainedAction; +begin + DesignerNotify := FindRootDesigner(ActionList); + if (DesignerNotify <> nil) then begin + DesignerNotify.QueryInterface(ITntDesigner, Designer); + if (Designer <> nil) then begin + TntSelections := TTntDesignerSelections.Create; + try + Designer.GetSelections(TntSelections); + for i := ActionList.ActionCount - 1 downto 0 do begin + OldAction := ActionList.Actions[i]; + NewAction := UpgradeAction(ActionList, OldAction); + if (NewAction <> nil) then + TntSelections.ReplaceSelection(OldAction, NewAction); + end; + Designer.SetSelections(TntSelections); + finally + TntSelections.Free; + end; + end; + end; +end; + +initialization + UpgradeActionListItemsProc := TntActionList_UpgradeActionListItems; + +end. diff --git a/Design/TntActnList.dcr b/Design/TntActnList.dcr new file mode 100644 index 0000000000000000000000000000000000000000..f585e26a0a7a52823bd3c1785f06a835c5433ca5 GIT binary patch literal 484 zcwTi+u};J=40RC_-g@JWH}Vk-ATof2V1N&~tuT=-mTt(%ke^_qRhE8IhDu}$&q+Ig z#B&@!zc_Y6M09|c()=%^Bf6^RXY>Mlgx}CD_Ir9l_JH_|Y{PE1Ki~Kze7|}}O+Iw= z4{TjzZ3}8DVVma}N~ud9S%X@Ab0Jw_i8m@JsT+d57>M2X05H9}BfDHHl8AClkUsg! z86A3NM^bevtUa~fCX~}SIt)xDQT&WS(D8_L`kF>@#-vg>egyD4(HffGLen|N5GHYp zNy+;uhLfOC;+$jByNfBk_uj@)b(H6fapExGUG@4UJ;9~MjpDlT1$0^Up+bJ)2iP>b AXaE2J literal 0 HcwPel00001 diff --git a/Design/TntButtons.dcr b/Design/TntButtons.dcr new file mode 100644 index 0000000000000000000000000000000000000000..ea9d3db2fd9402803539e631997af206253a2bd9 GIT binary patch literal 928 zcwW^}u};G<5WOHIEM;g%*s4zX07j+?1{Oe~{71IHWGjnLV(7?_pXf#-59E{BsMI06 zyVwE3z|6BRdAfUNpZti37KpwdVhYZPF0_6`Ypff@J>Ah2)+MdzL9@5W517x-j#F=e zIE|6fkX~fd8xovua&Gv^k`z8&*CEsEmLc^gOK0whBOIAT8Im!5QjG=o=u5-#M&{D^ zk4jK(gzs6Kj3)-qO*|9aZNWY5cES%Rgl%ZRd4@v!+De{sXv0gRnm1^C`=pxu9r~te zRgXd&nrFXvG{XqNXm5Ui#+xwoLgS@h?m{7Q8QUZ-P~Jz#uvG+4fHyyjC=u^07tpdX@XpptTx5)RXY0BEC-DyY arRII?6}=DRIbw`WzQ7oteEDU}-}nSE9#x9~ literal 0 HcwPel00001 diff --git a/Design/TntComCtrls.dcr b/Design/TntComCtrls.dcr new file mode 100644 index 0000000000000000000000000000000000000000..9f1b07fa379f45afc99f08e89dd13902c9b84210 GIT binary patch literal 6776 zcwXI^&uSb;5XRfFL6d_SAAR&ON5ckUNWfOS#t!m7A|)nou?NA7Pdm5ikiZ-hv4^}u zKnH7Cg7p9b<>r&#VGkxdB7)BMRdw~u%B$GE7_V#peOp`8-P=D^b@$3S=WgH;f~9=h+`HeP?k>pk}@#a_F1{fg-?@VFiymz=t9Tyhs!C3ja<`obGs zcse{hgeS9`^PDD27Yxo zjoNbzdp+IvhomoJ);G-gH*T5VQ@82vgWg^DB=UTMoK*W*8JZ?T(`0D6>9i-qMVy-v zE^X}tFf>hurpYk*!7#;xVe*4viU-5wue)n~Jrg}9poRBsmSv@{J@54Q^*FT1RPP&v z`nTB%hC5*R?Mi~54#RYDuT3(v(UPHYejkQ)9)dBf(ey0SYwOIpIs-#=NIwSWEuOE9 zSD#o=-#gpNJS4aKc)o}Aa2q@~q18Thh9=3-G#Ms8YiX=?fwk29tfjvm@g{j_T54(3 zp0zY})}}i7mP+|{Td@{0_coD-TTAplO@5WnXPO}4xQS0mXO}w6A&cAfa{C+?d4v~e=@Xl=Q*j3uOvXfOWvg1UJ zVwu^TG=u2MvVP}0Y_v~8cUZ-i=SJXO&sJochSF*~# zVVLtfZuLH98~LXz;6uDyuN;gOPWGd=Wl1^M6h+FxM%$F8plhq4jn+{3ooh4)nW&-JuYe4RP(R z!2!!OADNv6Q9C-lDASpBKF>OTXfxwFa{av+ZN<9y06DoM?0!l;t_8cO|8GxY`^ve? z+uA;19_H$oJj{r&Q2 z)f~rymMXNRa;rw$6R@tS)0|?T=%0$0JybgZs6VAFN9sm78+q!@f?@cvLBT_ z2{hTE!$3`T)CK)uSK-fNRMud`npqUi7g}mj{YqbU$BCk>qh`i+$3{>~a@9h(;w-o= z{CK7~f0qCJgYz3iyXh{Q93UjQ!OuRp34Tdqf|71JJpezGOKlF^{=SWt{BFhR0l)p* z{EaItxaRHO@-3#hDHq_U+Aqj2>IVG2j+*@TO@n^YzP&v7s%SNtpsg?OFAr{8ISswB z4f=Z7E;`HK!|l!gOMG~KC(-_PS52NEGdrRVH7a`FHhIo@%FRm-BaRXsmL1 z&i&^JH2qxnRMXtczf6;#Xas 3) or (PageControl.PageCount > 0); +end; + +type TAccessPageControl = class(TPageControl{TNT-ALLOW TPageControl}); + +procedure TTntPageControlEditor.ExecuteVerb(Index: Integer); + + procedure CreateNewTabSheet; + var + NewTabsheet: TTntTabSheet; + begin + NewTabSheet := TTntTabSheet.Create(PageControl.Owner); + NewTabSheet.PageControl := Self.PageControl; + with NewTabSheet do begin + Name := Designer.UniqueName(ClassName); + Caption := Name; + Visible := True; + end; + PageControl.ActivePage := NewTabSheet; + end; + +begin + case Index of + 0: CreateNewTabSheet; + 1: PageControl.SelectNextPage(True, False); + 2: PageControl.SelectNextPage(False, False); + 3: if PageControl.ActivePage <> nil then + PageControl.ActivePage.Free; + end; +end; + +{ TTntStatusBarEditor } + +function TTntStatusBarEditor.GetVerbCount: Integer; +begin + Result := 1; +end; + +function TTntStatusBarEditor.GetVerb(Index: Integer): string{TNT-ALLOW string}; +begin + case Index of + 0: Result := SStatusBarPanelEdit; + end; +end; + +procedure TTntStatusBarEditor.ExecuteVerb(Index: Integer); +begin + case Index of + 0: EditPropertyWithDialog(Component, 'Panels', Designer); + end; +end; + +{ TTntToolBarEditor } + +procedure TTntToolBarEditor.ExecuteVerb(Index: Integer); +var + ToolBar: TTntToolBar; + ToolButton: TTntToolButton; + I, J: Integer; + NewName: WideString; +begin + Assert(Index in [0, 1]); + + if Component is TTntToolBar then + ToolBar := TTntToolBar(Component) + else if (Component is TTntToolButton) and (TTntToolButton(Component).Parent is TTntToolBar) then + ToolBar := TTntToolBar(TTntToolButton(Component).Parent) + else + Exit; + + ToolButton := TTntToolButton.Create(Component.Owner); + + I := 1; + repeat + NewName := 'TntToolButton' + IntToStr(I); + for J := 0 to ToolBar.ControlCount - 1 do + if WideSameText(ToolBar.Controls[J].Name, NewName) then + NewName := ''; + Inc(I); + until NewName <> ''; + ToolButton.Name := NewName; + + if Index = 1 then begin + ToolButton.Style := tbsSeparator; + ToolButton.Width := 8; + end; + + for I := 0 to ToolBar.ControlCount - 1 do + ToolButton.Left := ToolButton.Left + ToolBar.Controls[I].Width; + + ToolButton.Parent := ToolBar; +end; + +function TTntToolBarEditor.GetVerb(Index: Integer): string{TNT-ALLOW string}; +begin + case Index of + 0: Result := SNewToolButton; + 1: Result := SNewToolSeparator; + end; +end; + +function TTntToolBarEditor.GetVerbCount: Integer; +begin + Result := 2; +end; + +end. diff --git a/Design/TntDBClientActns_Design.pas b/Design/TntDBClientActns_Design.pas new file mode 100644 index 0000000..784c4f0 --- /dev/null +++ b/Design/TntDBClientActns_Design.pas @@ -0,0 +1,36 @@ + +{*****************************************************************************} +{ } +{ 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_Design; + +{$INCLUDE ..\Source\TntCompilers.inc} + +interface + +uses + Classes; + +procedure Register; + +implementation + +uses + TntDBClientActns; + +procedure Register; +begin + // DBClientActns + RegisterClass(TTntClientDataSetApply); + RegisterClass(TTntClientDataSetRevert); + RegisterClass(TTntClientDataSetUndo); +end; + +end. diff --git a/Design/TntDBCtrls.dcr b/Design/TntDBCtrls.dcr new file mode 100644 index 0000000000000000000000000000000000000000..8052106515c1341e4ac35879a24c0e0094dd6e0a GIT binary patch literal 3620 zcwW_)KX21e5WugrQi2$qv13Q}AZ1}F;EEztj8KvKF`mR=GuZ=@Ph!Z3stkMuqzokT z(0(KjmijUs_vbyQO4<$D@Dj(TpU=;Zf4Q>*0C2<$ku948_W)k%_9t-8uMfPW@EYF0 zDV*@=<`RT!-E(<=jAXgdtmrz5AGS2zM-mYB`-nzaeaNwg!C;ZsVjNuITK(Q z6%1pDoYLb#E*qwtN^Ma)j-7H|ORRiqahnkMVJ-W*7FzJF&gu9_iTAKrNZbPX=2tU| zeEEC1i22Qr*&@#4mtSXjuJik5Hd_{@lP@}4HnZ<#nd@k9xhP8VoKqk+i?T%TQDVe3 zM>Ia&;xd-i;LpvFBs5m%GI6F(4N*pRrs1k?k)Bl?eU%nQ7}BXJjEb;mgzXX=jk&AN`%9dpjk z)Sb-9vAT1VWxPq&v!<@#|UEo%C#;xuG*SZV&TXi=~JMVIL&XsrZztx>3g1H0velFbi zl$*P1fLMdm)LPFFt!MHMZV-AV@4)vl>zUP{h9dOLnol25-HE+HVeZH~ND6a@9-u59 z^S&olXU{L2z4PgVI~?KRkOHw?1n5 Z)<-S2K3Z~idTM<%*EsZ1;}6hB{{YF6ikSca literal 0 HcwPel00001 diff --git a/Design/TntDBGrids_Design.pas b/Design/TntDBGrids_Design.pas new file mode 100644 index 0000000..7be008d --- /dev/null +++ b/Design/TntDBGrids_Design.pas @@ -0,0 +1,58 @@ + +{*****************************************************************************} +{ } +{ 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_Design; + +{$INCLUDE ..\Source\TntCompilers.inc} + +interface + +uses + DesignEditors, DesignIntf; + +type + TTntDBGridEditor = class(TComponentEditor) + public + procedure ExecuteVerb(Index: Integer); override; + function GetVerb(Index: Integer): string{TNT-ALLOW string}; override; + function GetVerbCount: Integer; override; + end; + +procedure Register; + +implementation + +uses + TntDBGrids, DsnDBCst, TntDesignEditors_Design; + +procedure Register; +begin + RegisterComponentEditor(TTntDBGrid, TTntDBGridEditor); +end; + +{ TTntDBGridEditor } + +function TTntDBGridEditor.GetVerbCount: Integer; +begin + Result := 1; +end; + +function TTntDBGridEditor.GetVerb(Index: Integer): string{TNT-ALLOW string}; +begin + Result := DsnDBCst.SDBGridColEditor; +end; + +procedure TTntDBGridEditor.ExecuteVerb(Index: Integer); +begin + EditPropertyWithDialog(Component, 'Columns', Designer); +end; + +end. diff --git a/Design/TntDesignEditors_Design.pas b/Design/TntDesignEditors_Design.pas new file mode 100644 index 0000000..c305f04 --- /dev/null +++ b/Design/TntDesignEditors_Design.pas @@ -0,0 +1,196 @@ + +{*****************************************************************************} +{ } +{ 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 TntDesignEditors_Design; + +{$INCLUDE ..\Source\TntCompilers.inc} + +interface + +uses + Classes, Forms, TypInfo, DesignIntf, DesignEditors; + +type + ITntDesigner = IDesigner; + + TTntDesignerSelections = class(TInterfacedObject, IDesignerSelections) + private + FList: TList; + {$IFDEF COMPILER_9_UP} + function GetDesignObject(Index: Integer): IDesignObject; + {$ENDIF} + protected + function Add(const Item: TPersistent): Integer; + function Equals(const List: IDesignerSelections): Boolean; + function Get(Index: Integer): TPersistent; + function GetCount: Integer; + property Count: Integer read GetCount; + property Items[Index: Integer]: TPersistent read Get; default; + public + constructor Create; virtual; + destructor Destroy; override; + procedure ReplaceSelection(const OldInst, NewInst: TPersistent); + end; + +function GetObjectInspectorForm: TCustomForm; +procedure EditPropertyWithDialog(Component: TPersistent; const PropName: AnsiString; const Designer: ITntDesigner); + +implementation + +uses + SysUtils; + +{ TTntDesignerSelections } + +function TTntDesignerSelections.Add(const Item: TPersistent): Integer; +begin + Result := FList.Add(Item); +end; + +constructor TTntDesignerSelections.Create; +begin + inherited; + FList := TList.Create; +end; + +destructor TTntDesignerSelections.Destroy; +begin + FList.Free; + inherited; +end; + +function TTntDesignerSelections.Equals(const List: IDesignerSelections): Boolean; +var + I: Integer; +begin + Result := False; + if List.Count <> Count then Exit; + for I := 0 to Count - 1 do + begin + if Items[I] <> List[I] then Exit; + end; + Result := True; +end; + +function TTntDesignerSelections.Get(Index: Integer): TPersistent; +begin + Result := TPersistent(FList[Index]); +end; + +function TTntDesignerSelections.GetCount: Integer; +begin + Result := FList.Count; +end; + +{$IFDEF COMPILER_9_UP} +function TTntDesignerSelections.GetDesignObject(Index: Integer): IDesignObject; +begin + Result := nil; {TODO: Figure out what IDesignerSelections.GetDesignObject is all about. Must wait for more documentation!} +end; +{$ENDIF} + +procedure TTntDesignerSelections.ReplaceSelection(const OldInst, NewInst: TPersistent); +var + Idx: Integer; +begin + Idx := FList.IndexOf(OldInst); + if Idx <> -1 then + FList[Idx] := NewInst; +end; + +{//------------------------------ +// Helpful discovery routines to explore the components and classes inside the IDE... +// +procedure EnumerateComponents(Comp: TComponent); +var + i: integer; +begin + for i := Comp.ComponentCount - 1 downto 0 do + MessageBoxW(0, PWideChar(WideString(Comp.Components[i].Name + ': ' + Comp.Components[i].ClassName)), + PWideChar(WideString(Comp.Name)), 0); +end; + +procedure EnumerateClasses(Comp: TComponent); +var + AClass: TClass; +begin + AClass := Comp.ClassType; + repeat + MessageBoxW(0, PWideChar(WideString(AClass.ClassName)), + PWideChar(WideString(Comp.Name)), 0); + AClass := Aclass.ClassParent; + until AClass = nil; +end; +//------------------------------} + +//------------------------------ +function GetIdeMainForm: TCustomForm; +var + Comp: TComponent; +begin + Result := nil; + if Application <> nil then begin + Comp := Application.FindComponent('AppBuilder'); + if Comp is TCustomForm then + Result := TCustomForm(Comp); + end; +end; + +function GetObjectInspectorForm: TCustomForm; +var + Comp: TComponent; + IdeMainForm: TCustomForm; +begin + Result := nil; + IdeMainForm := GetIdeMainForm; + if IdeMainForm <> nil then begin + Comp := IdeMainForm.FindComponent('PropertyInspector'); + if Comp is TCustomForm then + Result := TCustomForm(Comp); + end; +end; + +{ TPropertyEditorWithDialog } +type + TPropertyEditorWithDialog = class + private + FPropName: AnsiString; + procedure CheckEditProperty(const Prop: IProperty); + procedure EditProperty(Component: TPersistent; const PropName: AnsiString; const Designer: ITntDesigner); + end; + +procedure TPropertyEditorWithDialog.CheckEditProperty(const Prop: IProperty); +begin + if Prop.GetName = FPropName then + Prop.Edit; +end; + +procedure TPropertyEditorWithDialog.EditProperty(Component: TPersistent; const PropName: AnsiString; const Designer: ITntDesigner); +var + Components: IDesignerSelections; +begin + FPropName := PropName; + Components := TDesignerSelections.Create; + Components.Add(Component); + GetComponentProperties(Components, [tkClass], Designer, CheckEditProperty); +end; + +procedure EditPropertyWithDialog(Component: TPersistent; const PropName: AnsiString; const Designer: ITntDesigner); +begin + with TPropertyEditorWithDialog.Create do + try + EditProperty(Component, PropName, Designer); + finally + Free; + end; +end; + +end. diff --git a/Design/TntDialogs.dcr b/Design/TntDialogs.dcr new file mode 100644 index 0000000000000000000000000000000000000000..3a953b0a1fde80b858799fc61ccf659d3268b262 GIT binary patch literal 936 zcwW_!ze>YU6o-E?qJe6$n~T4jlN`QWZcg|BU`W+8T0fIIz^T07!7Z&3)eX*YhjYZZr0xm{ zF8ck0!O?ElA5$H+xV(X-a)&KE031WZYNfhI?-U>6Ni9|#18xXnZs|+h&l!U literal 0 HcwPel00001 diff --git a/Design/TntExtCtrls.dcr b/Design/TntExtCtrls.dcr new file mode 100644 index 0000000000000000000000000000000000000000..e6ba64957f82f6c3eea3bdd39bb4df0b59d07d5e GIT binary patch literal 3592 zcwXI>ON$dr6vu1s1k&OnE?o{;-DRK!1%>g^k`YEDzVKr-80el=_d=)x1NQPR@+B^0 zVL~rvK7b#>rMt;ONP%GaKc^l&8KdAvMo-eyznnT%{rF8)w^B;&VYAk47lU?`8cF*< z>IFVeu-#V=)hld=zUJDs>%CC_FShG`+fgpPw{vmS5Vd?&UArBBIE6o_r>DqR`SOX$ zjz4mqR*{cdB>@Q~G2Jgz(pZUAsq;h^5;;*GI@C?alxXxVd=bWMe7;nRMd0@Tb{2T~ ze%a;!n?){{N2tM34f3Pb3$1b_A6@@FycU0Kc-A!swUczdo6;O*&O z=Z&)LKpN2XZI)%y0B=BPU~j@W5PK6&jA3uWgQjWVjrp!phQ0APxWNs3!}t?x`=(8n z3k)}~79En7ImfDCj60j!u5#tiUJv>dV~}*5mmSx%C2-I0s7-GV)I|2rus_7Ac@Grg zPjIN?e=B(HmPU4{jVqG5XVz8W$JEADyku#fd(65NhmQNQW;#}-%st0wIGV*g&%IF3 zb1#fTzAulDH8U`4*<@R-xkOk_)3Ljjwea?tw{`A4g|#Ptz_Tu}%)O@bMrG%XDpw?P zuR1qo6$V`_0<*Wk>@DWuE!M+Z%)?u(=eZa1Ro9oQ_8b%anEg7*54x~So|}K)1@8GR z^}V-8{%vKVUPlX;$zR=*ixPizJ{D$w^YctIX?~evL>6dQIB3T^g zxJT;!f=qIJqWh)zGlLU7%?t5oYCX-yWASIGk7Y6!e}-~iKEck@E00J@CUwG6kyyb@IGm9({T!aX<#>|<5bP(;F_8J1%|(Qy34$q z!ry!(`4Jk9X8z)K*WGlew>V4t-u6`g(R4>)|lg!(pt4 h!&uJ_Lp?k6^?cAx=IRHyg#9!vgmDSnO*s8od;`9^EIR-I literal 0 HcwPel00001 diff --git a/Design/TntExtDlgs.dcr b/Design/TntExtDlgs.dcr new file mode 100644 index 0000000000000000000000000000000000000000..8f766ba8cbad6571d106c3baa7b0a7856cf9883f GIT binary patch literal 960 zcwW_!ze>YU6o-Em!9WP)$LF0t#9DQ72fKwb{kLH&+ zquD;q`Z&fA2j;uo?#^bj&o0%rsSX79I_qz1;`0UHmzy3M(Z^!3Afouv2j-g|e13(( z6#pi;cJkE+^Dv}7@}FF&>R$J&ihC=7aHXm)EatM)bf)3h)JYoKEiV(j{&S*qQraglr*`SR zZJg$}P@KHVBrdHPwYe*P$xl9qWO6{=KlZ6(d~zz|lh;J-6H^`WY1?Cp&;P4y@dNg0 tSDK4YcMe!n@o9f~0WleYi> literal 0 HcwPel00001 diff --git a/Design/TntForms.dcr b/Design/TntForms.dcr new file mode 100644 index 0000000000000000000000000000000000000000..c4dbd69e1f3de14cc2dd352b03777d52fe163813 GIT binary patch literal 920 zcwWs>p;E*!5ZyAJA+9G+oB{PUhM1KNDJ2CyF$hu`W$p(5~ zz)LoH^SYaC^8f&L6o@fSVGDq(@cj&4X*^N9z%4vO0}nKAXn#w&o6WYAx(kYJiUOj% zD^5=r=rBR+xba|#mU*5@!7#bOu<;1}BG?2CN~oojET4Cvbh_nWTBU8<_q13`-0NlW zUiZvVla5*$u#yjSrp5>bAd&@Udl)i2I zLWOYr2%-1wNhw`gtxJ!6$G)SBY|wY?JFQ70&OT!D%cY-RFZzg%+Dl(9OK*M)zxh2= zGPwg0{8tRk#84Y!62lsesS`ud7#Yf#X-)P~7@|hfks(EGFfpXjh|Dl=jENyfX2@@! c84?qH$#9$*mLtxrSm*Iee|kQg8QO*a1B5L$K>z>% literal 0 HcwPel00001 diff --git a/Design/TntMenus.dcr b/Design/TntMenus.dcr new file mode 100644 index 0000000000000000000000000000000000000000..edc3deb49c7c9f8ad5509856ec18314e03d97cef GIT binary patch literal 928 zcwWVlJx;?w5QQfw65AzZ%9I>|GDxPN2&N$SND(Qa@^&7HA|-_{L5D3jInox9D3>=g z*){*7wsqfF|9_tphq$|3CThcY|tK2)C&c?}Kpk}8U zk;U^7{UEOwd2bI{65)0@9FRo45x~Cg)Al<^H~T%sFH4R)r(= zEmsBhigwIZ8Ox$P7IDo({>rC*5&ucw@VlcDwL*O)_>cT(;OC{q9Q%;?c{d5lPkfjJ z<)__|_V2v%Gmkkg`JnvPdIqQbDujt2e&0oO#%}{3oblVBXY7pMM*auR_$d!({3_uh U-!XpXp`0_P{x7*=-0^RE0|`EKZvX%Q literal 0 HcwPel00001 diff --git a/Design/TntMenus_Design.pas b/Design/TntMenus_Design.pas new file mode 100644 index 0000000..5018df6 --- /dev/null +++ b/Design/TntMenus_Design.pas @@ -0,0 +1,391 @@ + +{*****************************************************************************} +{ } +{ 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_Design; + +{$INCLUDE ..\Source\TntCompilers.inc} + +{*******************************************************} +{ Special Thanks to Francisco Leong for getting these } +{ menu designer enhancements to work w/o MnuBuild. } +{*******************************************************} + +interface + +{$IFDEF COMPILER_6} // Delphi 6 and BCB 6 have MnuBuild available + {$DEFINE MNUBUILD_AVAILABLE} +{$ENDIF} + +{$IFDEF COMPILER_7} // Delphi 7 has MnuBuild available + {$DEFINE MNUBUILD_AVAILABLE} +{$ENDIF} + +uses + Windows, Classes, Menus, Messages, + {$IFDEF MNUBUILD_AVAILABLE} MnuBuild, {$ENDIF} + DesignEditors, DesignIntf; + +type + TTntMenuEditor = class(TComponentEditor) + public + procedure ExecuteVerb(Index: Integer); override; + function GetVerb(Index: Integer): string{TNT-ALLOW string}; override; + function GetVerbCount: Integer; override; + end; + +procedure Register; + +implementation + +uses + {$IFDEF MNUBUILD_AVAILABLE} MnuConst, {$ELSE} DesignWindows, {$ENDIF} SysUtils, Graphics, ActnList, + Controls, Forms, TntDesignEditors_Design, TntActnList, TntMenus; + +procedure Register; +begin + RegisterComponentEditor(TTntMainMenu, TTntMenuEditor); + RegisterComponentEditor(TTntPopupMenu, TTntMenuEditor); +end; + +function GetMenuBuilder: TForm{TNT-ALLOW TForm}; +{$IFDEF MNUBUILD_AVAILABLE} +begin + Result := MenuEditor; +{$ELSE} +var + Comp: TComponent; +begin + Result := nil; + if Application <> nil then + begin + Comp := Application.FindComponent('MenuBuilder'); + if Comp is TForm{TNT-ALLOW TForm} then + Result := TForm{TNT-ALLOW TForm}(Comp); + end; +{$ENDIF} +end; + +{$IFDEF DELPHI_9} // verified against Delphi 9 +type + THackMenuBuilder = class(TDesignWindow) + protected + Fields: array[1..26] of TObject; + FWorkMenu: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} + +{$IFDEF COMPILER_10_UP} +{$IFDEF DELPHI_10} // NOT verified against Delphi 10 +type + THackMenuBuilder = class(TDesignWindow) + protected + Fields: array[1..26] of TObject; + FWorkMenu: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} +{$ENDIF} + +function GetMenuBuilder_WorkMenu(MenuBuilder: TForm{TNT-ALLOW TForm}): TMenuItem{TNT-ALLOW TMenuItem}; +begin + if MenuBuilder = nil then + Result := nil + else begin + {$IFDEF MNUBUILD_AVAILABLE} + Result := MenuEditor.WorkMenu; + {$ELSE} + Result := THackMenuBuilder(MenuBuilder).FWorkMenu; + Assert((Result = nil) or (Result is TMenuItem{TNT-ALLOW TMenuItem}), + 'TNT Internal Error: THackMenuBuilder has incorrect internal layout.'); + {$ENDIF} + end; +end; + +{$IFDEF DELPHI_9} // verified against Delphi 9 +type + THackMenuItemWin = class(TCustomControl) + protected + FxxxxCaptionExtent: Integer; + FMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} + +{$IFDEF DELPHI_10} // beta: NOT verified against Delphi 10 +type + THackMenuItemWin = class(TCustomControl) + protected + FxxxxCaptionExtent: Integer; + FMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} + +function GetMenuItem(Control: TWinControl; DoVerify: Boolean = True): TMenuItem{TNT-ALLOW TMenuItem}; +begin + {$IFDEF MNUBUILD_AVAILABLE} + if Control is TMenuItemWin then + Result := TMenuItemWin(Control).MenuItem + {$ELSE} + if Control.ClassName = 'TMenuItemWin' then begin + Result := THackMenuItemWin(Control).FMenuItem; + Assert((Result = nil) or (Result is TMenuItem{TNT-ALLOW TMenuItem}), 'TNT Internal Error: Unexpected TMenuItem field layout.'); + end + {$ENDIF} + else if DoVerify then + raise Exception.Create('TNT Internal Error: Control is not a TMenuItemWin.') + else + Result := nil; +end; + +procedure SetMenuItem(Control: TWinControl; Item: TMenuItem{TNT-ALLOW TMenuItem}); +begin + {$IFDEF MNUBUILD_AVAILABLE} + if Control is TMenuItemWin then + TMenuItemWin(Control).MenuItem := Item + {$ELSE} + if Control.ClassName = 'TMenuItemWin' then begin + THackMenuItemWin(Control).FMenuItem := Item; + Item.FreeNotification(Control); + end + {$ENDIF} + else + raise Exception.Create('TNT Internal Error: Control is not a TMenuItemWin.'); +end; + +procedure ReplaceMenuItem(Control: TWinControl; ANewItem: TMenuItem{TNT-ALLOW TMenuItem}); +var + OldItem: TMenuItem{TNT-ALLOW TMenuItem}; + OldName: string{TNT-ALLOW string}; +begin + OldItem := GetMenuItem(Control, True); + Assert(OldItem <> nil); + OldName := OldItem.Name; + FreeAndNil(OldItem); + ANewItem.Name := OldName; { assume old name } + SetMenuItem(Control, ANewItem); +end; + +{ TTntMenuBuilderChecker } + +type + TMenuBuilderChecker = class(TComponent) + private + FMenuBuilder: TForm{TNT-ALLOW TForm}; + FCheckMenuAction: TTntAction; + FLastCaption: string{TNT-ALLOW string}; + FLastActiveControl: TControl; + FLastMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; + procedure CheckMenuItems(Sender: TObject); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + +var MenuBuilderChecker: TMenuBuilderChecker = nil; + +constructor TMenuBuilderChecker.Create(AOwner: TComponent); +begin + inherited; + MenuBuilderChecker := Self; + FCheckMenuAction := TTntAction.Create(Self); + FCheckMenuAction.OnUpdate := CheckMenuItems; + FCheckMenuAction.OnExecute := CheckMenuItems; + FMenuBuilder := AOwner as TForm{TNT-ALLOW TForm}; + FMenuBuilder.Action := FCheckMenuAction; +end; + +destructor TMenuBuilderChecker.Destroy; +begin + FMenuBuilder := nil; + MenuBuilderChecker := nil; + inherited; +end; + +type TAccessTntMenuItem = class(TTntMenuItem); + +function CreateTntMenuItem(OldItem: TMenuItem{TNT-ALLOW TMenuItem}): TTntMenuItem; +var + OldName: AnsiString; + OldParent: TMenuItem{TNT-ALLOW TMenuItem}; + OldIndex: Integer; + OldItemsList: TList; + j: integer; +begin + // item should be converted. + OldItemsList := TList.Create; + try + // clone properties + Result := TTntMenuItem.Create(OldItem.Owner); + TAccessTntMenuItem(Result).FComponentStyle := OldItem.ComponentStyle; {csTransient hides item from object inspector} + Result.Action := OldItem.Action; + Result.AutoCheck := OldItem.AutoCheck; + Result.AutoHotkeys := OldItem.AutoHotkeys; + Result.AutoLineReduction := OldItem.AutoLineReduction; + Result.Bitmap := OldItem.Bitmap; + Result.Break := OldItem.Break; + Result.Caption := OldItem.Caption; + Result.Checked := OldItem.Checked; + Result.Default := OldItem.Default; + Result.Enabled := OldItem.Enabled; + Result.GroupIndex := OldItem.GroupIndex; + Result.HelpContext := OldItem.HelpContext; + Result.Hint := OldItem.Hint; + Result.ImageIndex := OldItem.ImageIndex; + Result.MenuIndex := OldItem.MenuIndex; + Result.RadioItem := OldItem.RadioItem; + Result.ShortCut := OldItem.ShortCut; + Result.SubMenuImages := OldItem.SubMenuImages; + Result.Visible := OldItem.Visible; + Result.Tag := OldItem.Tag; + + // clone events + Result.OnAdvancedDrawItem := OldItem.OnAdvancedDrawItem; + Result.OnClick := OldItem.OnClick; + Result.OnDrawItem := OldItem.OnDrawItem; + Result.OnMeasureItem := OldItem.OnMeasureItem; + + // remember name, parent, index, children + OldName := OldItem.Name; + OldParent := OldItem.Parent; + OldIndex := OldItem.MenuIndex; + for j := OldItem.Count - 1 downto 0 do begin + OldItemsList.Insert(0, OldItem.Items[j]); + OldItem.Remove(OldItem.Items[j]); + end; + + // clone final parts of old item + for j := 0 to OldItemsList.Count - 1 do + Result.Add(TMenuItem{TNT-ALLOW TMenuItem}(OldItemsList[j])); { add children } + if OldParent <> nil then + OldParent.Insert(OldIndex, Result); { insert into parent } + finally + OldItemsList.Free; + end; +end; + +procedure CheckMenuItemWin(MenuItemWin: TWinControl; PartOfATntMenu: Boolean); +var + OldItem: TMenuItem{TNT-ALLOW TMenuItem}; +begin + OldItem := GetMenuItem(MenuItemWin); + if OldItem = nil then + exit; + if (OldItem.ClassType = TMenuItem{TNT-ALLOW TMenuItem}) + and (PartOfATntMenu or (OldItem.Parent is TTntMenuItem)) then + begin + if MenuItemWin.Focused then + MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.} + ReplaceMenuItem(MenuItemWin, CreateTntMenuItem(OldItem)); + end else if (OldItem.ClassType = TTntMenuItem) + and (OldItem.Parent = nil) and (OldItem.Caption = '') and (OldItem.Name = '') + and not (PartOfATntMenu or (OldItem.Parent is TTntMenuItem)) then begin + if MenuItemWin.Focused then + MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.} + ReplaceMenuItem(MenuItemWin, TMenuItem{TNT-ALLOW TMenuItem}.Create(OldItem.Owner)); + end; +end; + +procedure TMenuBuilderChecker.CheckMenuItems(Sender: TObject); +var + a, i: integer; + MenuWin: TWinControl; + MenuItemWin: TWinControl; + SaveFocus: HWND; + PartOfATntMenu: Boolean; + WorkMenu: TMenuItem{TNT-ALLOW TMenuItem}; +begin + if (FMenuBuilder <> nil) + and (FMenuBuilder.Action = FCheckMenuAction) then begin + if (FLastCaption <> FMenuBuilder.Caption) + or (FLastActiveControl <> FMenuBuilder.ActiveControl) + or (FLastMenuItem <> GetMenuItem(FMenuBuilder.ActiveControl, False)) + then begin + try + try + with FMenuBuilder do begin + WorkMenu := GetMenuBuilder_WorkMenu(FMenuBuilder); + PartOfATntMenu := (WorkMenu <> nil) + and ((WorkMenu.Owner is TTntMainMenu) or (WorkMenu.Owner is TTntPopupMenu)); + SaveFocus := Windows.GetFocus; + for a := ComponentCount - 1 downto 0 do begin + {$IFDEF MNUBUILD_AVAILABLE} + if Components[a] is TMenuWin then begin + {$ELSE} + if Components[a].ClassName = 'TMenuWin' then begin + {$ENDIF} + MenuWin := Components[a] as TWinControl; + with MenuWin do begin + for i := ComponentCount - 1 downto 0 do begin + {$IFDEF MNUBUILD_AVAILABLE} + if Components[i] is TMenuItemWin then begin + {$ELSE} + if Components[i].ClassName = 'TMenuItemWin' then begin + {$ENDIF} + MenuItemWin := Components[i] as TWinControl; + CheckMenuItemWin(MenuItemWin, PartOfATntMenu); + end; + end; + end; + end; + end; + if SaveFocus <> Windows.GetFocus then + Windows.SetFocus(SaveFocus); + end; + except + on E: Exception do begin + FMenuBuilder.Action := nil; + end; + end; + finally + FLastCaption := FMenuBuilder.Caption; + FLastActiveControl := FMenuBuilder.ActiveControl; + FLastMenuItem := GetMenuItem(FMenuBuilder.ActiveControl, False); + end; + end; + end; +end; + +{ TTntMenuEditor } + +function TTntMenuEditor.GetVerbCount: Integer; +begin + Result := 1; +end; + +{$IFNDEF MNUBUILD_AVAILABLE} +resourcestring + SMenuDesigner = 'Menu Designer...'; +{$ENDIF} + +function TTntMenuEditor.GetVerb(Index: Integer): string{TNT-ALLOW string}; +begin + Result := SMenuDesigner; +end; + +procedure TTntMenuEditor.ExecuteVerb(Index: Integer); +var + MenuBuilder: TForm{TNT-ALLOW TForm}; +begin + EditPropertyWithDialog(Component, 'Items', Designer); + MenuBuilder := GetMenuBuilder; + if Assigned(MenuBuilder) then begin + if (MenuBuilderChecker = nil) or (MenuBuilderChecker.FMenuBuilder <> MenuBuilder) then begin + MenuBuilderChecker.Free; + MenuBuilderChecker := TMenuBuilderChecker.Create(MenuBuilder); + end; + EditPropertyWithDialog(Component, 'Items', Designer); // update menu builder caption + end; +end; + +initialization + +finalization + MenuBuilderChecker.Free; // design package might be recompiled + +end. diff --git a/Design/TntStdCtrls.dcr b/Design/TntStdCtrls.dcr new file mode 100644 index 0000000000000000000000000000000000000000..b3a5aec6521b58439c81e98f965248b6439399fc GIT binary patch literal 5392 zcwXI@v5wnD5QgW11GF7ox^(F>MT!(D&Sx31k-IQB$ABM$9p#EF3~&G!EK}$u+=T)Q z-y^XQAa^rK$?f&P@&?{d7L zHNBE^v`3E~pGW;vj>mSKQE)#wqc2#ke^l4ugcn@$@AmdqJYN5BV|v0%@6!{T)#RdN z2}$l%nJ(0urbwE3(yi#q2XhT^5id~2h50>w>Z0yH_S?em^E_Ys-QPR$=X;;~y#H&P zwBNl$%o=a|?RF<^#V_uD`vGm$?{}e3(bB8v{T`RRZ>Mpg(>!HdPR3tl3*4@S+%@H? z*Hhru*offPgozp2Nh`NzzlO;NbDaFtb>>%Y(GPAh9^6vAa7*#REyWAB6wkXUp8J_* z+{2{j{<$`Q8@|V6&VQ!6+@1@wYr2&GINl}-r@)VGM9sTQr$YI0rjwe3pZWcOrok_| z>-b#feGPtmj{NX@@JoK-m*RzA><9c}|KOMW!Y}2N@T-iBED9WSR;t#P8O{72I?$Va z+9i`Y|B3GMyOP!NwVdblPJ*3j%{?1^%DsU#_q@*jp-8zm44QlJ=ff=b2GZOM@vY{b zQoI;Pv$(CnjsZZhW=bewxH zWz~F6zb#UHKpYQ}Fp=XxGmgW4nIkqi6El{XuveeV8^?hCe1w_MRP;rBw$!5$1ZZI3%~=s|Qt8|-^c@aw+EB(qqo zbl(dVq0@a24I~`g&`!dY8>2z7Qf`dFrElzeVITnMI~{2LwOR3!HLh_fW>fzQ%*DDT zuAQg7W=8#a-nF)p!5y9+M(_(&{22HZL*{8Tegh3O27ZOyS*B|yv@CsN;1~RXpT%=% zi+)Ds7y2J{#PFR6`dc0lj!fqK7rM*uM)D3%dilcY`EVFA%T%U5%d#3-8FK0Up$!b1 z>`?kDFs#AnUq`3BgdA*E^391!B@m}1{7!<4Irv)g??$*? z$?H;h-WY|4#7{5G3xdE;E$|B#_?ch%#S8DY@za6d2190Tt9xHrkL<>=FJyG1hT2l8{5D~>lwURL({uxVrj?&**v~ZcUHyK&erbzq2^|+yXujVT)=)e#Jd@*<nj#R`jWJR?~o?vzi7Boz*m8=xqN&4mzu8z|dJu1BT9O h8myttY8tGej$=*J>f=NBDyp`crcL*DpPo%D{{yLJRv-WX literal 0 HcwPel00001 diff --git a/Design/TntStrEdit_Design.dfm b/Design/TntStrEdit_Design.dfm new file mode 100644 index 0000000..283cf15 --- /dev/null +++ b/Design/TntStrEdit_Design.dfm @@ -0,0 +1,135 @@ +object TntStrEditDlg: TTntStrEditDlg + Left = 267 + Top = 258 + BorderStyle = bsDialog + Caption = 'Wide String List Editor' + ClientHeight = 279 + ClientWidth = 430 + Color = clBtnFace + ParentFont = True + OldCreateOrder = True + PopupMenu = StringEditorMenu + Position = poScreenCenter + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object TntGroupBox1: TTntGroupBox + Left = 8 + Top = 3 + Width = 413 + Height = 234 + TabOrder = 4 + object LineCount: TTntLabel + Left = 9 + Top = 9 + Width = 169 + Height = 17 + AutoSize = False + Caption = '0 lines' + end + object UnicodeEnabledLbl: TTntLabel + Left = 325 + Top = 9 + Width = 79 + Height = 13 + Alignment = taRightJustify + Caption = 'Unicode Enabled' + Font.Charset = DEFAULT_CHARSET + Font.Color = clGreen + Font.Height = -11 + Font.Name = 'MS Shell Dlg 2' + Font.Style = [] + ParentFont = False + Visible = False + end + object Memo: TTntMemo + Left = 8 + Top = 28 + Width = 397 + Height = 197 + ScrollBars = ssBoth + TabOrder = 0 + WordWrap = False + OnChange = UpdateStatus + OnKeyDown = Memo1KeyDown + end + end + object CodeWndBtn: TTntButton + Left = 8 + Top = 248 + Width = 75 + Height = 25 + Caption = '&Code Editor...' + Enabled = False + TabOrder = 0 + OnClick = CodeWndBtnClick + end + object HelpButton: TTntButton + Left = 345 + Top = 248 + Width = 75 + Height = 25 + Caption = '&Help' + TabOrder = 3 + OnClick = HelpButtonClick + end + object OKButton: TTntButton + Left = 185 + Top = 248 + Width = 75 + Height = 25 + Caption = '&OK' + Default = True + ModalResult = 1 + TabOrder = 1 + end + object CancelButton: TTntButton + Left = 265 + Top = 248 + Width = 75 + Height = 25 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 2 + end + object OpenDialog: TTntOpenDialog + HelpContext = 26040 + DefaultExt = 'TXT' + Filter = + 'Text files (*.TXT)|*.TXT|Config files (*.SYS;*.INI)|*.SYS;*.INI|' + + 'Batch files (*.BAT)|*.BAT|All files (*.*)|*.*' + Options = [ofHideReadOnly, ofShowHelp, ofPathMustExist, ofFileMustExist, ofEnableSizing] + Title = 'Load string list' + Left = 200 + Top = 88 + end + object SaveDialog: TTntSaveDialog + HelpContext = 26050 + Filter = + 'Text files (*.TXT)|*.TXT|Config files (*.SYS;*.INI)|*.SYS;*.INI|' + + 'Batch files (*.BAT)|*.BAT|All files (*.*)|*.*' + Options = [ofOverwritePrompt, ofHideReadOnly, ofShowHelp, ofPathMustExist, ofEnableSizing] + Title = 'Save string list' + Left = 228 + Top = 88 + end + object StringEditorMenu: TTntPopupMenu + Left = 168 + Top = 88 + object LoadItem: TTntMenuItem + Caption = '&Load...' + OnClick = FileOpenClick + end + object SaveItem: TTntMenuItem + Caption = '&Save...' + OnClick = FileSaveClick + end + object CodeEditorItem: TTntMenuItem + Caption = '&Code Editor...' + Enabled = False + Visible = False + OnClick = CodeWndBtnClick + end + end +end diff --git a/Design/TntStrEdit_Design.pas b/Design/TntStrEdit_Design.pas new file mode 100644 index 0000000..5e17b44 --- /dev/null +++ b/Design/TntStrEdit_Design.pas @@ -0,0 +1,419 @@ + +{*****************************************************************************} +{ } +{ 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 TntStrEdit_Design; + +{$INCLUDE ..\Source\TntCompilers.inc} + +// The following unit is adapted from StrEdit.pas. + +interface + +uses + Windows, Classes, Graphics, Controls, Buttons, Menus, StdCtrls, + TntStdCtrls, ExtCtrls, DesignEditors, DesignIntf, + TntForms, TntMenus, TntClasses, TntDialogs; + +type + TTntStrEditDlg = class(TTntForm) + CodeWndBtn: TTntButton; + OpenDialog: TTntOpenDialog; + SaveDialog: TTntSaveDialog; + HelpButton: TTntButton; + OKButton: TTntButton; + CancelButton: TTntButton; + StringEditorMenu: TTntPopupMenu; + LoadItem: TTntMenuItem; + SaveItem: TTntMenuItem; + CodeEditorItem: TTntMenuItem; + TntGroupBox1: TTntGroupBox; + UnicodeEnabledLbl: TTntLabel; + Memo: TTntMemo; + LineCount: TTntLabel; + procedure FileOpenClick(Sender: TObject); + procedure FileSaveClick(Sender: TObject); + procedure HelpButtonClick(Sender: TObject); + procedure CodeWndBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure UpdateStatus(Sender: TObject); + private + SingleLine: WideString; + MultipleLines: WideString; + protected + FModified: Boolean; + function GetLines: TTntStrings; + procedure SetLines(const Value: TTntStrings); + function GetLinesControl: TWinControl; + public + property Lines: TTntStrings read GetLines write SetLines; + procedure PrepareForWideStringEdit; + end; + +type + TWideStringListProperty = class(TClassProperty) + protected + function EditDialog: TTntStrEditDlg; virtual; + function GetStrings: TTntStrings; virtual; + procedure SetStrings(const Value: TTntStrings); virtual; + public + function GetAttributes: TPropertyAttributes; override; + procedure Edit; override; + end; + +procedure Register; + +implementation + +{$R *.dfm} + +uses + ActiveX, Forms, SysUtils, DesignConst, ToolsAPI, IStreams, LibHelp, + StFilSys, TypInfo, TntSystem, TntDesignEditors_Design; + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(TTntStrings), nil, '', TWideStringListProperty); +end; + +{$IFDEF COMPILER_10_UP} +type + TStringsModuleCreator = class(TInterfacedObject, IOTACreator, IOTAModuleCreator) + private + FFileName: AnsiString; + FStream: TStringStream{TNT-ALLOW TStringStream}; + FAge: TDateTime; + public + constructor Create(const FileName: AnsiString; Stream: TStringStream{TNT-ALLOW TStringStream}; Age: TDateTime); + destructor Destroy; override; + { IOTACreator } + function GetCreatorType: AnsiString; + function GetExisting: Boolean; + function GetFileSystem: AnsiString; + function GetOwner: IOTAModule; + function GetUnnamed: Boolean; + { IOTAModuleCreator } + function GetAncestorName: AnsiString; + function GetImplFileName: AnsiString; + function GetIntfFileName: AnsiString; + function GetFormName: AnsiString; + function GetMainForm: Boolean; + function GetShowForm: Boolean; + function GetShowSource: Boolean; + function NewFormFile(const FormIdent, AncestorIdent: AnsiString): IOTAFile; + function NewImplSource(const ModuleIdent, FormIdent, AncestorIdent: AnsiString): IOTAFile; + function NewIntfSource(const ModuleIdent, FormIdent, AncestorIdent: AnsiString): IOTAFile; + procedure FormCreated(const FormEditor: IOTAFormEditor); + end; + + TOTAFile = class(TInterfacedObject, IOTAFile) + private + FSource: AnsiString; + FAge: TDateTime; + public + constructor Create(const ASource: AnsiString; AAge: TDateTime); + { IOTAFile } + function GetSource: AnsiString; + function GetAge: TDateTime; + end; + +{ TOTAFile } + +constructor TOTAFile.Create(const ASource: AnsiString; AAge: TDateTime); +begin + inherited Create; + FSource := ASource; + FAge := AAge; +end; + +function TOTAFile.GetAge: TDateTime; +begin + Result := FAge; +end; + +function TOTAFile.GetSource: AnsiString; +begin + Result := FSource; +end; + +{ TStringsModuleCreator } + +constructor TStringsModuleCreator.Create(const FileName: AnsiString; Stream: TStringStream{TNT-ALLOW TStringStream}; + Age: TDateTime); +begin + inherited Create; + FFileName := FileName; + FStream := Stream; + FAge := Age; +end; + +destructor TStringsModuleCreator.Destroy; +begin + FStream.Free; + inherited; +end; + +procedure TStringsModuleCreator.FormCreated(const FormEditor: IOTAFormEditor); +begin + { Nothing to do } +end; + +function TStringsModuleCreator.GetAncestorName: AnsiString; +begin + Result := ''; +end; + +function TStringsModuleCreator.GetCreatorType: AnsiString; +begin + Result := sText; +end; + +function TStringsModuleCreator.GetExisting: Boolean; +begin + Result := True; +end; + +function TStringsModuleCreator.GetFileSystem: AnsiString; +begin + Result := sTStringsFileSystem; +end; + +function TStringsModuleCreator.GetFormName: AnsiString; +begin + Result := ''; +end; + +function TStringsModuleCreator.GetImplFileName: AnsiString; +begin + Result := FFileName; +end; + +function TStringsModuleCreator.GetIntfFileName: AnsiString; +begin + Result := ''; +end; + +function TStringsModuleCreator.GetMainForm: Boolean; +begin + Result := False; +end; + +function TStringsModuleCreator.GetOwner: IOTAModule; +begin + Result := nil; +end; + +function TStringsModuleCreator.GetShowForm: Boolean; +begin + Result := False; +end; + +function TStringsModuleCreator.GetShowSource: Boolean; +begin + Result := True; +end; + +function TStringsModuleCreator.GetUnnamed: Boolean; +begin + Result := False; +end; + +function TStringsModuleCreator.NewFormFile(const FormIdent, + AncestorIdent: AnsiString): IOTAFile; +begin + Result := nil; +end; + +function TStringsModuleCreator.NewImplSource(const ModuleIdent, FormIdent, + AncestorIdent: AnsiString): IOTAFile; +begin + Result := TOTAFile.Create(FStream.DataString, FAge); +end; + +function TStringsModuleCreator.NewIntfSource(const ModuleIdent, FormIdent, + AncestorIdent: AnsiString): IOTAFile; +begin + Result := nil; +end; +{$ENDIF} + +{ TTntStrEditDlg } + +procedure TTntStrEditDlg.FormCreate(Sender: TObject); +begin + HelpContext := hcDStringListEditor; + OpenDialog.HelpContext := hcDStringListLoad; + SaveDialog.HelpContext := hcDStringListSave; + SingleLine := srLine; + MultipleLines := srLines; + UnicodeEnabledLbl.Visible := IsWindowUnicode(Memo.Handle); +end; + +procedure TTntStrEditDlg.PrepareForWideStringEdit; +begin + Caption := 'WideString Editor'; + CodeWndBtn.Visible := False; + CodeEditorItem.Visible := False; +end; + +procedure TTntStrEditDlg.FileOpenClick(Sender: TObject); +begin + with OpenDialog do + if Execute then Lines.LoadFromFile(FileName); +end; + +procedure TTntStrEditDlg.FileSaveClick(Sender: TObject); +begin + SaveDialog.FileName := OpenDialog.FileName; + with SaveDialog do + if Execute then Lines.SaveToFile(FileName); +end; + +procedure TTntStrEditDlg.HelpButtonClick(Sender: TObject); +begin + Application.HelpContext(HelpContext); +end; + +procedure TTntStrEditDlg.CodeWndBtnClick(Sender: TObject); +begin + ModalResult := mrYes; +end; + +function TTntStrEditDlg.GetLinesControl: TWinControl; +begin + Result := Memo; +end; + +procedure TTntStrEditDlg.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if Key = VK_ESCAPE then CancelButton.Click; +end; + +procedure TTntStrEditDlg.UpdateStatus(Sender: TObject); +var + Count: Integer; + LineText: WideString; +begin + if Sender = Memo then FModified := True; + Count := Lines.Count; + if Count = 1 then LineText := SingleLine + else LineText := MultipleLines; + LineCount.Caption := WideFormat('%d %s', [Count, LineText]); +end; + +function TTntStrEditDlg.GetLines: TTntStrings; +begin + Result := Memo.Lines; +end; + +procedure TTntStrEditDlg.SetLines(const Value: TTntStrings); +begin + Memo.Lines.Assign(Value); +end; + +{ TWideStringListProperty } + +function TWideStringListProperty.EditDialog: TTntStrEditDlg; +begin + Result := TTntStrEditDlg.Create(Application); +end; + +function TWideStringListProperty.GetAttributes: TPropertyAttributes; +begin + Result := inherited GetAttributes + [paDialog] - [paSubProperties]; +end; + +function TWideStringListProperty.GetStrings: TTntStrings; +begin + Result := TTntStrings(GetOrdValue); +end; + +procedure TWideStringListProperty.SetStrings(const Value: TTntStrings); +begin + SetOrdValue(Longint(Value)); +end; + +procedure TWideStringListProperty.Edit; +{$IFDEF COMPILER_10_UP} +const + DotSep = '.'; // Temp fix for opening the strings in the editor. +var + Ident: AnsiString; + Component: TComponent; + Module: IOTAModule; + Editor: IOTAEditor; + ModuleServices: IOTAModuleServices; + Stream: TStringStream{TNT-ALLOW TStringStream}; + Age: TDateTime; +{$ENDIF} +begin + {$IFDEF COMPILER_10_UP} + Component := TComponent(GetComponent(0)); + ModuleServices := BorlandIDEServices as IOTAModuleServices; + if (TObject(Component) is TComponent) + and (Component.Owner = Self.Designer.GetRoot) + and (Self.Designer.GetRoot.Name <> '') + then begin + Ident := Self.Designer.GetRoot.Name + DotSep + + Component.Name + DotSep + GetName; + Ident := Self.Designer.GetDesignerExtension + DotSep + Ident; + Module := ModuleServices.FindModule(Ident); + end else begin + Ident := ''; + Module := nil; + end; + if (Module <> nil) and (Module.GetModuleFileCount > 0) then + Module.GetModuleFileEditor(0).Show + else + {$ENDIF} + with EditDialog do + try + if GetObjectInspectorForm <> nil then + Font.Assign(GetObjectInspectorForm.Font); + Lines := GetStrings; + UpdateStatus(nil); + FModified := False; + ActiveControl := GetLinesControl; + {$IFDEF COMPILER_10_UP} + CodeEditorItem.Enabled := Ident <> ''; + CodeWndBtn.Enabled := Ident <> ''; + {$ENDIF} + case ShowModal of + mrOk: SetStrings(Lines); + {$IFDEF COMPILER_10_UP} + mrYes: + begin + // this used to be done in LibMain's TLibrary.Create but now its done here + // the unregister is done over in ComponentDesigner's finalization + //StFilSys.Register; + Stream := TStringStream{TNT-ALLOW TStringStream}.Create(WideStringToUTF8(Lines.Text)); + Stream.Position := 0; + Age := Now; + Module := ModuleServices.CreateModule( + TStringsModuleCreator.Create(Ident, Stream, Age)); + if Module <> nil then + begin + with StringsFileSystem.GetTStringsProperty(Ident, Component, GetName) do + DiskAge := DateTimeToFileDate(Age); + Editor := Module.GetModuleFileEditor(0); + if FModified then + Editor.MarkModified; + Editor.Show; + end; + end; + {$ENDIF} + end; + finally + Free; + end; +end; + +end. diff --git a/Design/TntUnicodeVcl_Register.pas b/Design/TntUnicodeVcl_Register.pas new file mode 100644 index 0000000..210a172 --- /dev/null +++ b/Design/TntUnicodeVcl_Register.pas @@ -0,0 +1,132 @@ + +{*****************************************************************************} +{ } +{ 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 TntUnicodeVcl_Register; + +{$INCLUDE ..\Source\TntCompilers.inc} + +interface + +{ TODO: Install program (handle Std, Prof, Ent versions) (ie. no database stuff for personal edition) } +{ TODO: $IFDEF DelphiPersonalEdition } + +procedure Register; + +implementation + +uses + Classes, DB, TntForms, TntMenus, TntStdCtrls, TntCheckLst, TntGrids, TntExtCtrls, TntComCtrls, + TntButtons, TntDB, TntDBCtrls, TntDBGrids, TntActnList, TntDialogs, TntExtDlgs, DesignIntf; + +const + TNT_STANDARD = 'Tnt Standard'; + TNT_ADDITIONAL = 'Tnt Additional'; + TNT_WIN32 = 'Tnt Win32'; + TNT_DATA_CONTROLS = 'Tnt Data Controls'; + TNT_DIALOGS = 'Tnt Dialogs'; + +procedure Register; +begin + {$IFDEF COMPILER_9_UP} + // ForceDemandLoadState(dlDisable); + {$ENDIF} + + // ------- Standard ------- + RegisterComponents(TNT_STANDARD, [TTntMainMenu]); + RegisterComponents(TNT_STANDARD, [TTntPopupMenu]); + RegisterComponents(TNT_STANDARD, [TTntLabel]); + RegisterComponents(TNT_STANDARD, [TTntEdit]); + RegisterComponents(TNT_STANDARD, [TTntMemo]); + RegisterComponents(TNT_STANDARD, [TTntButton]); + RegisterComponents(TNT_STANDARD, [TTntCheckBox]); + RegisterComponents(TNT_STANDARD, [TTntRadioButton]); + RegisterComponents(TNT_STANDARD, [TTntListBox]); + RegisterComponents(TNT_STANDARD, [TTntComboBox]); + RegisterComponents(TNT_STANDARD, [TTntScrollBar]); + RegisterComponents(TNT_STANDARD, [TTntGroupBox]); + RegisterComponents(TNT_STANDARD, [TTntRadioGroup]); + RegisterComponents(TNT_STANDARD, [TTntPanel]); + RegisterComponents(TNT_STANDARD, [TTntActionList]); + + // ------- Additional ------- + RegisterComponents(TNT_ADDITIONAL, [TTntBitBtn]); + RegisterComponents(TNT_ADDITIONAL, [TTntSpeedButton]); + { -- TTntMaskEdit goes here -- } + RegisterComponents(TNT_ADDITIONAL, [TTntStringGrid]); + RegisterComponents(TNT_ADDITIONAL, [TTntDrawGrid]); + RegisterComponents(TNT_ADDITIONAL, [TTntImage]); + RegisterComponents(TNT_ADDITIONAL, [TTntShape]); + RegisterComponents(TNT_ADDITIONAL, [TTntBevel]); + RegisterComponents(TNT_ADDITIONAL, [TTntScrollBox]); + RegisterComponents(TNT_ADDITIONAL, [TTntCheckListBox]); + RegisterComponents(TNT_ADDITIONAL, [TTntSplitter]); + RegisterComponents(TNT_ADDITIONAL, [TTntStaticText]); + RegisterComponents(TNT_ADDITIONAL, [TTntControlBar]); + + // ------- Win32 ------- + RegisterComponents(TNT_WIN32, [TTntTabControl]); + RegisterComponents(TNT_WIN32, [TTntPageControl]); + RegisterComponents(TNT_WIN32, [TTntRichEdit]); + RegisterComponents(TNT_WIN32, [TTntTrackBar]); + RegisterComponents(TNT_WIN32, [TTntProgressBar]); + RegisterComponents(TNT_WIN32, [TTntUpDown]); + { -- TTntHotKey goes here -- } + { -- TTntAnimate goes here -- } + RegisterComponents(TNT_WIN32, [TTntDateTimePicker]); + RegisterComponents(TNT_WIN32, [TTntMonthCalendar]); + RegisterComponents(TNT_WIN32, [TTntTreeView]); + RegisterComponents(TNT_WIN32, [TTntListView]); + { -- TTntHeader goes here -- } + RegisterComponents(TNT_WIN32, [TTntStatusBar]); + RegisterComponents(TNT_WIN32, [TTntToolBar]); + { -- TTntCoolBar goes here -- } + RegisterComponents(TNT_WIN32, [TTntPageScroller]); + { -- TTntComboBoxEx goes here -- } + + // ------- System ------- + RegisterComponents(TNT_ADDITIONAL, [TTntPaintBox]); + { -- TTntMediaPlayer goes here -- } + { -- TTntOleContainer goes here -- } + + // ------- Data Controls ------- + RegisterComponents(TNT_DATA_CONTROLS, [TTntDBGrid]); + { -- TTntDBNavigator goes here -- } + RegisterComponents(TNT_DATA_CONTROLS, [TTntDBText]); + RegisterComponents(TNT_DATA_CONTROLS, [TTntDBEdit]); + RegisterComponents(TNT_DATA_CONTROLS, [TTntDBMemo]); + { -- TTntDBImage goes here -- } + { -- TTntDBListBox goes here -- } + RegisterComponents(TNT_DATA_CONTROLS, [TTntDBComboBox]); + RegisterComponents(TNT_DATA_CONTROLS, [TTntDBCheckBox]); + RegisterComponents(TNT_DATA_CONTROLS, [TTntDBRadioGroup]); + { -- TTntDBLookupListBox goes here -- } + { -- TTntDBLookupComboBox goes here -- } + RegisterComponents(TNT_DATA_CONTROLS, [TTntDBRichEdit]); + { -- TTntDBCtrlGrid here -- } + { -- TTntDBLookupListBox goes here -- } + { -- TTntDBChart goes here -- } + + // ------- Dialogs ------- + RegisterComponents(TNT_DIALOGS, [TTntOpenDialog]); + RegisterComponents(TNT_DIALOGS, [TTntSaveDialog]); + RegisterComponents(TNT_DIALOGS, [TTntOpenPictureDialog]); + RegisterComponents(TNT_DIALOGS, [TTntSavePictureDialog]); + + // --------- Fields -------------- + RegisterTntFields; + + // --------- Classes -------------- + RegisterClass(TTntMenuItem); + RegisterClass(TTntTabSheet); + RegisterClass(TTntToolButton); +end; + +end. diff --git a/Design/TntWideStringProperty_Design.pas b/Design/TntWideStringProperty_Design.pas new file mode 100644 index 0000000..79ca022 --- /dev/null +++ b/Design/TntWideStringProperty_Design.pas @@ -0,0 +1,400 @@ + +{*****************************************************************************} +{ } +{ 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 TntWideStringProperty_Design; + +{$INCLUDE ..\Source\TntCompilers.inc} + +interface + +{*****************************************************} +{ TWideCharProperty-editor implemented by Maël Hörz } +{*****************************************************} + +{$IFDEF COMPILER_9_UP} + {$MESSAGE FATAL 'The Object Inspector in Delphi 9 is already Unicode enabled.'} +{$ENDIF} + +uses + Classes, Messages, Windows, Graphics, TypInfo, TntDesignEditors_Design, + DesignIntf, DesignEditors, VCLEditors; + +type + TWideStringProperty = class(TPropertyEditor, ICustomPropertyDrawing) + private + FActivateWithoutGetValue: Boolean; + FPropList: PInstPropList; + protected + procedure SetPropEntry(Index: Integer; AInstance: TPersistent; APropInfo: PPropInfo); override; + function GetWideStrValueAt(Index: Integer): WideString; dynamic; + function GetWideStrValue: WideString; + procedure SetWideStrValue(const Value: WideString); dynamic; + function GetWideVisualValue: WideString; + public + constructor Create(const ADesigner: ITntDesigner; APropCount: Integer); override; + destructor Destroy; override; + procedure Activate; override; + procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + function AllEqual: Boolean; override; + function GetEditLimit: Integer; override; + function GetValue: AnsiString; override; + procedure SetValue(const Value: AnsiString); override; + {$IFDEF MULTI_LINE_STRING_EDITOR} + function GetAttributes: TPropertyAttributes; override; + procedure Edit; override; + {$ENDIF} + end; + + TWideCaptionProperty = class(TWideStringProperty) + public + function GetAttributes: TPropertyAttributes; override; + end; + + TWideCharProperty = class(TWideStringProperty) + protected + {$IFDEF COMPILER_7_UP} + function GetIsDefault: Boolean; override; + {$ENDIF} + function GetWideStrValueAt(Index: Integer): WideString; override; + procedure SetWideStrValue(const Value: WideString); override; + public + function GetAttributes: TPropertyAttributes; override; + function GetEditLimit: Integer; override; + end; + +procedure Register; + +implementation + +uses + Controls, Forms, SysUtils, StdCtrls, TntGraphics, TntControls, + TntSysUtils, TntSystem, Consts, + RTLConsts; + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(WideString), nil, '', TWideStringProperty); + RegisterPropertyEditor(TypeInfo(TWideCaption), nil, '', TWideCaptionProperty); + RegisterPropertyEditor(TypeInfo(WideChar), nil, '', TWideCharProperty); +end; + +function GetOIInspListBox: TWinControl; +var + ObjectInspectorForm: TCustomForm; + Comp: TComponent; +begin + Result := nil; + ObjectInspectorForm := GetObjectInspectorForm; + if ObjectInspectorForm <> nil then begin + Comp := ObjectInspectorForm.FindComponent('PropList'); + if Comp is TWinControl then + Result := TWinControl(Comp); + end; +end; + +function GetOIPropInspEdit: TCustomEdit{TNT-ALLOW TCustomEdit}; +var + OIInspListBox: TWinControl; + Comp: TComponent; +begin + Result := nil; + OIInspListBox := GetOIInspListBox; + if OIInspListBox <> nil then begin + Comp := OIInspListBox.FindComponent('EditControl'); + if Comp is TCustomEdit{TNT-ALLOW TCustomEdit} then + Result := TCustomEdit{TNT-ALLOW TCustomEdit}(Comp); + end; +end; +//------------------------------ + +type TAccessWinControl = class(TWinControl); + +{ TWideStringProperty } + +var + WideStringPropertyCount: Integer = 0; + +constructor TWideStringProperty.Create(const ADesigner: ITntDesigner; APropCount: Integer); +begin + inherited; + Inc(WideStringPropertyCount); + GetMem(FPropList, APropCount * SizeOf(TInstProp)); +end; + +procedure ConvertObjectInspectorBackToANSI; +var + Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; +begin + if (Win32PlatformIsUnicode) then begin + Edit := GetOIPropInspEdit; + if Assigned(Edit) + and IsWindowUnicode(Edit.Handle) then + TAccessWinControl(Edit).RecreateWnd; + end; +end; + +destructor TWideStringProperty.Destroy; +begin + Dec(WideStringPropertyCount); + if (WideStringPropertyCount = 0) then + ConvertObjectInspectorBackToANSI; + if FPropList <> nil then + FreeMem(FPropList, PropCount * SizeOf(TInstProp)); + inherited; +end; + +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackPropertyEditor = class + FDesigner: IDesigner; + FPropList: PInstPropList; + end; +{$ENDIF} + +procedure TWideStringProperty.Activate; +var + Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; +begin + FActivateWithoutGetValue := True; + if (Win32PlatformIsUnicode) then begin + Edit := GetOIPropInspEdit; + if Assigned(Edit) + and (not IsWindowUnicode(Edit.Handle)) then + ReCreateUnicodeWnd(Edit, 'EDIT', True); + end; +end; + +procedure TWideStringProperty.SetPropEntry(Index: Integer; + AInstance: TPersistent; APropInfo: PPropInfo); +begin + inherited; + with FPropList^[Index] do + begin + Instance := AInstance; + PropInfo := APropInfo; + end; +end; + +function TWideStringProperty.GetWideStrValueAt(Index: Integer): WideString; +begin + with FPropList^[Index] do Result := GetWideStrProp(Instance, PropInfo); +end; + +function TWideStringProperty.GetWideStrValue: WideString; +begin + Result := GetWideStrValueAt(0); +end; + +procedure TWideStringProperty.SetWideStrValue(const Value: WideString); +var + I: Integer; +begin + for I := 0 to PropCount - 1 do + with FPropList^[I] do SetWideStrProp(Instance, PropInfo, Value); + Modified; +end; + +function TWideStringProperty.GetWideVisualValue: WideString; +begin + if AllEqual then + Result := GetWideStrValue + else + Result := ''; +end; + +procedure TWideStringProperty.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); +begin + DefaultPropertyDrawName(Self, ACanvas, ARect); +end; + +procedure TWideStringProperty.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); +begin + WideCanvasTextRect(ACanvas, ARect, ARect.Left + 1, ARect.Top + 1, GetWideVisualValue); +end; + +function TWideStringProperty.AllEqual: Boolean; +var + I: Integer; + V: WideString; +begin + Result := False; + if PropCount > 1 then + begin + V := GetWideStrValue; + for I := 1 to PropCount - 1 do + if GetWideStrValueAt(I) <> V then Exit; + end; + Result := True; +end; + +function TWideStringProperty.GetEditLimit: Integer; +var + Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; +begin + Result := MaxInt; + // GetEditLimit is called right before the inplace editor text has been set + if Win32PlatformIsUnicode then begin + Edit := GetOIPropInspEdit; + if Assigned(Edit) then begin + TntControl_SetText(Edit, GetWideStrValue); + TntControl_SetHint(Edit, GetWideStrValue); + end; + end; +end; + +function TWideStringProperty.GetValue: AnsiString; +begin + FActivateWithoutGetValue := False; + Result := WideStringToStringEx(GetWideStrValue, CP_ACP{TNT-ALLOW CP_ACP}); // use the same code page as the inplace editor +end; + +procedure TWideStringProperty.SetValue(const Value: AnsiString); +var + Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; +begin + if (not FActivateWithoutGetValue) then begin + Edit := GetOIPropInspEdit; + if Assigned(Edit) and Win32PlatformIsUnicode then + SetWideStrValue(TntControl_GetText(Edit)) + else + SetWideStrValue(StringToWideStringEx(Value, CP_ACP{TNT-ALLOW CP_ACP})); // use the same code page as the inplace editor + end; +end; + +{$IFDEF MULTI_LINE_STRING_EDITOR} +function TWideStringProperty.GetAttributes: TPropertyAttributes; +begin + Result := inherited GetAttributes + [paDialog]; +end; + +procedure TWideStringProperty.Edit; +var + Temp: WideString; +begin + with TTntStrEditDlg.Create(Application) do + try + PrepareForWideStringEdit; + Memo.Text := GetWideStrValue; + UpdateStatus(nil); + if ShowModal = mrOk then begin + Temp := Memo.Text; + while (Length(Temp) > 0) and (Temp[Length(Temp)] < ' ') do + System.Delete(Temp, Length(Temp), 1); { trim control characters from end } + SetWideStrValue(Temp); + end; + finally + Free; + end; +end; +{$ENDIF} + +{ TWideCaptionProperty } + +function TWideCaptionProperty.GetAttributes: TPropertyAttributes; +begin + Result := inherited GetAttributes + [paAutoUpdate]; +end; + +{ TWideCharProperty } + +function TWideCharProperty.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paRevertable]; +end; + +function TWideCharProperty.GetEditLimit: Integer; +begin + inherited GetEditLimit; + Result := 63; +end; + +{$IFDEF COMPILER_7_UP} +function TWideCharProperty.GetIsDefault: Boolean; +var + i: Integer; + OldPropList: PInstPropList; +begin + Result := True; + if PropCount > 0 then + begin + OldPropList := THackPropertyEditor(Self).FPropList; + // The memory FPropList points to is write-protected. + // In the constructor we dynamically allocated our own PropList, + // which can be written, so point there instead. + THackPropertyEditor(Self).FPropList := FPropList; + + // Delphi can't handle WideChar-type, but does well with Word-type, + // which has exactly the same size as WideChar (i.e. 2 Bytes) + for i := 0 to PropCount - 1 do + FPropList^[i].PropInfo^.PropType^ := TypeInfo(Word); + + Result := inherited GetIsDefault; + + for i := 0 to PropCount - 1 do + FPropList^[i].PropInfo^.PropType^ := TypeInfo(WideChar); + + THackPropertyEditor(Self).FPropList := OldPropList; + end; +end; +{$ENDIF} + +function IsCharGraphic(C: WideChar): Boolean; +begin + if Win32PlatformIsUnicode then + Result := not IsWideCharCntrl(C) and not IsWideCharSpace(C) + else // representation as charcode avoids corruption on ANSI-systems + Result := (C >= #33) and (C <= #127); +end; + +function TWideCharProperty.GetWideStrValueAt(Index: Integer): WideString; +var + C: WideChar; +begin + with FPropList^[Index] do + C := WideChar(GetOrdProp(Instance, PropInfo)); + + if IsCharGraphic(C) then + Result := C + else + Result := WideFormat('#%d', [Ord(C)]); +end; + +procedure TWideCharProperty.SetWideStrValue(const Value: WideString); +var + C: Longint; + I: Integer; +begin + if Length(Value) = 0 then + C := 0 + else if Length(Value) = 1 then + C := Ord(Value[1]) + else if Value[1] = '#' then + C := StrToInt(Copy(Value, 2, Maxint)) + else + raise EPropertyError.Create(SInvalidPropertyValue); + + with GetTypeData(GetPropType)^ do + if (C < MinValue) or (C > MaxValue) then + raise EPropertyError.CreateFmt(SOutOfRange, [MinValue, MaxValue]); + + for I := 0 to PropCount - 1 do + with FPropList^[I] do SetOrdProp(Instance, PropInfo, C); + + Modified; +end; + +initialization + +finalization + ConvertObjectInspectorBackToANSI; + +end. diff --git a/Example/ExampleUnicode.cfg b/Example/ExampleUnicode.cfg new file mode 100644 index 0000000..d6273bf --- /dev/null +++ b/Example/ExampleUnicode.cfg @@ -0,0 +1,35 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/Example/ExampleUnicode.dof b/Example/ExampleUnicode.dof new file mode 100644 index 0000000..b5d1d6b --- /dev/null +++ b/Example/ExampleUnicode.dof @@ -0,0 +1,87 @@ +[FileVersion] +Version=6.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases= +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages= +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang=$00000409 +RootDir= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=2 +MinorVer=3 +Release=0 +Build=1 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=2.3.0.1 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=2.3.0.1 +Comments= diff --git a/Example/ExampleUnicode.dpr b/Example/ExampleUnicode.dpr new file mode 100644 index 0000000..00ec3c6 --- /dev/null +++ b/Example/ExampleUnicode.dpr @@ -0,0 +1,13 @@ +program ExampleUnicode; + +uses + Forms, + MainFrm in 'MainFrm.pas' {MainForm}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/Example/ExampleUnicode.res b/Example/ExampleUnicode.res new file mode 100644 index 0000000000000000000000000000000000000000..1694512495aca6f109f47a8bba113e17ee2382be GIT binary patch literal 1536 zcwT)|O=}ZT6g`s(8N0Cwx)2vOh={n5)CP)lQKfC5pjND8+X>ot zY<4ak?msf;pA!~zxR=5;qbFbVdU{bG72-4+jTi~!tBlB^KH_U?ESJkBGX9_2+rxHz zcgmd^epCRu!gatofn6w(AEF%!2A<-cV+0w$FWfbPLw_jT2)e%SYwqd;5%+{=>i%(@ zd!EUs6SO_A?iucC?g_8=g=Zo@NbsZjFrh#4{r(Iey1Jh5&;HPN47bR;$AjZ#WjEuw z)~%(}+?~F60$qTCgT+kWT`8D^u9agL2dDY~14;#Fr5#q(-Pt0LlICqd0wwM``Z1il zxN-y|Cx~#iAXp{t!3n;>3Vu>D2ELvFs|E{Wjrq|v7{@@pL)hm)~P+| zTRv?{g&nC^;ZXZj}GAXu_Q9!~xz*tu|}cc(xU33%C)}mWh3; zr<$jDf+eCrEJpQ}&yHwYtlgM#@K7`_$*Z!f+_vdcIjG_zPsV*tb?>OC-~)M+>ptpq zlI&^A3rzV`Tr+C66b#NIoX-ceEdPHJYmpY8o_?AOptions" for both the C++ Builder and the Delphi. + + +---A note on fonts---------------------- + +The default TFont uses "MS Sans Serif" which doesn't work well with most non-ANSI characters. I'd recommend using a TrueType font such as "Tahoma" if it is installed on the machine. To make TFont use a different font like "Tahoma" add this to the first line in the project: + + Graphics.DefFontData.Name := 'Tahoma'; + +You might have to include "Graphics" in the file's uses clauses. Furthermore, adding this line of code to the project will cause the changed setting to only be applied at runtime, not at design time. To make a designtime change, you'd have to add this line to the initialization section of a unit in a design package. + +Regarding the IDE, I use GExperts to change the font of the Object Inspector. The Wide String List editor uses the font used by the object inspector. + +Also keep in mind that the font used by certain message boxes come from that set by Windows' Display properties. + + +---Background---------------------------- + +Designing software for an international audience, I've always wanted to write a full UNICODE application. My approach so far, has been to write Unicode on the inside, and MBCS on the outside. This has always been frustrating, because (even on Windows NT/2000/XP which provide native Unicode window controls) the WideStrings inside my application and databases were always confined to an ANSI VCL. And, since the VCL was designed to wrap the low-level Windows details, why shouldn't the VCL hide the fact that sometimes native Unicode controls are not possible on the given version of Windows. I believe the VCL should be written with a Unicode interface, even if it must (at times) deal with an ANSI operating system. For example, TEdit should expose Text as a WideString, even if it has to convert the WideString to an AnsiString on the Windows 9X platform. + +In the past, the ANSI VCL may have made a little sense, considering that there were many more users of Windows 9X, than Windows NT. There would have been some performance penalty to use WideStrings on the Windows 9X platform. But with the faster computers of today, and with more people using platforms such as Windows 2000 and Windows XP, the ANSI VCL just doesn't make sense anymore. In fact, having to use the the ANSI VCL on Windows NT/2000/XP is slower because of the constant conversion to and from UNICODE inside Windows. + +My coding signature is Tnt. I will use this to denote my classes from others. + +For more information about me: +Some of my software projects (all written in Delphi). + TntMPD (contact manager for missionaries) + + Jesus Film Screen Saver + + ActiveX SCR control + + +---Design Goals---------------------------- + +I want the controls to work on Windows 95, 98, ME, NT, 2000, XP, etc. I want a single EXE for all platforms. Of course, full UNICODE support is only truly available on NT/2000/XP. In other words, the controls should automatically scale to take advantage of native Unicode support when possible. + +I want the controls to inherit from the Delphi VCL. I want to reuse as much code as possible. For the most part this makes sense. The only sticky part is where text messages get passed around. But I believe I've gotten past this through strategic subclassing at various points in the message flow chain. To give a rough comparison of why this is so important, check out the following chart which compares the lines of code in the VCL for a given control (4,397 in all), and the lines of code required in my descendent controls (655 in all). Besides saving lines of code, I get the advantage of automatically inheriting new features as new versions of Delphi come out. One such example is the AlphaBlending feature in the Delphi 6 TForm. Even though I use Delphi 5 now, I won't have to add any code to get this new feature. + +---More Interesting Information---------------------------- +Case Study: Porting an MFC Application to Unicode: It looks like the FrontPage 2002 team did the roughly the same thing to MFC as what I'm doing to the VCL. They did this with the same goal in mind: to support Unicode as much as possible depending on the support offered by Windows. Another goal was "Don’t abandon MFC; don’t rewrite app". Because they still want to support Windows 9X using the same worldwide EXE used everywhere. They couldn't just compile with the _UNICODE directive. They had to start with the ANSI MFC, strategically subclassing window procedures at just the right places. Hmmm... sounds familiar. \ No newline at end of file diff --git a/Reset Tnt Palette.reg b/Reset Tnt Palette.reg new file mode 100644 index 0000000000000000000000000000000000000000..649c0f7a39ac42144b4c8fead218cd83dfbc00d8 GIT binary patch literal 1669 zcwX(1O^d=X7=)j*;C~SBD~liN$%EaBin2&mR8}bq^$SWXwcx*Bor)lS#DgGsC`owp z&P*~Pv;TK!(A2VNGoVa1b1{Eu(Gfkt<(nZ6$$=k9U3Go!9j2-w3u1Qs5iu8H35oF4 z2YBjjp*|Z{tkqR0@TuAp?~92w=FHBvc^L!(^VImbg>!O@Pj@Gdo>^EI>B%(K3WX(x zM)63ZfD%Qs#MTXobxz+A9s--lQ=TkWVH4@)< literal 0 HcwPel00001 diff --git a/Source/ActiveIMM_TLB.pas b/Source/ActiveIMM_TLB.pas new file mode 100644 index 0000000..d8a31e7 --- /dev/null +++ b/Source/ActiveIMM_TLB.pas @@ -0,0 +1,1374 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit ActiveIMM_TLB; + +{$INCLUDE TntCompilers.inc} + +{TNT-IGNORE-UNIT} + +// ************************************************************************ // +// WARNING +// ------- +// The types declared in this file were generated from data read from a +// Type Library. If this type library is explicitly or indirectly (via +// another type library referring to this type library) re-imported, or the +// 'Refresh' command of the Type Library Editor activated while editing the +// Type Library, the contents of this file will be regenerated and all +// manual modifications will be lost. +// ************************************************************************ // + +// PASTLWTR : $Revision: 1.88.1.0.1.0 $ +// 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/Source/TntActnList.pas b/Source/TntActnList.pas new file mode 100644 index 0000000..0f3e698 --- /dev/null +++ b/Source/TntActnList.pas @@ -0,0 +1,835 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntActnList; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Controls, ActnList, Buttons, ExtCtrls, ComCtrls, StdCtrls, Menus; + +type +{TNT-WARN TActionList} + TTntActionList = class(TActionList{TNT-ALLOW TActionList}) + private + FCheckActionsTimer: TTimer; + procedure CheckActions(Sender: TObject); + public + constructor Create(AOwner: TComponent); override; + end; + + ITntAction = interface + ['{59D0AE37-8161-4AD6-9102-14B28E5761EB}'] + end; + +//--------------------------------------------------------------------------------------------- +// ACTIONS +//--------------------------------------------------------------------------------------------- + +{TNT-WARN TCustomAction} + TTntCustomAction = class(TCustomAction{TNT-ALLOW TCustomAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TAction} + TTntAction = class(TAction{TNT-ALLOW TAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +//--------------------------------------------------------------------------------------------- + +// MENU ACTION LINK +//--------------------------------------------------------------------------------------------- + +{TNT-WARN TMenuActionLink} + TTntMenuActionLink = class(TMenuActionLink{TNT-ALLOW TMenuActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +//--------------------------------------------------------------------------------------------- +// CONTROL ACTION LINKS +//--------------------------------------------------------------------------------------------- + +{TNT-WARN TListViewActionLink} + TTntListViewActionLink = class(TListViewActionLink{TNT-ALLOW TListViewActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TComboBoxExActionLink} + TTntComboBoxExActionLink = class(TComboBoxExActionLink{TNT-ALLOW TComboBoxExActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TSpeedButtonActionLink} + TTntSpeedButtonActionLink = class(TSpeedButtonActionLink{TNT-ALLOW TSpeedButtonActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + {$IFDEF COMPILER_10_UP} + function IsImageIndexLinked: Boolean; override; + procedure SetImageIndex(Value: Integer); override; + {$ENDIF} + end; + +{$IFDEF COMPILER_10_UP} +{TNT-WARN TBitBtnActionLink} + TTntBitBtnActionLink = class(TBitBtnActionLink{TNT-ALLOW TBitBtnActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + {$IFDEF COMPILER_10_UP} + function IsImageIndexLinked: Boolean; override; + procedure SetImageIndex(Value: Integer); override; + {$ENDIF} + end; +{$ENDIF} + +{TNT-WARN TToolButtonActionLink} + TTntToolButtonActionLink = class(TToolButtonActionLink{TNT-ALLOW TToolButtonActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TButtonActionLink} + TTntButtonActionLink = class(TButtonActionLink{TNT-ALLOW TButtonActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TWinControlActionLink} + TTntWinControlActionLink = class(TWinControlActionLink{TNT-ALLOW TWinControlActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +{TNT-WARN TControlActionLink} + TTntControlActionLink = class(TControlActionLink{TNT-ALLOW TControlActionLink}) + protected + function IsCaptionLinked: Boolean; override; + function IsHintLinked: Boolean; override; + procedure SetCaption(const Value: string{TNT-ALLOW string}); override; + procedure SetHint(const Value: string{TNT-ALLOW string}); override; + end; + +//--------------------------------------------------------------------------------------------- +// helper procs +//--------------------------------------------------------------------------------------------- + +//-- TCustomAction helper routines +procedure TntAction_SetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); +function TntAction_GetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; +function TntAction_GetNewCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; +procedure TntAction_SetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); +function TntAction_GetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; +function TntAction_GetNewHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; +procedure TntAction_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); + +// -- TControl helper routines +function TntControl_GetActionLinkClass(Control: TControl; InheritedLinkClass: TControlActionLinkClass): TControlActionLinkClass; +procedure TntControl_BeforeInherited_ActionChange(Control: TControl; Sender: TObject; CheckDefaults: Boolean); + +// -- TControlActionLink helper routines +function TntActionLink_IsCaptionLinked(InheritedIsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; +function TntActionLink_IsHintLinked(InheritedIsHintLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; +procedure TntActionLink_SetCaption(IsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); +procedure TntActionLink_SetHint(IsHintLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); + +type + TUpgradeActionListItemsProc = procedure (ActionList: TTntActionList); + +var + UpgradeActionListItemsProc: TUpgradeActionListItemsProc; + +implementation + +uses + SysUtils, TntMenus, TntClasses, TntControls; + +{ TActionListList } + +type + TActionListList = class(TList) + private + FActionList: TTntActionList; + protected + procedure Notify(Ptr: Pointer; Action: TListNotification); override; + end; + +procedure TActionListList.Notify(Ptr: Pointer; Action: TListNotification); +begin + inherited; + if (Action = lnAdded) and (FActionList <> nil) and (Ptr <> nil) + and (not Supports(TObject(Ptr), ITntAction)) then + begin + FActionList.FCheckActionsTimer.Enabled := False; + FActionList.FCheckActionsTimer.Enabled := True; + end; +end; + +{ THackActionList } + +type +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackCustomActionList = class(TComponent) + private + FActions: TList; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackCustomActionList = class(TComponent) + private + FActions: TList; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackCustomActionList = class(TComponent) + private + FActions: TList; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackCustomActionList = class(TComponent) + private + FActions: TList; + end; +{$ENDIF} + +{ TTntActionList } + +constructor TTntActionList.Create(AOwner: TComponent); +begin + inherited; + if (csDesigning in ComponentState) then begin + FCheckActionsTimer := TTimer.Create(Self); + FCheckActionsTimer.Enabled := False; + FCheckActionsTimer.Interval := 50; + FCheckActionsTimer.OnTimer := CheckActions; + // + THackCustomActionList(Self).FActions.Free; + THackCustomActionList(Self).FActions := TActionListList.Create; + TActionListList(THackCustomActionList(Self).FActions).FActionList := Self; + end; +end; + +procedure TTntActionList.CheckActions(Sender: TObject); +begin + if FCheckActionsTimer <> nil then begin + FCheckActionsTimer.Enabled := False; + end; + Assert(csDesigning in ComponentState); + Assert(Assigned(UpgradeActionListItemsProc)); + UpgradeActionListItemsProc(Self); +end; + +{ TCustomActionHelper } + +type + TCustomActionHelper = class(TComponent) + private + FAction: TCustomAction{TNT-ALLOW TCustomAction}; + private + FCaption: WideString; + FSettingNewCaption: Boolean; + FOldWideCaption: WideString; + FNewAnsiCaption: AnsiString; + procedure SetAnsiCaption(const Value: AnsiString); + function SettingNewCaption: Boolean; + procedure SetCaption(const Value: WideString); + function GetCaption: WideString; + private + FHint: WideString; + FSettingNewHint: Boolean; + FOldWideHint: WideString; + FNewAnsiHint: AnsiString; + procedure SetAnsiHint(const Value: AnsiString); + function SettingNewHint: Boolean; + procedure SetHint(const Value: WideString); + function GetHint: WideString; + end; + +procedure TCustomActionHelper.SetAnsiCaption(const Value: AnsiString); +begin + FAction.Caption := Value; + if (Value = '') and (FNewAnsiCaption <> '') then + FOldWideCaption := ''; +end; + +function TCustomActionHelper.SettingNewCaption: Boolean; +begin + Result := FSettingNewCaption and (FAction.Caption <> FNewAnsiCaption); +end; + +function TCustomActionHelper.GetCaption: WideString; +begin + if SettingNewCaption then + Result := FOldWideCaption + else + Result := GetSyncedWideString(FCaption, FAction.Caption) +end; + +procedure TCustomActionHelper.SetCaption(const Value: WideString); +begin + FOldWideCaption := GetCaption; + FNewAnsiCaption := Value; + FSettingNewCaption := True; + try + SetSyncedWideString(Value, FCaption, FAction.Caption, SetAnsiCaption) + finally + FSettingNewCaption := False; + end; +end; + +procedure TCustomActionHelper.SetAnsiHint(const Value: AnsiString); +begin + FAction.Hint := Value; + if (Value = '') and (FNewAnsiHint <> '') then + FOldWideHint := ''; +end; + +function TCustomActionHelper.SettingNewHint: Boolean; +begin + Result := FSettingNewHint and (FAction.Hint <> FNewAnsiHint); +end; + +function TCustomActionHelper.GetHint: WideString; +begin + if SettingNewHint then + Result := FOldWideHint + else + Result := GetSyncedWideString(FHint, FAction.Hint) +end; + +procedure TCustomActionHelper.SetHint(const Value: WideString); +begin + FOldWideHint := GetHint; + FNewAnsiHint := Value; + FSettingNewHint := True; + try + SetSyncedWideString(Value, FHint, FAction.Hint, SetAnsiHint) + finally + FSettingNewHint := False; + end; +end; + +function FindActionHelper(Action: TCustomAction{TNT-ALLOW TCustomAction}): TCustomActionHelper; +var + i: integer; +begin + Assert(Action <> nil); + Result := nil; + if Supports(Action, ITntAction) then begin + for i := 0 to Action.ComponentCount - 1 do begin + if Action.Components[i] is TCustomActionHelper then begin + Result := TCustomActionHelper(Action.Components[i]); + break; + end; + end; + if Result = nil then begin + Result := TCustomActionHelper.Create(Action); + Result.FAction := Action; + end; + end; +end; + +//-- TCustomAction helper routines + +procedure TntAction_SetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); +begin + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + SetCaption(Value) + else + Action.Caption := Value; +end; + +function TntAction_GetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; +begin + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + Result := GetCaption + else + Result := Action.Caption; +end; + +function TntAction_GetNewCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; +begin + Result := Default; + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + if SettingNewCaption then + Result := FCaption; +end; + +procedure TntAction_SetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); +begin + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + SetHint(Value) + else + Action.Hint := Value; +end; + +function TntAction_GetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; +begin + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + Result := GetHint + else + Result := Action.Hint; +end; + +function TntAction_GetNewHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; +begin + Result := Default; + if Supports(Action, ITntAction) then + with FindActionHelper(Action) do + if SettingNewHint then + Result := FHint; +end; + +procedure TntAction_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + with Action do begin + if (Source is TCustomAction{TNT-ALLOW TCustomAction}) then begin + Caption := TntAction_GetCaption(Source as TCustomAction{TNT-ALLOW TCustomAction}); + Hint := TntAction_GetHint(Source as TCustomAction{TNT-ALLOW TCustomAction}); + end else if (Source is TControl) then begin + Caption := TntControl_GetText(Source as TControl); + Hint := TntControl_GetHint(Source as TControl); + end; + end; +end; + +// -- TControl helper routines + +function TntControl_GetActionLinkClass(Control: TControl; InheritedLinkClass: TControlActionLinkClass): TControlActionLinkClass; +begin + if Control is TCustomListView{TNT-ALLOW TCustomListView} then + Result := TTntListViewActionLink + else if Control is TComboBoxEx then + Result := TTntComboBoxExActionLink + else if Control is TSpeedButton{TNT-ALLOW TSpeedButton} then + Result := TTntSpeedButtonActionLink + {$IFDEF COMPILER_10_UP} + else if Control is TBitBtn{TNT-ALLOW TBitBtn} then + Result := TTntBitBtnActionLink + {$ENDIF} + else if Control is TToolButton{TNT-ALLOW TToolButton} then + Result := TTntToolButtonActionLink + else if Control is TButtonControl then + Result := TTntButtonActionLink + else if Control is TWinControl then + Result := TTntWinControlActionLink + else + Result := TTntControlActionLink; + + Assert(Result.ClassParent = InheritedLinkClass); +end; + +procedure TntControl_BeforeInherited_ActionChange(Control: TControl; Sender: TObject; CheckDefaults: Boolean); +begin + if (Sender is TCustomAction{TNT-ALLOW TCustomAction}) and Supports(Sender, ITntAction) then begin + if not CheckDefaults or (TntControl_GetText(Control) = '') or (TntControl_GetText(Control) = Control.Name) then + TntControl_SetText(Control, TntAction_GetCaption(TCustomAction{TNT-ALLOW TCustomAction}(Sender))); + if not CheckDefaults or (TntControl_GetHint(Control) = '') then + TntControl_SetHint(Control, TntAction_GetHint(TCustomAction{TNT-ALLOW TCustomAction}(Sender))); + end; +end; + +// -- TControlActionLink helper routines + +function TntActionLink_IsCaptionLinked(InheritedIsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; +begin + Result := InheritedIsCaptionLinked + and (TntAction_GetCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}) = TntControl_GetText(FClient)); +end; + +function TntActionLink_IsHintLinked(InheritedIsHintLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; +begin + Result := InheritedIsHintLinked + and (TntAction_GetHint(Action as TCustomAction{TNT-ALLOW TCustomAction}) = TntControl_GetHint(FClient)); +end; + +procedure TntActionLink_SetCaption(IsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); +begin + if IsCaptionLinked then + TntControl_SetText(FClient, TntAction_GetNewCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value)); +end; + +procedure TntActionLink_SetHint(IsHintLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); +begin + if IsHintLinked then + TntControl_SetHint(FClient, TntAction_GetNewHint(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value)); +end; + +//--------------------------------------------------------------------------------------------- +// ACTIONS +//--------------------------------------------------------------------------------------------- + +{ TTntCustomAction } + +procedure TTntCustomAction.Assign(Source: TPersistent); +begin + inherited; + TntAction_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCustomAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCustomAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCustomAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCustomAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntAction } + +procedure TTntAction.Assign(Source: TPersistent); +begin + inherited; + TntAction_AfterInherited_Assign(Self, Source); +end; + +procedure TTntAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +//--------------------------------------------------------------------------------------------- +// MENU ACTION LINK +//--------------------------------------------------------------------------------------------- + +{ TTntMenuActionLink } + +function TTntMenuActionLink.IsCaptionLinked: Boolean; +begin + Result := inherited IsCaptionLinked + and WideSameCaption(TntAction_GetCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}), (FClient as TTntMenuItem).Caption); +end; + +function TTntMenuActionLink.IsHintLinked: Boolean; +begin + Result := inherited IsHintLinked + and (TntAction_GetHint(Action as TCustomAction{TNT-ALLOW TCustomAction}) = (FClient as TTntMenuItem).Hint); +end; + +procedure TTntMenuActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + if IsCaptionLinked then + (FClient as TTntMenuItem).Caption := TntAction_GetNewCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value); +end; + +procedure TTntMenuActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + if IsHintLinked then + (FClient as TTntMenuItem).Hint := TntAction_GetNewHint(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value); +end; + +//--------------------------------------------------------------------------------------------- +// CONTROL ACTION LINKS +//--------------------------------------------------------------------------------------------- + +{ TTntListViewActionLink } + +function TTntListViewActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntListViewActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntListViewActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntListViewActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntComboBoxExActionLink } + +function TTntComboBoxExActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntComboBoxExActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntComboBoxExActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntComboBoxExActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntSpeedButtonActionLink } + +function TTntSpeedButtonActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntSpeedButtonActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntSpeedButtonActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntSpeedButtonActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{$IFDEF COMPILER_10_UP} +// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. + +function TTntSpeedButtonActionLink.IsImageIndexLinked: Boolean; +begin + Result := Action is TCustomAction{TNT-ALLOW TCustomAction}; // taken from TActionLink.IsImageIndexLinked +end; + +procedure TTntSpeedButtonActionLink.SetImageIndex(Value: Integer); +begin + ; // taken from TActionLink.IsImageIndexLinked +end; +{$ENDIF} + +{$IFDEF COMPILER_10_UP} +{ TTntBitBtnActionLink } + +function TTntBitBtnActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntBitBtnActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntBitBtnActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntBitBtnActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{$IFDEF COMPILER_10_UP} +// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. + +function TTntBitBtnActionLink.IsImageIndexLinked: Boolean; +begin + Result := Action is TCustomAction{TNT-ALLOW TCustomAction}; // taken from TActionLink.IsImageIndexLinked +end; + +procedure TTntBitBtnActionLink.SetImageIndex(Value: Integer); +begin + ; // taken from TActionLink.IsImageIndexLinked +end; +{$ENDIF} + +{$ENDIF} + +{ TTntToolButtonActionLink } + +function TTntToolButtonActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntToolButtonActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntToolButtonActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntToolButtonActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntButtonActionLink } + +function TTntButtonActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntButtonActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntButtonActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntButtonActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntWinControlActionLink } + +function TTntWinControlActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntWinControlActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntWinControlActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntWinControlActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +{ TTntControlActionLink } + +function TTntControlActionLink.IsCaptionLinked: Boolean; +begin + Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); +end; + +function TTntControlActionLink.IsHintLinked: Boolean; +begin + Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); +end; + +procedure TTntControlActionLink.SetCaption(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); +end; + +procedure TTntControlActionLink.SetHint(const Value: string{TNT-ALLOW string}); +begin + TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); +end; + +end. diff --git a/Source/TntAxCtrls.pas b/Source/TntAxCtrls.pas new file mode 100644 index 0000000..bc4b03c --- /dev/null +++ b/Source/TntAxCtrls.pas @@ -0,0 +1,191 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntAxCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + ComObj, StdVcl, + {$IFNDEF COMPILER_10_UP} + TntWideStrings, + {$ELSE} + WideStrings, + {$ENDIF} + TntClasses; + +type + TWideStringsAdapter = class(TAutoIntfObject, IStrings, IWideStringsAdapter) + private + FStrings: TWideStrings; + protected + { IWideStringsAdapter } + procedure ReferenceStrings(S: TWideStrings); + procedure ReleaseStrings; + { IStrings } + function Get_ControlDefault(Index: Integer): OleVariant; safecall; + procedure Set_ControlDefault(Index: Integer; Value: OleVariant); safecall; + function Count: Integer; safecall; + function Get_Item(Index: Integer): OleVariant; safecall; + procedure Set_Item(Index: Integer; Value: OleVariant); safecall; + procedure Remove(Index: Integer); safecall; + procedure Clear; safecall; + function Add(Item: OleVariant): Integer; safecall; + function _NewEnum: IUnknown; safecall; + public + constructor Create(Strings: TTntStrings); + end; + +implementation + +uses + Classes, ActiveX, Variants; + +{ TStringsEnumerator } + +type + TStringsEnumerator = class(TContainedObject, IEnumString) + private + FIndex: Integer; // index of next unread string + FStrings: IStrings; + public + constructor Create(const Strings: IStrings); + function Next(celt: Longint; out elt; + pceltFetched: PLongint): HResult; stdcall; + function Skip(celt: Longint): HResult; stdcall; + function Reset: HResult; stdcall; + function Clone(out enm: IEnumString): HResult; stdcall; + end; + +constructor TStringsEnumerator.Create(const Strings: IStrings); +begin + inherited Create(Strings); + FStrings := Strings; +end; + +function TStringsEnumerator.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; +var + I: Integer; +begin + I := 0; + while (I < celt) and (FIndex < FStrings.Count) do + begin + TPointerList(elt)[I] := PWideChar(WideString(FStrings.Item[FIndex])); + Inc(I); + Inc(FIndex); + end; + if pceltFetched <> nil then pceltFetched^ := I; + if I = celt then Result := S_OK else Result := S_FALSE; +end; + +function TStringsEnumerator.Skip(celt: Longint): HResult; +begin + if (FIndex + celt) <= FStrings.Count then + begin + Inc(FIndex, celt); + Result := S_OK; + end + else + begin + FIndex := FStrings.Count; + Result := S_FALSE; + end; +end; + +function TStringsEnumerator.Reset: HResult; +begin + FIndex := 0; + Result := S_OK; +end; + +function TStringsEnumerator.Clone(out enm: IEnumString): HResult; +begin + try + enm := TStringsEnumerator.Create(FStrings); + TStringsEnumerator(enm).FIndex := FIndex; + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +{ TWideStringsAdapter } + +constructor TWideStringsAdapter.Create(Strings: TTntStrings); +var + StdVcl: ITypeLib; +begin + OleCheck(LoadRegTypeLib(LIBID_STDVCL, 4, 0, 0, StdVcl)); + inherited Create(StdVcl, IStrings); + FStrings := Strings; +end; + +procedure TWideStringsAdapter.ReferenceStrings(S: TWideStrings); +begin + FStrings := S; +end; + +procedure TWideStringsAdapter.ReleaseStrings; +begin + FStrings := nil; +end; + +function TWideStringsAdapter.Get_ControlDefault(Index: Integer): OleVariant; +begin + Result := Get_Item(Index); +end; + +procedure TWideStringsAdapter.Set_ControlDefault(Index: Integer; Value: OleVariant); +begin + Set_Item(Index, Value); +end; + +function TWideStringsAdapter.Count: Integer; +begin + Result := 0; + if FStrings <> nil then Result := FStrings.Count; +end; + +function TWideStringsAdapter.Get_Item(Index: Integer): OleVariant; +begin + Result := NULL; + if (FStrings <> nil) then Result := WideString(FStrings[Index]); +end; + +procedure TWideStringsAdapter.Set_Item(Index: Integer; Value: OleVariant); +begin + if (FStrings <> nil) then FStrings[Index] := Value; +end; + +procedure TWideStringsAdapter.Remove(Index: Integer); +begin + if FStrings <> nil then FStrings.Delete(Index); +end; + +procedure TWideStringsAdapter.Clear; +begin + if FStrings <> nil then FStrings.Clear; +end; + +function TWideStringsAdapter.Add(Item: OleVariant): Integer; +begin + Result := -1; + if FStrings <> nil then Result := FStrings.Add(Item); +end; + +function TWideStringsAdapter._NewEnum: IUnknown; +begin + Result := TStringsEnumerator.Create(Self); +end; + +end. diff --git a/Source/TntBandActn.pas b/Source/TntBandActn.pas new file mode 100644 index 0000000..2528c42 --- /dev/null +++ b/Source/TntBandActn.pas @@ -0,0 +1,92 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntBandActn; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, BandActn, TntActnList; + +type +{TNT-WARN TCustomizeActionBars} + TTntCustomizeActionBars = class(TCustomizeActionBars{TNT-ALLOW TCustomizeActionBars}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +implementation + +uses + ActnList, TntClasses; + +{TNT-IGNORE-UNIT} + +procedure TntBandActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntAction_AfterInherited_Assign(Action, Source); + // TCustomizeActionBars + if (Action is TCustomizeActionBars) and (Source is TCustomizeActionBars) then begin + TCustomizeActionBars(Action).ActionManager := TCustomizeActionBars(Source).ActionManager; + end; +end; + +//------------------------- +// TNT BAND ACTN +//------------------------- + +{ TTntCustomizeActionBars } + +procedure TTntCustomizeActionBars.Assign(Source: TPersistent); +begin + inherited; + TntBandActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCustomizeActionBars.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomizeActionBars.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCustomizeActionBars.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCustomizeActionBars.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCustomizeActionBars.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/Source/TntButtons.pas b/Source/TntButtons.pas new file mode 100644 index 0000000..dd2ab60 --- /dev/null +++ b/Source/TntButtons.pas @@ -0,0 +1,982 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntButtons; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Windows, Messages, Classes, Controls, Graphics, StdCtrls, + ExtCtrls, CommCtrl, Buttons, + TntControls; + +type + ITntGlyphButton = interface + ['{15D7E501-1E33-4293-8B45-716FB3B14504}'] + function GetButtonGlyph: Pointer; + procedure UpdateInternalGlyphList; + end; + +{TNT-WARN TSpeedButton} + TTntSpeedButton = class(TSpeedButton {TNT-ALLOW TSpeedButton}, ITntGlyphButton) + private + FPaintInherited: Boolean; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + function GetButtonGlyph: Pointer; + procedure UpdateInternalGlyphList; dynamic; + procedure PaintButton; dynamic; + procedure Paint; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TBitBtn} + TTntBitBtn = class(TBitBtn {TNT-ALLOW TBitBtn}, ITntGlyphButton) + private + FPaintInherited: Boolean; + FMouseInControl: Boolean; + function IsCaptionStored: Boolean; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; + procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + protected + function GetButtonGlyph: Pointer; + procedure UpdateInternalGlyphList; dynamic; + procedure DrawItem(const DrawItemStruct: TDrawItemStruct); dynamic; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +procedure TButtonGlyph_CalcButtonLayout(Control: TControl; DC: HDC; const Client: TRect; + const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; + Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect; + BiDiFlags: Integer {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}); + +function TButtonGlyph_Draw(Control: TControl; Canvas: TCanvas; const Client: TRect; + const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; Margin: Integer; + Spacing: Integer; State: TButtonState; Transparent: Boolean; + BiDiFlags: Longint {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}): TRect; + +implementation + +uses + SysUtils, ActnList, TntForms, TntStdCtrls, TypInfo, RTLConsts, TntWindows, + {$IFDEF THEME_7_UP} Themes, {$ENDIF} TntClasses, TntActnList, TntSysUtils; + +type + EAbortPaint = class(EAbort); + +// Many routines in this unit are nearly the same as those found in Buttons.pas. They are +// included here because the VCL implementation of TButtonGlyph is completetly inaccessible. + +type + THackButtonGlyph_D6_D7_D9 = class + protected + FOriginal: TBitmap; + FGlyphList: TImageList; + FIndexs: array[TButtonState] of Integer; + FxxxxTransparentColor: TColor; + FNumGlyphs: TNumGlyphs; + end; + + THackBitBtn_D6_D7_D9 = class(TButton{TNT-ALLOW TButton}) + protected + FCanvas: TCanvas; + FGlyph: Pointer; + FxxxxStyle: TButtonStyle; + FxxxxKind: TBitBtnKind; + FxxxxLayout: TButtonLayout; + FxxxxSpacing: Integer; + FxxxxMargin: Integer; + IsFocused: Boolean; + end; + + THackSpeedButton_D6_D7_D9 = class(TGraphicControl) + protected + FxxxxGroupIndex: Integer; + FGlyph: Pointer; + FxxxxDown: Boolean; + FDragging: Boolean; + end; + + {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackButtonGlyph = THackButtonGlyph_D6_D7_D9; + THackBitBtn = THackBitBtn_D6_D7_D9; + THackSpeedButton = THackSpeedButton_D6_D7_D9; + {$ENDIF} + {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackButtonGlyph = THackButtonGlyph_D6_D7_D9; + THackBitBtn = THackBitBtn_D6_D7_D9; + THackSpeedButton = THackSpeedButton_D6_D7_D9; + {$ENDIF} + {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackButtonGlyph = THackButtonGlyph_D6_D7_D9; + THackBitBtn = THackBitBtn_D6_D7_D9; + THackSpeedButton = THackSpeedButton_D6_D7_D9; + {$ENDIF} + {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackButtonGlyph = THackButtonGlyph_D6_D7_D9; + THackBitBtn = THackBitBtn_D6_D7_D9; + THackSpeedButton = THackSpeedButton_D6_D7_D9; + {$ENDIF} + +function GetButtonGlyph(Control: TControl): THackButtonGlyph; +var + GlyphButton: ITntGlyphButton; +begin + if Control.GetInterface(ITntGlyphButton, GlyphButton) then + Result := GlyphButton.GetButtonGlyph + else + raise ETntInternalError.Create('Internal Error: Control does not support ITntGlyphButton.'); +end; + +procedure UpdateInternalGlyphList(Control: TControl); +var + GlyphButton: ITntGlyphButton; +begin + if Control.GetInterface(ITntGlyphButton, GlyphButton) then + GlyphButton.UpdateInternalGlyphList + else + raise ETntInternalError.Create('Internal Error: Control does not support ITntGlyphButton.'); +end; + +function TButtonGlyph_CreateButtonGlyph(Control: TControl; State: TButtonState): Integer; +var + ButtonGlyph: THackButtonGlyph; + NumGlyphs: Integer; +begin + ButtonGlyph := GetButtonGlyph(Control); + NumGlyphs := ButtonGlyph.FNumGlyphs; + + if (State = bsDown) and (NumGlyphs < 3) then State := bsUp; + Result := ButtonGlyph.FIndexs[State]; + if (Result = -1) then begin + UpdateInternalGlyphList(Control); + Result := ButtonGlyph.FIndexs[State]; + end; +end; + +procedure TButtonGlyph_DrawButtonGlyph(Control: TControl; Canvas: TCanvas; const GlyphPos: TPoint; + State: TButtonState; Transparent: Boolean); +var + ButtonGlyph: THackButtonGlyph; + Glyph: TBitmap; + GlyphList: TImageList; + Index: Integer; + {$IFDEF THEME_7_UP} + Details: TThemedElementDetails; + R: TRect; + Button: TThemedButton; + {$ENDIF} +begin + ButtonGlyph := GetButtonGlyph(Control); + Glyph := ButtonGlyph.FOriginal; + GlyphList := ButtonGlyph.FGlyphList; + if Glyph = nil then Exit; + if (Glyph.Width = 0) or (Glyph.Height = 0) then Exit; + Index := TButtonGlyph_CreateButtonGlyph(Control, State); + with GlyphPos do + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled then begin + R.TopLeft := GlyphPos; + R.Right := R.Left + Glyph.Width div ButtonGlyph.FNumGlyphs; + R.Bottom := R.Top + Glyph.Height; + case State of + bsDisabled: + Button := tbPushButtonDisabled; + bsDown, + bsExclusive: + Button := tbPushButtonPressed; + else + // bsUp + Button := tbPushButtonNormal; + end; + Details := ThemeServices.GetElementDetails(Button); + ThemeServices.DrawIcon(Canvas.Handle, Details, R, GlyphList.Handle, Index); + end else + {$ENDIF} + if Transparent or (State = bsExclusive) then + ImageList_DrawEx(GlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0, + clNone, clNone, ILD_Transparent) + else + ImageList_DrawEx(GlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0, + ColorToRGB(clBtnFace), clNone, ILD_Normal); +end; + +procedure TButtonGlyph_DrawButtonText(Canvas: TCanvas; const Caption: WideString; + TextBounds: TRect; State: TButtonState; + BiDiFlags: LongInt {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}); +begin + with Canvas do + begin + Brush.Style := bsClear; + if State = bsDisabled then + begin + OffsetRect(TextBounds, 1, 1); + Font.Color := clBtnHighlight; + + {$IFDEF COMPILER_7_UP} + if WordWrap then + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_VCENTER or BiDiFlags or DT_WORDBREAK) + else + {$ENDIF} + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_VCENTER or BiDiFlags); + + OffsetRect(TextBounds, -1, -1); + Font.Color := clBtnShadow; + + {$IFDEF COMPILER_7_UP} + if WordWrap then + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_WORDBREAK or BiDiFlags) { TODO: Figure out why DT_VCENTER is not used } + else + {$ENDIF} + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_VCENTER or BiDiFlags); + + end else + begin + {$IFDEF COMPILER_7_UP} + if WordWrap then + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_WORDBREAK or BiDiFlags) { TODO: Figure out why DT_VCENTER is not used } + else + {$ENDIF} + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, + DT_CENTER or DT_VCENTER or BiDiFlags); + end; + end; +end; + +procedure TButtonGlyph_CalcButtonLayout(Control: TControl; DC: HDC; const Client: TRect; + const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; + Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect; + BiDiFlags: Integer {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}); +var + TextPos: TPoint; + ClientSize, + GlyphSize, + TextSize: TPoint; + TotalSize: TPoint; + Glyph: TBitmap; + NumGlyphs: Integer; + ButtonGlyph: THackButtonGlyph; +begin + ButtonGlyph := GetButtonGlyph(Control); + Glyph := ButtonGlyph.FOriginal; + NumGlyphs := ButtonGlyph.FNumGlyphs; + + if (BiDiFlags and DT_RIGHT) = DT_RIGHT then + if Layout = blGlyphLeft then + Layout := blGlyphRight + else + if Layout = blGlyphRight then + Layout := blGlyphLeft; + + // Calculate the item sizes. + ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top); + + if Assigned(Glyph) then + GlyphSize := Point(Glyph.Width div NumGlyphs, Glyph.Height) + else + GlyphSize := Point(0, 0); + + if Length(Caption) > 0 then + begin + {$IFDEF COMPILER_7_UP} + TextBounds := Rect(0, 0, Client.Right - Client.Left - GlyphSize.X - 3, 0); { TODO: Figure out why GlyphSize.X is in here. } + {$ELSE} + TextBounds := Rect(0, 0, Client.Right - Client.Left, 0); + {$ENDIF} + + {$IFDEF COMPILER_7_UP} + if WordWrap then + Tnt_DrawTextW(DC, PWideChar(Caption), Length(Caption), TextBounds, DT_WORDBREAK + or DT_CALCRECT or BiDiFlags) + else + {$ENDIF} + Tnt_DrawTextW(DC, PWideChar(Caption), Length(Caption), TextBounds, DT_CALCRECT or BiDiFlags); + + TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom - TextBounds.Top); + end + else + begin + TextBounds := Rect(0, 0, 0, 0); + TextSize := Point(0, 0); + end; + + // If the layout has the glyph on the right or the left, then both the text and the glyph are centered vertically. + // If the glyph is on the top or the bottom, then both the text and the glyph are centered horizontally. + if Layout in [blGlyphLeft, blGlyphRight] then + begin + GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2; + TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2; + end + else + begin + GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2; + TextPos.X := (ClientSize.X - TextSize.X + 1) div 2; + end; + + // If there is no text or no bitmap, then Spacing is irrelevant. + if (TextSize.X = 0) or (GlyphSize.X = 0) then + Spacing := 0; + + // Adjust Margin and Spacing. + if Margin = -1 then + begin + if Spacing = -1 then + begin + TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y); + if Layout in [blGlyphLeft, blGlyphRight] then + Margin := (ClientSize.X - TotalSize.X) div 3 + else + Margin := (ClientSize.Y - TotalSize.Y) div 3; + Spacing := Margin; + end + else + begin + TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y + Spacing + TextSize.Y); + if Layout in [blGlyphLeft, blGlyphRight] then + Margin := (ClientSize.X - TotalSize.X + 1) div 2 + else + Margin := (ClientSize.Y - TotalSize.Y + 1) div 2; + end; + end + else + begin + if Spacing = -1 then + begin + TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y - (Margin + GlyphSize.Y)); + if Layout in [blGlyphLeft, blGlyphRight] then + Spacing := (TotalSize.X - TextSize.X) div 2 + else + Spacing := (TotalSize.Y - TextSize.Y) div 2; + end; + end; + + case Layout of + blGlyphLeft: + begin + GlyphPos.X := Margin; + TextPos.X := GlyphPos.X + GlyphSize.X + Spacing; + end; + blGlyphRight: + begin + GlyphPos.X := ClientSize.X - Margin - GlyphSize.X; + TextPos.X := GlyphPos.X - Spacing - TextSize.X; + end; + blGlyphTop: + begin + GlyphPos.Y := Margin; + TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing; + end; + blGlyphBottom: + begin + GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y; + TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y; + end; + end; + + // Fixup the Result variables. + with GlyphPos do + begin + Inc(X, Client.Left + Offset.X); + Inc(Y, Client.Top + Offset.Y); + end; + + {$IFDEF THEME_7_UP} + { Themed text is not shifted, but gets a different color. } + if ThemeServices.ThemesEnabled then + OffsetRect(TextBounds, TextPos.X + Client.Left, TextPos.Y + Client.Top) + else + {$ENDIF} + OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X, TextPos.Y + Client.Top + Offset.Y); +end; + +function TButtonGlyph_Draw(Control: TControl; Canvas: TCanvas; const Client: TRect; + const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; Margin: Integer; + Spacing: Integer; State: TButtonState; Transparent: Boolean; + BiDiFlags: Longint {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}): TRect; +var + GlyphPos: TPoint; +begin + TButtonGlyph_CalcButtonLayout(Control, Canvas.Handle, Client, Offset, Caption, Layout, Margin, + Spacing, GlyphPos, Result, BiDiFlags {$IFDEF COMPILER_7_UP}, WordWrap {$ENDIF}); + TButtonGlyph_DrawButtonGlyph(Control, Canvas, GlyphPos, State, Transparent); + TButtonGlyph_DrawButtonText(Canvas, Caption, Result, State, + BiDiFlags {$IFDEF COMPILER_7_UP}, WordWrap {$ENDIF}); +end; + +{ TTntSpeedButton } + +procedure TTntSpeedButton.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSpeedButton.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntSpeedButton.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntSpeedButton.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntSpeedButton.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntSpeedButton.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntSpeedButton.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntSpeedButton.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntSpeedButton.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(CharCode, Caption) and Enabled and Visible and + (Parent <> nil) and Parent.Showing then + begin + Click; + Result := 1; + end else + inherited; +end; + +function TTntSpeedButton.GetButtonGlyph: Pointer; +begin + Result := THackSpeedButton(Self).FGlyph; +end; + +procedure TTntSpeedButton.UpdateInternalGlyphList; +begin + FPaintInherited := True; + try + Repaint; + finally + FPaintInherited := False; + end; + Invalidate; + raise EAbortPaint.Create(''); +end; + +procedure TTntSpeedButton.Paint; +begin + if FPaintInherited then + inherited + else + PaintButton; +end; + +procedure TTntSpeedButton.PaintButton; +const + DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER); + FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0); +var + PaintRect: TRect; + DrawFlags: Integer; + Offset: TPoint; + {$IFDEF THEME_7_UP} + Button: TThemedButton; + ToolButton: TThemedToolBar; + Details: TThemedElementDetails; + {$ENDIF} +begin + try + if not Enabled then + begin + FState := bsDisabled; + THackSpeedButton(Self).FDragging := False; + end + else if FState = bsDisabled then + if Down and (GroupIndex <> 0) then + FState := bsExclusive + else + FState := bsUp; + Canvas.Font := Self.Font; + + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled then + begin + {$IFDEF COMPILER_7_UP} + PerformEraseBackground(Self, Canvas.Handle); + {$ENDIF} + SelectObject(Canvas.Handle, Canvas.Font.Handle); { For some reason, PerformEraseBackground sometimes messes the font up. } + + if not Enabled then + Button := tbPushButtonDisabled + else + if FState in [bsDown, bsExclusive] then + Button := tbPushButtonPressed + else + if MouseInControl then + Button := tbPushButtonHot + else + Button := tbPushButtonNormal; + + ToolButton := ttbToolbarDontCare; + if Flat then + begin + case Button of + tbPushButtonDisabled: + Toolbutton := ttbButtonDisabled; + tbPushButtonPressed: + Toolbutton := ttbButtonPressed; + tbPushButtonHot: + Toolbutton := ttbButtonHot; + tbPushButtonNormal: + Toolbutton := ttbButtonNormal; + end; + end; + + PaintRect := ClientRect; + if ToolButton = ttbToolbarDontCare then + begin + Details := ThemeServices.GetElementDetails(Button); + ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect); + PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect); + end + else + begin + Details := ThemeServices.GetElementDetails(ToolButton); + ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect); + PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect); + end; + + if Button = tbPushButtonPressed then + begin + // A pressed speed button has a white text. This applies however only to flat buttons. + if ToolButton <> ttbToolbarDontCare then + Canvas.Font.Color := clHighlightText; + Offset := Point(1, 0); + end + else + Offset := Point(0, 0); + TButtonGlyph_Draw(Self, Canvas, PaintRect, Offset, Caption, Layout, Margin, Spacing, FState, + Transparent, DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, False {$ENDIF}); + end + else + {$ENDIF} + begin + PaintRect := Rect(0, 0, Width, Height); + if not Flat then + begin + DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT; + if FState in [bsDown, bsExclusive] then + DrawFlags := DrawFlags or DFCS_PUSHED; + DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags); + end + else + begin + if (FState in [bsDown, bsExclusive]) or + (MouseInControl and (FState <> bsDisabled)) or + (csDesigning in ComponentState) then + DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]], + FillStyles[Transparent] or BF_RECT) + else if not Transparent then + begin + Canvas.Brush.Color := Color; + Canvas.FillRect(PaintRect); + end; + InflateRect(PaintRect, -1, -1); + end; + if FState in [bsDown, bsExclusive] then + begin + if (FState = bsExclusive) and (not Flat or not MouseInControl) then + begin + Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight); + Canvas.FillRect(PaintRect); + end; + Offset.X := 1; + Offset.Y := 1; + end + else + begin + Offset.X := 0; + Offset.Y := 0; + end; + TButtonGlyph_Draw(Self, Canvas, PaintRect, Offset, Caption, + Layout, Margin, Spacing, FState, Transparent, + DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, False {$ENDIF}); + end; + except + on E: EAbortPaint do + ; + else + raise; + end; +end; + +function TTntSpeedButton.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{$IFDEF COMPILER_10_UP} +type + TAccessGraphicControl = class(TGraphicControl); +{$ENDIF} + +procedure TTntSpeedButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +{$IFDEF COMPILER_10_UP} +// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. +type + CallActionChange = procedure(Sender: TObject; CheckDefaults: Boolean) of object; +var + M: TMethod; +{$ENDIF} +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + {$IFNDEF COMPILER_10_UP} + inherited; + {$ELSE} + // call TGraphicControl.ActionChange (bypass TSpeedButton.ActionChange) + M.Code := @TAccessGraphicControl.ActionChange; + M.Data := Self; + CallActionChange(M)(Sender, CheckDefaults); + // call Delphi2005's TSpeedButton.ActionChange + if Sender is TCustomAction{TNT-ALLOW TCustomAction} then + with TCustomAction{TNT-ALLOW TCustomAction}(Sender) do + begin + if CheckDefaults or (Self.GroupIndex = 0) then + Self.GroupIndex := GroupIndex; + { Copy image from action's imagelist } + if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and + (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then + CopyImage(ActionList.Images, ImageIndex); + end; + {$ENDIF} +end; + +{ TTntBitBtn } + +procedure TTntBitBtn.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntBitBtn.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntBitBtn.IsCaptionStored: Boolean; +var + BaseClass: TClass; + PropInfo: PPropInfo; +begin + Assert(Self is TButton{TNT-ALLOW TButton}); + Assert(Self is TBitBtn{TNT-ALLOW TBitBtn}); + if Kind = bkCustom then + // don't use TBitBtn, it's broken for Kind <> bkCustom + BaseClass := TButton{TNT-ALLOW TButton} + else begin + //TBitBtn has it's own storage specifier, based upon the button kind + BaseClass := TBitBtn{TNT-ALLOW TBitBtn}; + end; + PropInfo := GetPropInfo(BaseClass, 'Caption'); + if PropInfo = nil then + raise EPropertyError.CreateResFmt(PResStringRec(@SUnknownProperty), ['Caption']); + Result := IsStoredProp(Self, PropInfo); +end; + +function TTntBitBtn.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntBitBtn.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntBitBtn.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntBitBtn.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntBitBtn.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntBitBtn.CMDialogChar(var Message: TCMDialogChar); +begin + TntButton_CMDialogChar(Self, Message); +end; + +function TTntBitBtn.GetButtonGlyph: Pointer; +begin + Result := THackBitBtn(Self).FGlyph; +end; + +procedure TTntBitBtn.UpdateInternalGlyphList; +begin + FPaintInherited := True; + try + Repaint; + finally + FPaintInherited := False; + end; + Invalidate; + raise EAbortPaint.Create(''); +end; + +procedure TTntBitBtn.CNDrawItem(var Message: TWMDrawItem); +begin + if FPaintInherited then + inherited + else + DrawItem(Message.DrawItemStruct^); +end; + +procedure TTntBitBtn.DrawItem(const DrawItemStruct: TDrawItemStruct); +var + IsDown, IsDefault: Boolean; + State: TButtonState; + R: TRect; + Flags: Longint; + FCanvas: TCanvas; + IsFocused: Boolean; + {$IFDEF THEME_7_UP} + Details: TThemedElementDetails; + Button: TThemedButton; + Offset: TPoint; + {$ENDIF} +begin + try + FCanvas := THackBitBtn(Self).FCanvas; + IsFocused := THackBitBtn(Self).IsFocused; + FCanvas.Handle := DrawItemStruct.hDC; + R := ClientRect; + + with DrawItemStruct do + begin + FCanvas.Handle := hDC; + FCanvas.Font := Self.Font; + IsDown := itemState and ODS_SELECTED <> 0; + IsDefault := itemState and ODS_FOCUS <> 0; + + if not Enabled then State := bsDisabled + else if IsDown then State := bsDown + else State := bsUp; + end; + + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled then + begin + if not Enabled then + Button := tbPushButtonDisabled + else + if IsDown then + Button := tbPushButtonPressed + else + if FMouseInControl then + Button := tbPushButtonHot + else + if IsFocused or IsDefault then + Button := tbPushButtonDefaulted + else + Button := tbPushButtonNormal; + + Details := ThemeServices.GetElementDetails(Button); + // Parent background. + ThemeServices.DrawParentBackground(Handle, DrawItemStruct.hDC, @Details, True); + // Button shape. + ThemeServices.DrawElement(DrawItemStruct.hDC, Details, DrawItemStruct.rcItem); + R := ThemeServices.ContentRect(FCanvas.Handle, Details, DrawItemStruct.rcItem); + + if Button = tbPushButtonPressed then + Offset := Point(1, 0) + else + Offset := Point(0, 0); + TButtonGlyph_Draw(Self, FCanvas, R, Offset, Caption, Layout, Margin, Spacing, State, False, + DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, Self.WordWrap {$ENDIF}); + + if IsFocused and IsDefault then + begin + FCanvas.Pen.Color := clWindowFrame; + FCanvas.Brush.Color := clBtnFace; + DrawFocusRect(FCanvas.Handle, R); + end; + end + else + {$ENDIF} + begin + R := ClientRect; + + Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT; + if IsDown then Flags := Flags or DFCS_PUSHED; + if DrawItemStruct.itemState and ODS_DISABLED <> 0 then + Flags := Flags or DFCS_INACTIVE; + + { DrawFrameControl doesn't allow for drawing a button as the + default button, so it must be done here. } + if IsFocused or IsDefault then + begin + FCanvas.Pen.Color := clWindowFrame; + FCanvas.Pen.Width := 1; + FCanvas.Brush.Style := bsClear; + FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom); + + { DrawFrameControl must draw within this border } + InflateRect(R, -1, -1); + end; + + { DrawFrameControl does not draw a pressed button correctly } + if IsDown then + begin + FCanvas.Pen.Color := clBtnShadow; + FCanvas.Pen.Width := 1; + FCanvas.Brush.Color := clBtnFace; + FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom); + InflateRect(R, -1, -1); + end + else + DrawFrameControl(DrawItemStruct.hDC, R, DFC_BUTTON, Flags); + + if IsFocused then + begin + R := ClientRect; + InflateRect(R, -1, -1); + end; + + FCanvas.Font := Self.Font; + if IsDown then + OffsetRect(R, 1, 1); + + TButtonGlyph_Draw(Self, FCanvas, R, Point(0, 0), Caption, Layout, Margin, Spacing, State, + False, DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, Self.WordWrap {$ENDIF}); + + if IsFocused and IsDefault then + begin + R := ClientRect; + InflateRect(R, -4, -4); + FCanvas.Pen.Color := clWindowFrame; + FCanvas.Brush.Color := clBtnFace; + DrawFocusRect(FCanvas.Handle, R); + end; + end; + FCanvas.Handle := 0; + except + on E: EAbortPaint do + ; + else + raise; + end; +end; + +procedure TTntBitBtn.CMMouseEnter(var Message: TMessage); +begin + FMouseInControl := True; + inherited; +end; + +procedure TTntBitBtn.CMMouseLeave(var Message: TMessage); +begin + FMouseInControl := False; + inherited; +end; + +{$IFDEF COMPILER_10_UP} +type + TAccessButton = class(TButton{TNT-ALLOW TButton}); +{$ENDIF} + +procedure TTntBitBtn.ActionChange(Sender: TObject; CheckDefaults: Boolean); +{$IFDEF COMPILER_10_UP} +// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. +type + CallActionChange = procedure(Sender: TObject; CheckDefaults: Boolean) of object; +var + M: TMethod; +{$ENDIF} +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + {$IFNDEF COMPILER_10_UP} + inherited; + {$ELSE} + // call TButton.ActionChange (bypass TBitBtn.ActionChange) + M.Code := @TAccessButton.ActionChange; + M.Data := Self; + CallActionChange(M)(Sender, CheckDefaults); + // call Delphi2005's TBitBtn.ActionChange + if Sender is TCustomAction{TNT-ALLOW TCustomAction} then + with TCustomAction{TNT-ALLOW TCustomAction}(Sender) do + begin + { Copy image from action's imagelist } + if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and + (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then + CopyImage(ActionList.Images, ImageIndex); + end; + {$ENDIF} +end; + +function TTntBitBtn.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +end. diff --git a/Source/TntCheckLst.pas b/Source/TntCheckLst.pas new file mode 100644 index 0000000..9d1ae95 --- /dev/null +++ b/Source/TntCheckLst.pas @@ -0,0 +1,184 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntCheckLst; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Messages, Windows, Controls, StdCtrls, CheckLst, + TntClasses, TntControls, TntStdCtrls; + +type +{TNT-WARN TCheckListBox} + TTntCheckListBox = class(TCheckListBox{TNT-ALLOW TCheckListBox}, IWideCustomListControl) + private + FItems: TTntStrings; + FSaveItems: TTntStrings; + FSaveTopIndex: Integer; + FSaveItemIndex: Integer; + FSaved_ItemEnabled: array of Boolean; + FSaved_State: array of TCheckBoxState; + FSaved_Header: array of Boolean; + FOnData: TLBGetWideDataEvent; + procedure SetItems(const Value: TTntStrings); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure LBGetText(var Message: TMessage); message LB_GETTEXT; + procedure LBGetTextLen(var Message: TMessage); message LB_GETTEXTLEN; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property Items: TTntStrings read FItems write SetItems; + property OnData: TLBGetWideDataEvent read FOnData write FOnData; + end; + +implementation + +uses + SysUtils, Math, TntActnList; + +{ TTntCheckListBox } + +constructor TTntCheckListBox.Create(AOwner: TComponent); +begin + inherited; + FItems := TTntListBoxStrings.Create; + TTntListBoxStrings(FItems).ListBox := Self; +end; + +destructor TTntCheckListBox.Destroy; +begin + FreeAndNil(FItems); + inherited; +end; + +procedure TTntCheckListBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'LISTBOX'); +end; + +procedure TTntCheckListBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCheckListBox.CreateWnd; +var + i: integer; +begin + inherited; + TntListBox_AfterInherited_CreateWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); + if Length(FSaved_ItemEnabled) > 0 then begin + for i := 0 to Min(Items.Count - 1, High(FSaved_ItemEnabled)) do begin + ItemEnabled[i] := FSaved_ItemEnabled[i]; + State[i] := FSaved_State[i]; + Header[i] := FSaved_Header[i]; + end; + SetLength(FSaved_ItemEnabled, 0); + SetLength(FSaved_State, 0); + SetLength(FSaved_Header, 0); + end; +end; + +procedure TTntCheckListBox.DestroyWnd; +var + i: integer; +begin + SetLength(FSaved_ItemEnabled, Items.Count); + SetLength(FSaved_State, Items.Count); + SetLength(FSaved_Header, Items.Count); + for i := 0 to Items.Count - 1 do begin + FSaved_ItemEnabled[i] := ItemEnabled[i]; + FSaved_State[i] := State[i]; + FSaved_Header[i] := Header[i]; + end; + TntListBox_BeforeInherited_DestroyWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); + inherited; +end; + +procedure TTntCheckListBox.SetItems(const Value: TTntStrings); +begin + FItems.Assign(Value); +end; + +procedure TTntCheckListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); +begin + inherited; + if not Assigned(OnDrawItem) then + TntListBox_DrawItem_Text(Self, Items, Index, Rect); +end; + +function TTntCheckListBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCheckListBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCheckListBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCheckListBox.AddItem(const Item: WideString; AObject: TObject); +begin + TntListBox_AddItem(Items, Item, AObject); +end; + +procedure TTntCheckListBox.CopySelection(Destination: TCustomListControl); +begin + TntListBox_CopySelection(Self, Items, Destination); +end; + +procedure TTntCheckListBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCheckListBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntCheckListBox.LBGetText(var Message: TMessage); +begin + if not TntCustomListBox_LBGetText(Self, OnData, Message) then + inherited; +end; + +procedure TTntCheckListBox.LBGetTextLen(var Message: TMessage); +begin + if not TntCustomListBox_LBGetTextLen(Self, OnData, Message) then + inherited; +end; + +end. diff --git a/Source/TntClasses.pas b/Source/TntClasses.pas new file mode 100644 index 0000000..ada78fb --- /dev/null +++ b/Source/TntClasses.pas @@ -0,0 +1,1799 @@ + +{*****************************************************************************} +{ } +{ 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, TntSysUtils, + {$IFNDEF COMPILER_10_UP} + TntWideStrings, + {$ELSE} + WideStrings, + {$ENDIF} + ActiveX, Contnrs; + +{ Exception classes } + +type + EWideFileStreamError = class(WideException) + constructor Create(ResStringRec: PResStringRec; const FileName: WideString); + end; + EWideFCreateError = class(EWideFileStreamError); + EWideFOpenError = class(EWideFileStreamError); + +// ......... 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; + +{ EWideFileStreamError } + +constructor EWideFileStreamError.Create(ResStringRec: PResStringRec; + const FileName: WideString); +begin + inherited CreateResFmt(ResStringRec, [WideExpandFileName(FileName), + WideSysErrorMessage(GetLastError)]); +end; + +{ 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 EWideFCreateError.CreateFmt(SFCreateErrorEx, [WideExpandFileName(FileName), ErrorMessage]); + {$ELSE} + raise EWideFCreateError.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 EWideFOpenError.CreateFmt(SFOpenErrorEx, [WideExpandFileName(FileName), ErrorMessage]); + {$ELSE} + raise EWideFOpenError.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/Source/TntClipBrd.pas b/Source/TntClipBrd.pas new file mode 100644 index 0000000..cf2c16e --- /dev/null +++ b/Source/TntClipBrd.pas @@ -0,0 +1,86 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntClipBrd; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Windows, Clipbrd; + +type +{TNT-WARN TClipboard} + TTntClipboard = class(TClipboard{TNT-ALLOW TClipboard}) + private + function GetAsWideText: WideString; + procedure SetAsWideText(const Value: WideString); + public + property AsWideText: WideString read GetAsWideText write SetAsWideText; + property AsText: WideString read GetAsWideText write SetAsWideText; + end; + +{TNT-WARN Clipboard} +function TntClipboard: TTntClipboard; + +implementation + +{ TTntClipboard } + +function TTntClipboard.GetAsWideText: WideString; +var + Data: THandle; +begin + Open; + Data := GetClipboardData(CF_UNICODETEXT); + try + if Data <> 0 then + Result := PWideChar(GlobalLock(Data)) + else + Result := ''; + finally + if Data <> 0 then GlobalUnlock(Data); + Close; + end; + if (Data = 0) or (Result = '') then + Result := inherited AsText +end; + +procedure TTntClipboard.SetAsWideText(const Value: WideString); +begin + Open; + try + inherited AsText := Value; {Ensures ANSI compatiblity across platforms.} + SetBuffer(CF_UNICODETEXT, PWideChar(Value)^, (Length(Value) + 1) * SizeOf(WideChar)); + finally + Close; + end; +end; + +//------------------------------------------ + +var + GTntClipboard: TTntClipboard; + +function TntClipboard: TTntClipboard; +begin + if GTntClipboard = nil then + GTntClipboard := TTntClipboard.Create; + Result := GTntClipboard; +end; + +initialization + +finalization + GTntClipboard.Free; + +end. diff --git a/Source/TntComCtrls.pas b/Source/TntComCtrls.pas new file mode 100644 index 0000000..42bec4c --- /dev/null +++ b/Source/TntComCtrls.pas @@ -0,0 +1,5058 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntComCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: TTntCustomListView events - reintroduce ones that refer to ansi classes (ie. TListItem) } +{ TODO: Handle RichEdit CRLF emulation at the WndProc level. } +{ TODO: TTntCustomTreeView events - reintroduce ones that refer to ansi classes (ie. TTreeNode) } +{ TODO: THotKey, Tanimate, TCoolBar (TCoolBand) } +{ TODO: TToolBar: Unicode-enable TBN_GETBUTTONINFO/DoGetButton } +{ TODO: TToolBar: Unicode-enable handling of CN_DIALOGCHAR, WM_SYSCOMMAND, FindButtonFromAccel } + +uses + Classes, Controls, ListActns, Menus, ComCtrls, Messages, + Windows, CommCtrl, Contnrs, TntControls, TntClasses, Graphics, TntSysUtils; + +type + TTntCustomListView = class; + TTntListItems = class; + +{TNT-WARN TListColumn} + TTntListColumn = class(TListColumn{TNT-ALLOW TListColumn}) + private + FCaption: WideString; + procedure SetInheritedCaption(const Value: AnsiString); + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + end; + +{TNT-WARN TListColumns} + TTntListColumns = class(TListColumns{TNT-ALLOW TListColumns}) + private + function GetItem(Index: Integer): TTntListColumn; + procedure SetItem(Index: Integer; Value: TTntListColumn); + public + constructor Create(AOwner: TTntCustomListView); + function Add: TTntListColumn; + function Owner: TTntCustomListView; + property Items[Index: Integer]: TTntListColumn read GetItem write SetItem; default; + end; + +{TNT-WARN TListItem} + TTntListItem = class(TListItem{TNT-ALLOW TListItem}) + private + FCaption: WideString; + FSubItems: TTntStrings; + procedure SetInheritedCaption(const Value: AnsiString); + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + procedure SetSubItems(const Value: TTntStrings); + function GetListView: TTntCustomListView; + function GetTntOwner: TTntListItems; + public + constructor Create(AOwner: TListItems{TNT-ALLOW TListItems}); virtual; + destructor Destroy; override; + property Owner: TTntListItems read GetTntOwner; + property ListView: TTntCustomListView read GetListView; + procedure Assign(Source: TPersistent); override; + property Caption: WideString read GetCaption write SetCaption; + property SubItems: TTntStrings read FSubItems write SetSubItems; + end; + + TTntListItemsEnumerator = class + private + FIndex: Integer; + FListItems: TTntListItems; + public + constructor Create(AListItems: TTntListItems); + function GetCurrent: TTntListItem; + function MoveNext: Boolean; + property Current: TTntListItem read GetCurrent; + end; + +{TNT-WARN TListItems} + TTntListItems = class(TListItems{TNT-ALLOW TListItems}) + private + function GetItem(Index: Integer): TTntListItem; + procedure SetItem(Index: Integer; const Value: TTntListItem); + public + function Owner: TTntCustomListView; + property Item[Index: Integer]: TTntListItem read GetItem write SetItem; default; + function Add: TTntListItem; + function AddItem(Item: TTntListItem; Index: Integer = -1): TTntListItem; + function GetEnumerator: TTntListItemsEnumerator; + function Insert(Index: Integer): TTntListItem; + end; + + TTntLVEditedEvent = procedure(Sender: TObject; Item: TTntListItem; var S: WideString) of object; + TTntLVOwnerDataFindEvent = procedure(Sender: TObject; Find: TItemFind; + const FindString: WideString; const FindPosition: TPoint; FindData: Pointer; + StartIndex: Integer; Direction: TSearchDirection; Wrap: Boolean; + var Index: Integer) of object; + +{TNT-WARN TCustomListView} + _TntInternalCustomListView = class(TCustomListView{TNT-ALLOW TCustomListView}) + private + PWideFindString: PWideChar; + CurrentDispInfo: PLVDispInfoW; + OriginalDispInfoMask: Cardinal; + function OwnerDataFindW(Find: TItemFind; const FindString: WideString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; virtual; abstract; + function OwnerDataFetchW(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; virtual; abstract; + protected + function OwnerDataFind(Find: TItemFind; const FindString: AnsiString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; override; + function OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; override; + end; + + TTntCustomListView = class(_TntInternalCustomListView, IWideCustomListControl) + private + FEditHandle: THandle; + FEditInstance: Pointer; + FDefEditProc: Pointer; + FOnEdited: TTntLVEditedEvent; + FOnDataFind: TTntLVOwnerDataFindEvent; + procedure EditWndProcW(var Message: TMessage); + procedure BeginChangingWideItem; + procedure EndChangingWideItem; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + function GetListColumns: TTntListColumns; + procedure SetListColumns(const Value: TTntListColumns); + function ColumnFromIndex(Index: Integer): TTntListColumn; + function GetColumnFromTag(Tag: Integer): TTntListColumn; + function OwnerDataFindW(Find: TItemFind; const FindString: WideString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; override; + function OwnerDataFetchW(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; override; + function GetDropTarget: TTntListItem; + procedure SetDropTarget(const Value: TTntListItem); + function GetItemFocused: TTntListItem; + procedure SetItemFocused(const Value: TTntListItem); + function GetSelected: TTntListItem; + procedure SetSelected(const Value: TTntListItem); + function GetTopItem: TTntListItem; + private + FSavedItems: TObjectList; + FTestingForSortProc: Boolean; + FChangingWideItemCount: Integer; + FTempItem: TTntListItem; + function AreItemsStored: Boolean; + function GetItems: TTntListItems; + procedure SetItems(Value: TTntListItems); + procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; + function GetItemW(Value: TLVItemW): TTntListItem; + procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure WndProc(var Message: TMessage); override; + function OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; reintroduce; virtual; + function CreateListItem: TListItem{TNT-ALLOW TListItem}; override; + function CreateListItems: TListItems{TNT-ALLOW TListItems}; override; + property Items: TTntListItems read GetItems write SetItems stored AreItemsStored; + procedure Edit(const Item: TLVItem); override; + function OwnerDataFind(Find: TItemFind; const FindString: WideString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; reintroduce; virtual; + property Columns: TTntListColumns read GetListColumns write SetListColumns; + procedure DrawItem(Item: TListItem{TNT-ALLOW TListItem}; Rect: TRect; State: TOwnerDrawState); override; + property OnEdited: TTntLVEditedEvent read FOnEdited write FOnEdited; + property OnDataFind: TTntLVOwnerDataFindEvent read FOnDataFind write FOnDataFind; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Column[Index: Integer]: TTntListColumn read ColumnFromIndex; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + function FindCaption(StartIndex: Integer; Value: WideString; Partial, + Inclusive, Wrap: Boolean): TTntListItem; + function GetSearchString: WideString; + function StringWidth(S: WideString): Integer; + public + property DropTarget: TTntListItem read GetDropTarget write SetDropTarget; + property ItemFocused: TTntListItem read GetItemFocused write SetItemFocused; + property Selected: TTntListItem read GetSelected write SetSelected; + property TopItem: TTntListItem read GetTopItem; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TListView} + TTntListView = class(TTntCustomListView) + published + property Action; + property Align; + property AllocBy; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind default bkNone; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property BorderWidth; + property Checkboxes; + property Color; + property Columns; + property ColumnClick; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property FlatScrollBars; + property FullDrag; + property GridLines; + property HideSelection; + property HotTrack; + property HotTrackStyles; + property HoverTime; + property IconOptions; + property Items; + property LargeImages; + property MultiSelect; + property OwnerData; + property OwnerDraw; + property ReadOnly default False; + property RowSelect; + property ParentBiDiMode; + property ParentColor default False; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowColumnHeaders; + property ShowWorkAreas; + property ShowHint; + property SmallImages; + property SortType; + property StateImages; + property TabOrder; + property TabStop default True; + property ViewStyle; + property Visible; + property OnAdvancedCustomDraw; + property OnAdvancedCustomDrawItem; + property OnAdvancedCustomDrawSubItem; + property OnChange; + property OnChanging; + property OnClick; + property OnColumnClick; + property OnColumnDragged; + property OnColumnRightClick; + property OnCompare; + property OnContextPopup; + property OnCustomDraw; + property OnCustomDrawItem; + property OnCustomDrawSubItem; + property OnData; + property OnDataFind; + property OnDataHint; + property OnDataStateChange; + property OnDblClick; + property OnDeletion; + property OnDrawItem; + property OnEdited; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetImageIndex; + property OnGetSubItemImage; + property OnDragDrop; + property OnDragOver; + property OnInfoTip; + property OnInsert; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnResize; + property OnSelectItem; + property OnStartDock; + property OnStartDrag; + end; + +type +{TNT-WARN TToolButton} + TTntToolButton = class(TToolButton{TNT-ALLOW TToolButton}) + private + procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function IsCaptionStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + function GetMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; + procedure SetMenuItem(const Value: TMenuItem{TNT-ALLOW TMenuItem}); + protected + procedure DefineProperties(Filer: TFiler); override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetActionLinkClass: TControlActionLinkClass; override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property MenuItem: TMenuItem{TNT-ALLOW TMenuItem} read GetMenuItem write SetMenuItem; + end; + +type +{TNT-WARN TToolBar} + TTntToolBar = class(TToolBar{TNT-ALLOW TToolBar}) + private + FCaption: WideString; + procedure TBInsertButtonA(var Message: TMessage); message TB_INSERTBUTTONA; + procedure WMGetText(var Message: TWMGetText); message WM_GETTEXT; + procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH; + procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; + function GetMenu: TMainMenu{TNT-ALLOW TMainMenu}; + procedure SetMenu(const Value: TMainMenu{TNT-ALLOW TMainMenu}); + private + function GetCaption: WideString; + function GetHint: WideString; + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure SetCaption(const Value: WideString); + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetActionLinkClass: TControlActionLinkClass; override; + published + property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property Menu: TMainMenu{TNT-ALLOW TMainMenu} read GetMenu write SetMenu; + end; + +type +{TNT-WARN TCustomRichEdit} + TTntCustomRichEdit = class(TCustomRichEdit{TNT-ALLOW TCustomRichEdit}) + private + FRichEditStrings: TTntStrings; + FPrintingTextLength: Integer; + procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH; + procedure SetRichEditStrings(const Value: TTntStrings); + function GetWideSelText: WideString; + function GetText: WideString; + procedure SetWideSelText(const Value: WideString); + procedure SetText(const Value: WideString); + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + procedure SetRTFText(Flags: DWORD; const Value: AnsiString); + protected + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + function GetSelText: string{TNT-ALLOW string}; override; + function CharPosToGet(RawWin32CharPos: Integer): Integer; deprecated; // use EmulatedCharPos() + function CharPosToSet(EmulatedCharPos: Integer): Integer; deprecated; // use RawWin32CharPos() + function GetSelStart: Integer; reintroduce; virtual; + procedure SetSelStart(const Value: Integer); reintroduce; virtual; + function GetSelLength: Integer; reintroduce; virtual; + procedure SetSelLength(const Value: Integer); reintroduce; virtual; + function LineBreakStyle: TTntTextLineBreakStyle; + property Lines: TTntStrings read FRichEditStrings write SetRichEditStrings; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + // + function EmulatedCharPos(RawWin32CharPos: Integer): Integer; + function RawWin32CharPos(EmulatedCharPos: Integer): Integer; + // + procedure Print(const Caption: string{TNT-ALLOW string}); override; + property SelText: WideString read GetWideSelText write SetWideSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + function FindText(const SearchStr: WideString; StartPos, + Length: Integer; Options: TSearchTypes): Integer; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TRichEdit} + TTntRichEdit = class(TTntCustomRichEdit) + published + property Align; + property Alignment; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind default bkNone; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property BorderWidth; + property Color; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property HideScrollBars; + property ImeMode; + property ImeName; + property Constraints; + property Lines; + property MaxLength; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PlainText; + property PopupMenu; + property ReadOnly; + property ScrollBars; + property ShowHint; + property TabOrder; + property TabStop default True; + property Visible; + property WantTabs; + property WantReturns; + property WordWrap; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnProtectChange; + property OnResizeRequest; + property OnSaveClipboard; + property OnSelectionChange; + property OnStartDock; + property OnStartDrag; + end; + +type +{TNT-WARN TCustomTabControl} + TTntCustomTabControl = class(TCustomTabControl{TNT-ALLOW TCustomTabControl}) + private + FTabs: TTntStrings; + FSaveTabIndex: Integer; + FSaveTabs: TTntStrings; + function GetTabs: TTntStrings; + procedure SetTabs(const Value: TTntStrings); + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + property Tabs: TTntStrings read GetTabs write SetTabs; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TTabControl} + TTntTabControl = class(TTntCustomTabControl) + public + property DisplayRect; + published + property Align; + property Anchors; + property BiDiMode; + property Constraints; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HotTrack; + property Images; + property MultiLine; + property MultiSelect; + property OwnerDraw; + property ParentBiDiMode; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property RaggedRight; + property ScrollOpposite; + property ShowHint; + property Style; + property TabHeight; + property TabOrder; + property TabPosition; + property Tabs; + property TabIndex; // must be after Tabs + property TabStop; + property TabWidth; + property Visible; + property OnChange; + property OnChanging; + property OnContextPopup; + property OnDockDrop; + property OnDockOver; + property OnDragDrop; + property OnDragOver; + property OnDrawTab; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetImageIndex; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnResize; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +type +{TNT-WARN TTabSheet} + TTntTabSheet = class(TTabSheet{TNT-ALLOW TTabSheet}) + private + Force_Inherited_WMSETTEXT: Boolean; + function IsCaptionStored: Boolean; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TPageControl} + TTntPageControl = class(TPageControl{TNT-ALLOW TPageControl}) + private + FNewDockSheet: TTntTabSheet; + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure CMDockNotification(var Message: TCMDockNotification); message CM_DOCKNOTIFICATION; + procedure CMDockClient(var Message: TCMDockClient); message CM_DOCKCLIENT; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure WndProc(var Message: TMessage); override; + procedure DoAddDockClient(Client: TControl; const ARect: TRect); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TTrackBar} + TTntTrackBar = class(TTrackBar{TNT-ALLOW TTrackBar}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TProgressBar} + TTntProgressBar = class(TProgressBar{TNT-ALLOW TProgressBar}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomUpDown} + TTntCustomUpDown = class(TCustomUpDown{TNT-ALLOW TCustomUpDown}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TUpDown} + TTntUpDown = class(TTntCustomUpDown) + published + property AlignButton; + property Anchors; + property Associate; + property ArrowKeys; + property Enabled; + property Hint; + property Min; + property Max; + property Increment; + property Constraints; + property Orientation; + property ParentShowHint; + property PopupMenu; + property Position; + property ShowHint; + property TabOrder; + property TabStop; + property Thousands; + property Visible; + property Wrap; + property OnChanging; + property OnChangingEx; + property OnContextPopup; + property OnClick; + property OnEnter; + property OnExit; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + end; + +{TNT-WARN TDateTimePicker} + TTntDateTimePicker = class(TDateTimePicker{TNT-ALLOW TDateTimePicker}) + private + FHadFirstMouseClick: Boolean; + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TMonthCalendar} + TTntMonthCalendar = class(TMonthCalendar{TNT-ALLOW TMonthCalendar}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function GetDate: TDate; + procedure SetDate(const Value: TDate); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + procedure ForceGetMonthInfo; + published + property Date: TDate read GetDate write SetDate; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TPageScroller} + TTntPageScroller = class(TPageScroller{TNT-ALLOW TPageScroller}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +type +{TNT-WARN TStatusPanel} + TTntStatusPanel = class(TStatusPanel{TNT-ALLOW TStatusPanel}) + private + FText: WideString; + function GetText: Widestring; + procedure SetText(const Value: Widestring); + procedure SetInheritedText(const Value: AnsiString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Text: Widestring read GetText write SetText; + end; + +{TNT-WARN TStatusPanels} + TTntStatusPanels = class(TStatusPanels{TNT-ALLOW TStatusPanels}) + private + function GetItem(Index: Integer): TTntStatusPanel; + procedure SetItem(Index: Integer; Value: TTntStatusPanel); + public + function Add: TTntStatusPanel; + function AddItem(Item: TTntStatusPanel; Index: Integer): TTntStatusPanel; + function Insert(Index: Integer): TTntStatusPanel; + property Items[Index: Integer]: TTntStatusPanel read GetItem write SetItem; default; + end; + +{TNT-WARN TCustomStatusBar} + TTntCustomStatusBar = class(TCustomStatusBar{TNT-ALLOW TCustomStatusBar}) + private + FSimpleText: WideString; + function GetSimpleText: WideString; + procedure SetSimpleText(const Value: WideString); + procedure SetInheritedSimpleText(const Value: AnsiString); + function SyncLeadingTabs(const WideVal: WideString; const AnsiVal: AnsiString): WideString; + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH; + function GetPanels: TTntStatusPanels; + procedure SetPanels(const Value: TTntStatusPanels); + protected + procedure DefineProperties(Filer: TFiler); override; + function CreatePanels: TStatusPanels{TNT-ALLOW TStatusPanels}; override; + function GetPanelClass: TStatusPanelClass; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure WndProc(var Msg: TMessage); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + function ExecuteAction(Action: TBasicAction): Boolean; override; + property Panels: TTntStatusPanels read GetPanels write SetPanels; + property SimpleText: WideString read GetSimpleText write SetSimpleText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TStatusBar} + TTntStatusBar = class(TTntCustomStatusBar) + private + function GetOnDrawPanel: TDrawPanelEvent; + procedure SetOnDrawPanel(const Value: TDrawPanelEvent); + published + property Action; + property AutoHint default False; + property Align default alBottom; + property Anchors; + property BiDiMode; + property BorderWidth; + property Color default clBtnFace; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font stored IsFontStored; + property Constraints; + property Panels; + property ParentBiDiMode; + property ParentColor default False; + property ParentFont default False; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property SimplePanel {$IFDEF COMPILER_7_UP} default False {$ENDIF}; + property SimpleText; + property SizeGrip default True; + property UseSystemFont default True; + property Visible; + property OnClick; + property OnContextPopup; + property OnCreatePanelClass; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnHint; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + // Required for backwards compatibility with the old event signature + property OnDrawPanel: TDrawPanelEvent read GetOnDrawPanel write SetOnDrawPanel; + property OnResize; + property OnStartDock; + property OnStartDrag; + end; + +type + TTntTreeNodes = class; + TTntCustomTreeView = class; + +{TNT-WARN TTreeNode} + TTntTreeNode = class(TTreeNode{TNT-ALLOW TTreeNode}) + private + FText: WideString; + procedure SetText(const Value: WideString); + procedure SetInheritedText(const Value: AnsiString); + function GetText: WideString; + function GetItem(Index: Integer): TTntTreeNode; + function GetNodeOwner: TTntTreeNodes; + function GetParent: TTntTreeNode; + function GetTreeView: TTntCustomTreeView; + procedure SetItem(Index: Integer; const Value: TTntTreeNode); + function IsEqual(Node: TTntTreeNode): Boolean; + procedure ReadData(Stream: TStream; Info: PNodeInfo); + procedure WriteData(Stream: TStream; Info: PNodeInfo); + public + procedure Assign(Source: TPersistent); override; + function getFirstChild: TTntTreeNode; {GetFirstChild conflicts with C++ macro} + function GetLastChild: TTntTreeNode; + function GetNext: TTntTreeNode; + function GetNextChild(Value: TTntTreeNode): TTntTreeNode; + function getNextSibling: TTntTreeNode; {GetNextSibling conflicts with C++ macro} + function GetNextVisible: TTntTreeNode; + function GetPrev: TTntTreeNode; + function GetPrevChild(Value: TTntTreeNode): TTntTreeNode; + function getPrevSibling: TTntTreeNode; {GetPrevSibling conflicts with a C++ macro} + function GetPrevVisible: TTntTreeNode; + property Item[Index: Integer]: TTntTreeNode read GetItem write SetItem; default; + property Owner: TTntTreeNodes read GetNodeOwner; + property Parent: TTntTreeNode read GetParent; + property Text: WideString read GetText write SetText; + property TreeView: TTntCustomTreeView read GetTreeView; + end; + + TTntTreeNodeClass = class of TTntTreeNode; + + TTntTreeNodesEnumerator = class + private + FIndex: Integer; + FTreeNodes: TTntTreeNodes; + public + constructor Create(ATreeNodes: TTntTreeNodes); + function GetCurrent: TTntTreeNode; + function MoveNext: Boolean; + property Current: TTntTreeNode read GetCurrent; + end; + +{TNT-WARN TTreeNodes} + TTntTreeNodes = class(TTreeNodes{TNT-ALLOW TTreeNodes}) + private + function GetNodeFromIndex(Index: Integer): TTntTreeNode; + function GetNodesOwner: TTntCustomTreeView; + procedure ClearCache; + procedure ReadData(Stream: TStream); + procedure WriteData(Stream: TStream); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + function Add(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; + function AddChild(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; + function AddChildFirst(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; + function AddChildObject(Parent: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function AddChildObjectFirst(Parent: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function AddFirst(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; + function AddObject(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function AddObjectFirst(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function Insert(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; + function InsertObject(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function InsertNode(Node, Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; + function AddNode(Node, Relative: TTntTreeNode; const S: WideString; + Ptr: Pointer; Method: TNodeAttachMode): TTntTreeNode; + public + function GetFirstNode: TTntTreeNode; + function GetEnumerator: TTntTreeNodesEnumerator; + function GetNode(ItemId: HTreeItem): TTntTreeNode; + property Item[Index: Integer]: TTntTreeNode read GetNodeFromIndex; default; + property Owner: TTntCustomTreeView read GetNodesOwner; + end; + + TTntTVEditedEvent = procedure(Sender: TObject; Node: TTntTreeNode; var S: WideString) of object; + +{TNT-WARN TCustomTreeView} + _TntInternalCustomTreeView = class(TCustomTreeView{TNT-ALLOW TCustomTreeView}) + private + function Wide_FindNextToSelect: TTntTreeNode; virtual; abstract; + function Inherited_FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; + public + function FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; override; + end; + + TTntCustomTreeView = class(_TntInternalCustomTreeView) + private + FSavedNodeText: TTntStrings; + FSavedSortType: TSortType; + FOnEdited: TTntTVEditedEvent; + FTestingForSortProc: Boolean; + FEditHandle: THandle; + FEditInstance: Pointer; + FDefEditProc: Pointer; + function GetTreeNodes: TTntTreeNodes; + procedure SetTreeNodes(const Value: TTntTreeNodes); + procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; + procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY; + function GetNodeFromItem(const Item: TTVItem): TTntTreeNode; + procedure EditWndProcW(var Message: TMessage); + function Wide_FindNextToSelect: TTntTreeNode; override; + function GetDropTarget: TTntTreeNode; + function GetSelected: TTntTreeNode; + function GetSelection(Index: Integer): TTntTreeNode; + function GetTopItem: TTntTreeNode; + procedure SetDropTarget(const Value: TTntTreeNode); + procedure SetSelected(const Value: TTntTreeNode); + procedure SetTopItem(const Value: TTntTreeNode); + function GetHint: WideString; + function IsHintStored: Boolean; + procedure SetHint(const Value: WideString); + protected + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure DefineProperties(Filer: TFiler); override; + procedure WndProc(var Message: TMessage); override; + procedure Edit(const Item: TTVItem); override; + function CreateNode: TTreeNode{TNT-ALLOW TTreeNode}; override; + function CreateNodes: TTreeNodes{TNT-ALLOW TTreeNodes}; override; + property Items: TTntTreeNodes read GetTreeNodes write SetTreeNodes; + property OnEdited: TTntTVEditedEvent read FOnEdited write FOnEdited; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure LoadFromFile(const FileName: WideString); + procedure LoadFromStream(Stream: TStream); + procedure SaveToFile(const FileName: WideString); + procedure SaveToStream(Stream: TStream); + function GetNodeAt(X, Y: Integer): TTntTreeNode; + property DropTarget: TTntTreeNode read GetDropTarget write SetDropTarget; + property Selected: TTntTreeNode read GetSelected write SetSelected; + property TopItem: TTntTreeNode read GetTopItem write SetTopItem; + property Selections[Index: Integer]: TTntTreeNode read GetSelection; + function GetSelections(AList: TList): TTntTreeNode; + function FindNextToSelect: TTntTreeNode; reintroduce; virtual; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TTreeView} + TTntTreeView = class(TTntCustomTreeView) + published + property Align; + property Anchors; + property AutoExpand; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind default bkNone; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property BorderWidth; + property ChangeDelay; + property Color; + property Ctl3D; + property Constraints; + property DragKind; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property HotTrack; + property Images; + property Indent; + property MultiSelect; + property MultiSelectStyle; + property ParentBiDiMode; + property ParentColor default False; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly; + property RightClickSelect; + property RowSelect; + property ShowButtons; + property ShowHint; + property ShowLines; + property ShowRoot; + property SortType; + property StateImages; + property TabOrder; + property TabStop default True; + property ToolTips; + property Visible; + property OnAddition; + property OnAdvancedCustomDraw; + property OnAdvancedCustomDrawItem; + property OnChange; + property OnChanging; + property OnClick; + property OnCollapsed; + property OnCollapsing; + property OnCompare; + property OnContextPopup; + property OnCreateNodeClass; + property OnCustomDraw; + property OnCustomDrawItem; + property OnDblClick; + property OnDeletion; + property OnDragDrop; + property OnDragOver; + property OnEdited; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnExpanding; + property OnExpanded; + property OnGetImageIndex; + property OnGetSelectedIndex; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + { Items must be published after OnGetImageIndex and OnGetSelectedIndex } + property Items; + end; + +implementation + +uses + Forms, SysUtils, TntGraphics, ImgList, TntSystem, TntStdCtrls, StdCtrls, + RichEdit, ActiveIMM_TLB, TntForms, ComStrs, TntMenus, + TntActnList, TntStdActns, TntWindows, + {$IFNDEF COMPILER_10_UP} + TntWideStrings, + {$ELSE} + WideStrings, + {$ENDIF} + {$IFDEF COMPILER_9_UP} WideStrUtils {$ELSE} TntWideStrUtils {$ENDIF}; + +procedure CreateUnicodeHandle_ComCtl(Control: TWinControl; const Params: TCreateParams; + const SubClass: WideString); +begin + Assert(SubClass <> '', 'TNT Internal Error: Only call CreateUnicodeHandle_ComCtl for Common Controls.'); + CreateUnicodeHandle(Control, Params, SubClass); + if Win32PlatformIsUnicode then + SendMessageW(Control.Handle, CCM_SETUNICODEFORMAT, Integer(True), 0); +end; + +{ TTntListColumn } + +procedure TTntListColumn.Assign(Source: TPersistent); +begin + inherited; + if Source is TTntListColumn then + Caption := TTntListColumn(Source).Caption + else if Source is TListColumn{TNT-ALLOW TListColumn} then + FCaption := TListColumn{TNT-ALLOW TListColumn}(Source).Caption; +end; + +procedure TTntListColumn.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntListColumn.SetInheritedCaption(const Value: AnsiString); +begin + inherited Caption := Value; +end; + +function TTntListColumn.GetCaption: WideString; +begin + Result := GetSyncedWideString(FCaption, inherited Caption); +end; + +procedure TTntListColumn.SetCaption(const Value: WideString); +begin + SetSyncedWideString(Value, FCaption, inherited Caption, SetInheritedCaption); +end; + +{ TTntListColumns } + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackCollection = class(TPersistent) + protected + FItemClass: TCollectionItemClass; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackCollection = class(TPersistent) + protected + FItemClass: TCollectionItemClass; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackCollection = class(TPersistent) + protected + FItemClass: TCollectionItemClass; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackCollection = class(TPersistent) + protected + FItemClass: TCollectionItemClass; + end; +{$ENDIF} + +constructor TTntListColumns.Create(AOwner: TTntCustomListView); +begin + inherited Create(AOwner); + Assert(THackCollection(Self).FItemClass = Self.ItemClass, 'Internal Error in TTntListColumns.Create().'); + THackCollection(Self).FItemClass := TTntListColumn +end; + +function TTntListColumns.Owner: TTntCustomListView; +begin + Result := inherited Owner as TTntCustomListView; +end; + +function TTntListColumns.Add: TTntListColumn; +begin + Result := (inherited Add) as TTntListColumn; +end; + +function TTntListColumns.GetItem(Index: Integer): TTntListColumn; +begin + Result := inherited Items[Index] as TTntListColumn; +end; + +procedure TTntListColumns.SetItem(Index: Integer; Value: TTntListColumn); +begin + inherited SetItem(Index, Value); +end; + +{ TWideSubItems } +type + TWideSubItems = class(TTntStringList) + private + FIgnoreInherited: Boolean; + FInheritedOwner: TListItem{TNT-ALLOW TListItem}; + FOwner: TTntListItem; + protected + procedure Put(Index: Integer; const S: WideString); override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + procedure Insert(Index: Integer; const S: WideString); override; + function AddObject(const S: WideString; AObject: TObject): Integer; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + public + constructor Create(AOwner: TTntListItem); + end; + +constructor TWideSubItems.Create(AOwner: TTntListItem); +begin + inherited Create; + FInheritedOwner := AOwner; + FOwner := AOwner; +end; + +function TWideSubItems.AddObject(const S: WideString; AObject: TObject): Integer; +begin + FOwner.ListView.BeginChangingWideItem; + try + Result := inherited AddObject(S, AObject); + if (not FIgnoreInherited) then + FInheritedOwner.SubItems.AddObject(S, AObject); + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +procedure TWideSubItems.Clear; +begin + FOwner.ListView.BeginChangingWideItem; + try + inherited; + if (not FIgnoreInherited) then + FInheritedOwner.SubItems.Clear; + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +procedure TWideSubItems.Delete(Index: Integer); +begin + FOwner.ListView.BeginChangingWideItem; + try + inherited; + if (not FIgnoreInherited) then + FInheritedOwner.SubItems.Delete(Index); + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +procedure TWideSubItems.Insert(Index: Integer; const S: WideString); +begin + FOwner.ListView.BeginChangingWideItem; + try + inherited; + if (not FIgnoreInherited) then + FInheritedOwner.SubItems.Insert(Index, S); + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +procedure TWideSubItems.Put(Index: Integer; const S: WideString); +begin + FOwner.ListView.BeginChangingWideItem; + try + inherited; + if (not FIgnoreInherited) then + FInheritedOwner.SubItems[Index] := S; + finally + FOwner.ListView.EndChangingWideItem; + end; +end; + +function TWideSubItems.GetObject(Index: Integer): TObject; +begin + Result := FInheritedOwner.SubItems.Objects[Index]; +end; + +procedure TWideSubItems.PutObject(Index: Integer; AObject: TObject); +begin + FInheritedOwner.SubItems.Objects[Index] := AObject; +end; + +type TAccessStrings = class(TStrings{TNT-ALLOW TStrings}); + +procedure TWideSubItems.SetUpdateState(Updating: Boolean); +begin + inherited; + TAccessStrings(FInheritedOwner.SubItems).SetUpdateState(Updating); +end; + +{ TTntListItem } + +constructor TTntListItem.Create(AOwner: TListItems{TNT-ALLOW TListItems}); +begin + inherited Create(AOwner); + FSubItems := TWideSubItems.Create(Self); +end; + +destructor TTntListItem.Destroy; +begin + inherited; + FreeAndNil(FSubItems); +end; + +function TTntListItem.GetCaption: WideString; +begin + Result := GetSyncedWideString(FCaption, inherited Caption); +end; + +procedure TTntListItem.SetInheritedCaption(const Value: AnsiString); +begin + inherited Caption := Value; +end; + +procedure TTntListItem.SetCaption(const Value: WideString); +begin + ListView.BeginChangingWideItem; + try + SetSyncedWideString(Value, FCaption, inherited Caption, SetInheritedCaption); + finally + ListView.EndChangingWideItem; + end; +end; + +procedure TTntListItem.Assign(Source: TPersistent); +begin + if Source is TTntListItem then + with Source as TTntListItem do + begin + Self.Caption := Caption; + Self.Data := Data; + Self.ImageIndex := ImageIndex; + Self.Indent := Indent; + Self.OverlayIndex := OverlayIndex; + Self.StateIndex := StateIndex; + Self.SubItems := SubItems; + Self.Checked := Checked; + end + else inherited Assign(Source); +end; + +procedure TTntListItem.SetSubItems(const Value: TTntStrings); +begin + if Value <> nil then + FSubItems.Assign(Value); +end; + +function TTntListItem.GetTntOwner: TTntListItems; +begin + Result := ListView.Items; +end; + +function TTntListItem.GetListView: TTntCustomListView; +begin + Result := ((inherited Owner).Owner as TTntCustomListView); +end; + +{ TTntListItemsEnumerator } + +constructor TTntListItemsEnumerator.Create(AListItems: TTntListItems); +begin + inherited Create; + FIndex := -1; + FListItems := AListItems; +end; + +function TTntListItemsEnumerator.GetCurrent: TTntListItem; +begin + Result := FListItems[FIndex]; +end; + +function TTntListItemsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FListItems.Count - 1; + if Result then + Inc(FIndex); +end; + +{ TTntListItems } + +function TTntListItems.Add: TTntListItem; +begin + Result := (inherited Add) as TTntListItem; +end; + +function TTntListItems.AddItem(Item: TTntListItem; Index: Integer): TTntListItem; +begin + Result := (inherited AddItem(Item, Index)) as TTntListItem; +end; + +function TTntListItems.Insert(Index: Integer): TTntListItem; +begin + Result := (inherited Insert(Index)) as TTntListItem; +end; + +function TTntListItems.GetItem(Index: Integer): TTntListItem; +begin + Result := (inherited Item[Index]) as TTntListItem; +end; + +function TTntListItems.Owner: TTntCustomListView; +begin + Result := (inherited Owner) as TTntCustomListView; +end; + +procedure TTntListItems.SetItem(Index: Integer; const Value: TTntListItem); +begin + inherited Item[Index] := Value; +end; + +function TTntListItems.GetEnumerator: TTntListItemsEnumerator; +begin + Result := TTntListItemsEnumerator.Create(Self); +end; + +{ TSavedListItem } +type + TSavedListItem = class + FCaption: WideString; + FSubItems: TTntStrings; + constructor Create; + destructor Destroy; override; + end; + +constructor TSavedListItem.Create; +begin + inherited; + FSubItems := TTntStringList.Create; +end; + +destructor TSavedListItem.Destroy; +begin + FSubItems.Free; + inherited; +end; + +{ _TntInternalCustomListView } + +function _TntInternalCustomListView.OwnerDataFind(Find: TItemFind; + const FindString: AnsiString; const FindPosition: TPoint; + FindData: Pointer; StartIndex: Integer; Direction: TSearchDirection; + Wrap: Boolean): Integer; +var + WideFindString: WideString; +begin + if Assigned(PWideFindString) then + WideFindString := PWideFindString + else + WideFindString := FindString; + Result := OwnerDataFindW(Find, WideFindString, FindPosition, FindData, StartIndex, Direction, Wrap); +end; + +function _TntInternalCustomListView.OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; + Request: TItemRequest): Boolean; +begin + if (CurrentDispInfo <> nil) + and (OriginalDispInfoMask and LVIF_TEXT <> 0) then begin + (Item as TTntListItem).FCaption := CurrentDispInfo.item.pszText + end; + (Item as TTntListItem).FSubItems.Clear; + Result := OwnerDataFetchW(Item, Request); +end; + +{ TTntCustomListView } + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackCustomListView = class(TCustomMultiSelectListControl) + protected + FxxxCanvas: TCanvas; + FxxxBorderStyle: TBorderStyle; + FxxxViewStyle: TViewStyle; + FxxxReadOnly: Boolean; + FxxxLargeImages: TCustomImageList; + FxxxSmallImages: TCustomImageList; + FxxxStateImages: TCustomImageList; + FxxxDragImage: TDragImageList; + FxxxMultiSelect: Boolean; + FxxxSortType: TSortType; + FxxxColumnClick: Boolean; + FxxxShowColumnHeaders: Boolean; + FxxxListItems: TListItems{TNT-ALLOW TListItems}; + FxxxClicked: Boolean; + FxxxRClicked: Boolean; + FxxxIconOptions: TIconOptions; + FxxxHideSelection: Boolean; + FListColumns: TListColumns{TNT-ALLOW TListColumns}; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackCustomListView = class(TCustomMultiSelectListControl) + protected + FxxxCanvas: TCanvas; + FxxxBorderStyle: TBorderStyle; + FxxxViewStyle: TViewStyle; + FxxxReadOnly: Boolean; + FxxxLargeImages: TCustomImageList; + FxxxSmallImages: TCustomImageList; + FxxxStateImages: TCustomImageList; + FxxxDragImage: TDragImageList; + FxxxMultiSelect: Boolean; + FxxxSortType: TSortType; + FxxxColumnClick: Boolean; + FxxxShowColumnHeaders: Boolean; + FxxxListItems: TListItems{TNT-ALLOW TListItems}; + FxxxClicked: Boolean; + FxxxRClicked: Boolean; + FxxxIconOptions: TIconOptions; + FxxxHideSelection: Boolean; + FListColumns: TListColumns{TNT-ALLOW TListColumns}; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackCustomListView = class(TCustomMultiSelectListControl) + protected + FxxxCanvas: TCanvas; + FxxxBorderStyle: TBorderStyle; + FxxxViewStyle: TViewStyle; + FxxxReadOnly: Boolean; + FxxxLargeImages: TCustomImageList; + FxxxSmallImages: TCustomImageList; + FxxxStateImages: TCustomImageList; + FxxxDragImage: TDragImageList; + FxxxMultiSelect: Boolean; + FxxxSortType: TSortType; + FxxxColumnClick: Boolean; + FxxxShowColumnHeaders: Boolean; + FxxxListItems: TListItems{TNT-ALLOW TListItems}; + FxxxClicked: Boolean; + FxxxRClicked: Boolean; + FxxxIconOptions: TIconOptions; + FxxxHideSelection: Boolean; + FListColumns: TListColumns{TNT-ALLOW TListColumns}; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackCustomListView = class(TCustomMultiSelectListControl) + protected + FxxxCanvas: TCanvas; + FxxxBorderStyle: TBorderStyle; + FxxxViewStyle: TViewStyle; + FxxxReadOnly: Boolean; + FxxxLargeImages: TCustomImageList; + FxxxSaveSelectedIndex: Integer; + FxxxSmallImages: TCustomImageList; + FxxxStateImages: TCustomImageList; + FxxxDragImage: TDragImageList; + FxxxMultiSelect: Boolean; + FxxxSortType: TSortType; + FxxxColumnClick: Boolean; + FxxxShowColumnHeaders: Boolean; + FxxxListItems: TListItems{TNT-ALLOW TListItems}; + FxxxClicked: Boolean; + FxxxRClicked: Boolean; + FxxxIconOptions: TIconOptions; + FxxxHideSelection: Boolean; + FListColumns: TListColumns{TNT-ALLOW TListColumns}; + end; +{$ENDIF} + +var + ComCtrls_DefaultListViewSort: TLVCompare = nil; + +constructor TTntCustomListView.Create(AOwner: TComponent); +begin + inherited; + FEditInstance := Classes.MakeObjectInstance(EditWndProcW); + // create list columns + Assert(THackCustomListView(Self).FListColumns = inherited Columns, 'Internal Error in TTntCustomListView.Create().'); + FreeAndNil(THackCustomListView(Self).FListColumns); + THackCustomListView(Self).FListColumns := TTntListColumns.Create(Self); +end; + +destructor TTntCustomListView.Destroy; +begin + inherited; + Classes.FreeObjectInstance(FEditInstance); + FreeAndNil(FSavedItems); +end; + +procedure TTntCustomListView.CreateWindowHandle(const Params: TCreateParams); + + procedure Capture_ComCtrls_DefaultListViewSort; + begin + FTestingForSortProc := True; + try + AlphaSort; + finally + FTestingForSortProc := False; + end; + end; + +var + Column: TLVColumn; +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_LISTVIEW); + if (Win32PlatformIsUnicode) then begin + if not Assigned(ComCtrls_DefaultListViewSort) then + Capture_ComCtrls_DefaultListViewSort; + // the only way I could get editing to work is after a column had been inserted + Column.mask := 0; + ListView_InsertColumn(Handle, 0, Column); + ListView_DeleteColumn(Handle, 0); + end; +end; + +procedure TTntCustomListView.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomListView.CreateWnd; +begin + inherited; + FreeAndNil(FSavedItems); +end; + +procedure TTntCustomListView.DestroyWnd; +var + i: integer; + FSavedItem: TSavedListItem; + Item: TTntListItem; +begin + if (not (csDestroying in ComponentState)) and (not OwnerData) then begin + FreeAndNil(FSavedItems); // fixes a bug on Windows 95. + FSavedItems := TObjectList.Create(True); + for i := 0 to Items.Count - 1 do begin + FSavedItem := TSavedListItem.Create; + Item := Items[i]; + FSavedItem.FCaption := Item.FCaption; + FSavedItem.FSubItems.Assign(Item.FSubItems); + FSavedItems.Add(FSavedItem) + end; + end; + inherited; +end; + +function TTntCustomListView.GetDropTarget: TTntListItem; +begin + Result := inherited DropTarget as TTntListItem; +end; + +procedure TTntCustomListView.SetDropTarget(const Value: TTntListItem); +begin + inherited DropTarget := Value; +end; + +function TTntCustomListView.GetItemFocused: TTntListItem; +begin + Result := inherited ItemFocused as TTntListItem; +end; + +procedure TTntCustomListView.SetItemFocused(const Value: TTntListItem); +begin + inherited ItemFocused := Value; +end; + +function TTntCustomListView.GetSelected: TTntListItem; +begin + Result := inherited Selected as TTntListItem; +end; + +procedure TTntCustomListView.SetSelected(const Value: TTntListItem); +begin + inherited Selected := Value; +end; + +function TTntCustomListView.GetTopItem: TTntListItem; +begin + Result := inherited TopItem as TTntListItem; +end; + +function TTntCustomListView.GetListColumns: TTntListColumns; +begin + Result := inherited Columns as TTntListColumns; +end; + +procedure TTntCustomListView.SetListColumns(const Value: TTntListColumns); +begin + inherited Columns := Value; +end; + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackListColumn = class(TCollectionItem) + protected + FxxxAlignment: TAlignment; + FxxxAutoSize: Boolean; + FxxxCaption: AnsiString; + FxxxMaxWidth: TWidth; + FxxxMinWidth: TWidth; + FxxxImageIndex: TImageIndex; + FxxxPrivateWidth: TWidth; + FxxxWidth: TWidth; + FOrderTag: Integer; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackListColumn = class(TCollectionItem) + protected + FxxxAlignment: TAlignment; + FxxxAutoSize: Boolean; + FxxxCaption: AnsiString; + FxxxMaxWidth: TWidth; + FxxxMinWidth: TWidth; + FxxxImageIndex: TImageIndex; + FxxxPrivateWidth: TWidth; + FxxxWidth: TWidth; + FOrderTag: Integer; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackListColumn = class(TCollectionItem) + protected + FxxxxxxxxAlignment: TAlignment; + FxxxxAutoSize: Boolean; + FxxxxCaption: AnsiString; + FxxxxMaxWidth: TWidth; + FxxxxMinWidth: TWidth; + FxxxxImageIndex: TImageIndex; + FxxxxPrivateWidth: TWidth; + FxxxxWidth: TWidth; + FOrderTag: Integer; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackListColumn = class(TCollectionItem) + protected + FxxxxxxxxAlignment: TAlignment; + FxxxxAutoSize: Boolean; + FxxxxCaption: AnsiString; + FxxxxMaxWidth: TWidth; + FxxxxMinWidth: TWidth; + FxxxxImageIndex: TImageIndex; + FxxxxPrivateWidth: TWidth; + FxxxxWidth: TWidth; + FOrderTag: Integer; + end; +{$ENDIF} + +function TTntCustomListView.GetColumnFromTag(Tag: Integer): TTntListColumn; +var + I: Integer; +begin + for I := 0 to Columns.Count - 1 do + begin + Result := Columns[I]; + if THackListColumn(Result).FOrderTag = Tag then Exit; + end; + Result := nil; +end; + +function TTntCustomListView.ColumnFromIndex(Index: Integer): TTntListColumn; +begin + Result := inherited Column[Index] as TTntListColumn; +end; + +function TTntCustomListView.AreItemsStored: Boolean; +begin + if Assigned(Action) then + begin + if Action is TCustomListAction{TNT-ALLOW TCustomListAction} then + Result := False + else + Result := True; + end + else + Result := not OwnerData; +end; + +function TTntCustomListView.GetItems: TTntListItems; +begin + Result := inherited Items as TTntListItems; +end; + +procedure TTntCustomListView.SetItems(Value: TTntListItems); +begin + inherited Items := Value; +end; + +type TTntListItemClass = class of TTntListItem; + +function TTntCustomListView.CreateListItem: TListItem{TNT-ALLOW TListItem}; +var + LClass: TClass; + TntLClass: TTntListItemClass; +begin + LClass := TTntListItem; + if Assigned(OnCreateItemClass) then + OnCreateItemClass(Self, TListItemClass(LClass)); + if not LClass.InheritsFrom(TTntListItem) then + raise ETntInternalError.Create('Internal Error: OnCreateItemClass.ItemClass must inherit from TTntListItem.'); + TntLClass := TTntListItemClass(LClass); + Result := TntLClass.Create(inherited Items); + if FTempItem = nil then + FTempItem := Result as TTntListItem; { In Delphi 5/6/7/9/10, the first item created is the temp item } + { TODO: Verify that D11 creates a temp item in its constructor. } +end; + +function TTntCustomListView.CreateListItems: TListItems{TNT-ALLOW TListItems}; +begin + Result := TTntListItems.Create(Self); +end; + +function TTntCustomListView.GetItemW(Value: TLVItemW): TTntListItem; +begin + with Value do begin + if (mask and LVIF_PARAM) <> 0 then + Result := TListItem{TNT-ALLOW TListItem}(lParam) as TTntListItem + else if iItem >= 0 then + Result := Items[IItem] + else if OwnerData then + Result := FTempItem + else + Result := nil + end; +end; + +function TTntCustomListView.OwnerDataFetchW(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; +begin + Result := OwnerDataFetch(Item, Request); +end; + +function TTntCustomListView.OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; +begin + if Assigned(OnData) then + begin + OnData(Self, Item); + Result := True; + end + else Result := False; +end; + +function TntDefaultListViewSort(Item1, Item2: TTntListItem; lParam: Integer): Integer; stdcall; +begin + Assert(Win32PlatformIsUnicode); + with Item1 do + if Assigned(ListView.OnCompare) then + ListView.OnCompare(ListView, Item1, Item2, lParam, Result) + else Result := lstrcmpw(PWideChar(Item1.Caption), PWideChar(Item2.Caption)); +end; + +procedure TTntCustomListView.WndProc(var Message: TMessage); +var + Item: TTntListItem; + InheritedItem: TListItem{TNT-ALLOW TListItem}; + SubItem: Integer; + SavedItem: TSavedListItem; + PCol: PLVColumn; + Col: TTntListColumn; +begin + with Message do begin + // restore previous values (during CreateWnd) + if (FSavedItems <> nil) and (FChangingWideItemCount = 0) and (Msg = LVM_SETITEMTEXTA) then begin + Item := Items[wParam]; + SavedItem := TSavedListItem(FSavedItems[wParam]); + if (Msg = LVM_SETITEMTEXTA) and (PLVItem(lParam).iSubItem = 0) then + Item.FCaption := SavedItem.FCaption + else begin + SubItem := PLVItem(lParam).iSubItem - 1; + TWideSubItems(Item.SubItems).FIgnoreInherited := True; + try + if SubItem < Item.SubItems.Count then begin + Item.SubItems[SubItem] := SavedItem.FSubItems[SubItem]; + Item.SubItems.Objects[SubItem] := SavedItem.FSubItems.Objects[SubItem] + end else if SubItem = Item.SubItems.Count then + Item.SubItems.AddObject(SavedItem.FSubItems[SubItem], SavedItem.FSubItems.Objects[SubItem]) + else + Item.SubItems.Assign(SavedItem.FSubItems) + finally + TWideSubItems(Item.SubItems).FIgnoreInherited := False; + end; + end; + end; + + // sync wide with ansi + if (FSavedItems = nil) and (FChangingWideItemCount = 0) and (Msg = LVM_UPDATE) then begin + Item := Items[wParam]; + InheritedItem := Item; + TWideSubItems(Item.SubItems).FIgnoreInherited := True; + try + Item.SubItems.Assign(InheritedItem.SubItems) + finally + TWideSubItems(Item.SubItems).FIgnoreInherited := False; + end; + end; + + if (FSavedItems = nil) and (FChangingWideItemCount = 0) and (Msg = LVM_SETITEMTEXTA) then begin + if OwnerData then + Item := FTempItem + else + Item := Items[wParam]; + InheritedItem := Item; + if (Msg = LVM_SETITEMTEXTA) and (PLVItem(lParam).iSubItem = 0) then + Item.FCaption := InheritedItem.Caption + else begin + SubItem := PLVItem(lParam).iSubItem - 1; + TWideSubItems(Item.SubItems).FIgnoreInherited := True; + try + if SubItem < Item.SubItems.Count then begin + Item.SubItems[SubItem] := InheritedItem.SubItems[SubItem]; + Item.SubItems.Objects[SubItem] := InheritedItem.SubItems.Objects[SubItem] + end else if SubItem = Item.SubItems.Count then + Item.SubItems.AddObject(InheritedItem.SubItems[SubItem], InheritedItem.SubItems.Objects[SubItem]) + else + Item.SubItems.Assign(InheritedItem.SubItems) + finally + TWideSubItems(Item.SubItems).FIgnoreInherited := False; + end; + end; + end; + + // capture ANSI version of DefaultListViewSort from ComCtrls + if (FTestingForSortProc) + and (Msg = LVM_SORTITEMS) then begin + ComCtrls_DefaultListViewSort := Pointer(lParam); + exit; + end; + + if (Msg = LVM_SETCOLUMNA) then begin + // make sure that wide column caption stays in sync with ANSI + PCol := PLVColumn(lParam); + if (PCol.mask and LVCF_TEXT) <> 0 then begin + Col := GetColumnFromTag(wParam); + if (Col <> nil) and (AnsiString(Col.Caption) <> PCol.pszText) then begin + Col.FCaption := PCol.pszText; + end; + end; + end; + + if (Win32PlatformIsUnicode) + and (Msg = LVM_SETITEMTEXTA) and (PLVItem(lParam).pszText = LPSTR_TEXTCALLBACK) then + // Unicode:: call wide version of text call back instead + Result := SendMessageW(Handle, LVM_SETITEMTEXTW, WParam, LParam) + else if (Win32PlatformIsUnicode) + and (Msg = LVM_SORTITEMS) and (Pointer(lParam) = @ComCtrls_DefaultListViewSort) then + // Unicode:: call wide version of sort proc instead + Result := SendMessageW(Handle, LVM_SORTITEMS, wParam, Integer(@TntDefaultListViewSort)) + else if (Win32PlatformIsUnicode) + and (Msg = LVM_SETCOLUMNA) and ((PLVColumn(lParam).mask and LVCF_TEXT) <> 0) + and (GetColumnFromTag(wParam) <> nil) then begin + PLVColumn(lParam).pszText := PAnsiChar(PWideChar(GetColumnFromTag(wParam).FCaption)); + Result := SendMessageW(Handle, LVM_SETCOLUMNW, wParam, lParam); + end else begin + if (Msg = LVM_SETEXTENDEDLISTVIEWSTYLE) and CheckBoxes then begin + { fix a bug in TCustomListView.ResetExStyles } + lParam := lParam or LVS_EX_SUBITEMIMAGES or LVS_EX_INFOTIP; + end; + inherited; + end; + end; +end; + +procedure TTntCustomListView.WMNotify(var Message: TWMNotify); +begin + inherited; + // capture updated info after inherited + with Message.NMHdr^ do + case code of + HDN_ENDTRACKW: + begin + Message.NMHdr^.code := HDN_ENDTRACKA; + try + inherited + finally + Message.NMHdr^.code := HDN_ENDTRACKW; + end; + end; + HDN_DIVIDERDBLCLICKW: + begin + Message.NMHdr^.code := HDN_DIVIDERDBLCLICKA; + try + inherited + finally + Message.NMHdr^.code := HDN_DIVIDERDBLCLICKW; + end; + end; + end; +end; + +procedure TTntCustomListView.CNNotify(var Message: TWMNotify); +var + Item: TTntListItem; +begin + if (not Win32PlatformIsUnicode) then + inherited + else begin + with Message do + begin + case NMHdr^.code of + HDN_TRACKW: + begin + NMHdr^.code := HDN_TRACKA; + try + inherited; + finally + NMHdr^.code := HDN_TRACKW; + end; + end; + LVN_GETDISPINFOW: + begin + // call inherited without the LVIF_TEXT flag + CurrentDispInfo := PLVDispInfoW(NMHdr); + try + OriginalDispInfoMask := PLVDispInfoW(NMHdr)^.item.mask; + + PLVDispInfoW(NMHdr)^.item.mask := PLVDispInfoW(NMHdr)^.item.mask and (not LVIF_TEXT); + try + NMHdr^.code := LVN_GETDISPINFOA; + try + inherited; + finally + NMHdr^.code := LVN_GETDISPINFOW; + end; + finally + if (OriginalDispInfoMask and LVIF_TEXT <> 0) then + PLVDispInfoW(NMHdr)^.item.mask := PLVDispInfoW(NMHdr)^.item.mask or LVIF_TEXT; + end; + finally + CurrentDispInfo := nil; + end; + + // handle any text info + with PLVDispInfoW(NMHdr)^.item do + begin + if (mask and LVIF_TEXT) <> 0 then + begin + Item := GetItemW(PLVDispInfoW(NMHdr)^.item); + if iSubItem = 0 then + WStrLCopy(pszText, PWideChar(Item.Caption), cchTextMax - 1) + else begin + with Item.SubItems do begin + if iSubItem <= Count then + WStrLCopy(pszText, PWideChar(Strings[iSubItem - 1]), cchTextMax - 1) + else pszText[0] := #0; + end; + end; + end; + end; + end; + LVN_ODFINDITEMW: + with PNMLVFindItem(NMHdr)^ do + begin + if ((lvfi.flags and LVFI_PARTIAL) <> 0) or ((lvfi.flags and LVFI_STRING) <> 0) then + PWideFindString := TLVFindInfoW(lvfi).psz + else + PWideFindString := nil; + lvfi.psz := nil; + NMHdr^.code := LVN_ODFINDITEMA; + try + inherited; {will Result in call to OwnerDataFind} + finally + TLVFindInfoW(lvfi).psz := PWideFindString; + NMHdr^.code := LVN_ODFINDITEMW; + PWideFindString := nil; + end; + end; + LVN_BEGINLABELEDITW: + begin + Item := GetItemW(PLVDispInfoW(NMHdr)^.item); + if not CanEdit(Item) then Result := 1; + if Result = 0 then + begin + FEditHandle := ListView_GetEditControl(Handle); + FDefEditProc := Pointer(GetWindowLongW(FEditHandle, GWL_WNDPROC)); + SetWindowLongW(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance)); + end; + end; + LVN_ENDLABELEDITW: + with PLVDispInfoW(NMHdr)^ do + if (item.pszText <> nil) and (item.IItem <> -1) then + Edit(TLVItemA(item)); + LVN_GETINFOTIPW: + begin + NMHdr^.code := LVN_GETINFOTIPA; + try + inherited; + finally + NMHdr^.code := LVN_GETINFOTIPW; + end; + end; + else + inherited; + end; + end; + end; +end; + +function TTntCustomListView.OwnerDataFindW(Find: TItemFind; + const FindString: WideString; const FindPosition: TPoint; + FindData: Pointer; StartIndex: Integer; Direction: TSearchDirection; + Wrap: Boolean): Integer; +begin + Result := OwnerDataFind(Find, FindString, FindPosition, FindData, StartIndex, Direction, Wrap); +end; + +function TTntCustomListView.OwnerDataFind(Find: TItemFind; const FindString: WideString; + const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; + Direction: TSearchDirection; Wrap: Boolean): Integer; +var + AnsiEvent: TLVOwnerDataFindEvent; +begin + Result := -1; + if Assigned(OnDataFind) then + OnDataFind(Self, Find, FindString, FindPosition, FindData, StartIndex, Direction, Wrap, Result) + else if Assigned(inherited OnDataFind) then begin + AnsiEvent := inherited OnDataFind; + AnsiEvent(Self, Find, FindString, FindPosition, FindData, StartIndex, Direction, + Wrap, Result); + end; +end; + +procedure TTntCustomListView.Edit(const Item: TLVItem); +var + S: WideString; + AnsiS: AnsiString; + EditItem: TTntListItem; + AnsiEvent: TLVEditedEvent; +begin + if (not Win32PlatformIsUnicode) then + S := Item.pszText + else + S := TLVItemW(Item).pszText; + EditItem := GetItemW(TLVItemW(Item)); + if Assigned(OnEdited) then + OnEdited(Self, EditItem, S) + else if Assigned(inherited OnEdited) then + begin + AnsiEvent := inherited OnEdited; + AnsiS := S; + AnsiEvent(Self, EditItem, AnsiS); + S := AnsiS; + end; + if EditItem <> nil then + EditItem.Caption := S; +end; + +procedure TTntCustomListView.EditWndProcW(var Message: TMessage); +begin + Assert(Win32PlatformIsUnicode); + try + with Message do + begin + case Msg of + WM_KEYDOWN, + WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit; + WM_CHAR: + begin + MakeWMCharMsgSafeForAnsi(Message); + try + if DoKeyPress(TWMKey(Message)) then Exit; + finally + RestoreWMCharMsg(Message); + end; + end; + WM_KEYUP, + WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit; + CN_KEYDOWN, + CN_CHAR, CN_SYSKEYDOWN, + CN_SYSCHAR: + begin + WndProc(Message); + Exit; + end; + end; + Result := CallWindowProcW(FDefEditProc, FEditHandle, Msg, WParam, LParam); + end; + except + Application.HandleException(Self); + end; +end; + +procedure TTntCustomListView.BeginChangingWideItem; +begin + Inc(FChangingWideItemCount); +end; + +procedure TTntCustomListView.EndChangingWideItem; +begin + if FChangingWideItemCount > 0 then + Dec(FChangingWideItemCount); +end; + +procedure TTntCustomListView.DrawItem(Item: TListItem{TNT-ALLOW TListItem}; Rect: TRect; + State: TOwnerDrawState); +begin + TControlCanvas(Canvas).UpdateTextFlags; + if Assigned(OnDrawItem) then OnDrawItem(Self, Item, Rect, State) + else + begin + Canvas.FillRect(Rect); + WideCanvasTextOut(Canvas, Rect.Left + 2, Rect.Top, Item.Caption); + end; +end; + +procedure TTntCustomListView.CopySelection(Destination: TCustomListControl); +var + I: Integer; +begin + for I := 0 to Items.Count - 1 do + if Items[I].Selected then + WideListControl_AddItem(Destination, Items[I].Caption, Items[I].Data); +end; + +procedure TTntCustomListView.AddItem(const Item: WideString; AObject: TObject); +begin + with Items.Add do + begin + Caption := Item; + Data := AObject; + end; +end; + +//------------- + +function TTntCustomListView.FindCaption(StartIndex: Integer; Value: WideString; + Partial, Inclusive, Wrap: Boolean): TTntListItem; +const + FullString: array[Boolean] of Integer = (0, LVFI_PARTIAL); + Wraps: array[Boolean] of Integer = (0, LVFI_WRAP); +var + Info: TLVFindInfoW; + Index: Integer; +begin + if (not Win32PlatformIsUnicode) then + Result := inherited FindCaption(StartIndex, Value, Partial, Inclusive, Wrap) as TTntListItem + else begin + with Info do + begin + flags := LVFI_STRING or FullString[Partial] or Wraps[Wrap]; + psz := PWideChar(Value); + end; + if Inclusive then Dec(StartIndex); + Index := SendMessageW(Handle, LVM_FINDITEMW, StartIndex, Longint(@Info)); + if Index <> -1 then Result := Items[Index] + else Result := nil; + end; +end; + +function TTntCustomListView.StringWidth(S: WideString): Integer; +begin + if (not Win32PlatformIsUnicode) then + Result := inherited StringWidth(S) + else + Result := SendMessageW(Handle, LVM_GETSTRINGWIDTHW, 0, Longint(PWideChar(S))) +end; + +function TTntCustomListView.GetSearchString: WideString; +var + Buffer: array[0..1023] of WideChar; +begin + if (not Win32PlatformIsUnicode) then + Result := inherited GetSearchString + else begin + Result := ''; + if HandleAllocated + and Bool(SendMessageW(Handle, LVM_GETISEARCHSTRINGW, 0, Longint(PWideChar(@Buffer[0])))) then + Result := Buffer; + end; +end; + +function TTntCustomListView.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomListView.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomListView.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomListView.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomListView.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntToolButton } + +procedure TTntToolButton.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntToolButton.CMVisibleChanged(var Message: TMessage); +begin + inherited; + RefreshControl; +end; + +function TTntToolButton.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntToolButton.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); + RefreshControl; { causes button to be removed and reinserted with TB_INSERTBUTTON } +end; + +function TTntToolButton.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntToolButton.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntToolButton.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntToolButton.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +procedure TTntToolButton.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntToolButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntToolButton.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntToolButton.GetMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; +begin + Result := inherited MenuItem; +end; + +procedure TTntToolButton.SetMenuItem(const Value: TMenuItem{TNT-ALLOW TMenuItem}); +begin + inherited MenuItem := Value; + if Value is TTntMenuItem then begin + Caption := TTntMenuItem(Value).Caption; + Hint := TTntMenuItem(Value).Hint; + end; +end; + +{ TTntToolBar } + +procedure TTntToolBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, TOOLBARCLASSNAME); +end; + +procedure TTntToolBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntToolBar.TBInsertButtonA(var Message: TMessage); +var + Button: TTntToolButton; + Buffer: WideString; +begin + if Win32PlatformIsUnicode + and (PTBButton(Message.LParam).iString <> -1) + and (Buttons[Message.WParam] is TTntToolButton) then + begin + Button := TTntToolButton(Buttons[Message.WParam]); + Buffer := Button.Caption + WideChar(#0); + PTBButton(Message.LParam).iString := + SendMessage(Handle, TB_ADDSTRINGW, 0, Integer(PWideChar(Buffer))); + end; + inherited; +end; + +{ Need to read/write caption ourselves - default wndproc seems to discard it. } + +procedure TTntToolBar.WMGetText(var Message: TWMGetText); +begin + if (not Win32PlatformIsUnicode) or (WindowHandle = 0) then + inherited + else + with Message do + Result := WStrLen(WStrLCopy(PWideChar(Text), PWideChar(FCaption), TextMax - 1)); +end; + +procedure TTntToolBar.WMGetTextLength(var Message: TWMGetTextLength); +begin + if (not Win32PlatformIsUnicode) or (WindowHandle = 0) then + inherited + else + Message.Result := Length(FCaption); +end; + +procedure TTntToolBar.WMSetText(var Message: TWMSetText); +begin + if (not Win32PlatformIsUnicode) or (WindowHandle = 0) then + inherited + else + with Message do + SetString(FCaption, PWideChar(Text), WStrLen(PWideChar(Text))); +end; + +function TTntToolBar.GetCaption: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntToolBar.SetCaption(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +function TTntToolBar.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntToolBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntToolBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntToolBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +procedure TTntToolBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntToolBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntToolBar.GetMenu: TMainMenu{TNT-ALLOW TMainMenu}; +begin + Result := inherited Menu; +end; + +procedure TTntToolBar.SetMenu(const Value: TMainMenu{TNT-ALLOW TMainMenu}); +var + I: Integer; +begin + if (Menu <> Value) then begin + inherited Menu := Value; + if Assigned(Menu) then begin + // get rid of TToolButton(s) + for I := ButtonCount - 1 downto 0 do + Buttons[I].Free; + // add TTntToolButton(s) + for I := Menu.Items.Count - 1 downto 0 do + begin + with TTntToolButton.Create(Self) do + try + AutoSize := True; + Grouped := True; + Parent := Self; + MenuItem := Menu.Items[I]; + except + Free; + raise; + end; + end; + end; + end; +end; + +{ TTntRichEditStrings } +type + TTntRichEditStrings = class(TTntMemoStrings) + private + RichEdit: TCustomRichEdit{TNT-ALLOW TCustomRichEdit}; + procedure EnableChange(const Value: Boolean); + protected + procedure SetTextStr(const Value: WideString); override; + public + constructor Create; + procedure AddStrings(Strings: TWideStrings); overload; override; + //-- + procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); override; + procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); override; + procedure LoadFromFile(const FileName: WideString); override; + procedure SaveToFile(const FileName: WideString); override; + end; + +constructor TTntRichEditStrings.Create; +begin + inherited Create; + FRichEditMode := True; +end; + +procedure TTntRichEditStrings.AddStrings(Strings: TWideStrings); +var + SelChange: TNotifyEvent; +begin + SelChange := TTntCustomRichEdit(RichEdit).OnSelectionChange; + TTntCustomRichEdit(RichEdit).OnSelectionChange := nil; + try + inherited; + finally + TTntCustomRichEdit(RichEdit).OnSelectionChange := SelChange; + end; +end; + +procedure TTntRichEditStrings.EnableChange(const Value: Boolean); +var + EventMask: Longint; +begin + with RichEdit do + begin + if Value then + EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE + else + EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE; + SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask); + end; +end; + +procedure TTntRichEditStrings.SetTextStr(const Value: WideString); +begin + EnableChange(False); + try + inherited; + finally + EnableChange(True); + end; +end; + +type TAccessCustomRichEdit = class(TCustomRichEdit{TNT-ALLOW TCustomRichEdit}); + +procedure TTntRichEditStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); +begin + if TAccessCustomRichEdit(RichEdit).PlainText then + inherited LoadFromStream_BOM(Stream, WithBOM) + else + TAccessCustomRichEdit(RichEdit).Lines.LoadFromStream(Stream); +end; + +procedure TTntRichEditStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); +begin + if TAccessCustomRichEdit(RichEdit).PlainText then + inherited SaveToStream_BOM(Stream, WithBOM) + else + TAccessCustomRichEdit(RichEdit).Lines.SaveToStream(Stream); +end; + +procedure TTntRichEditStrings.LoadFromFile(const FileName: WideString); +begin + if TAccessCustomRichEdit(RichEdit).PlainText then + inherited LoadFromFile(FileName) + else + TAccessCustomRichEdit(RichEdit).Lines.LoadFromFile(FileName); +end; + +procedure TTntRichEditStrings.SaveToFile(const FileName: WideString); +begin + if TAccessCustomRichEdit(RichEdit).PlainText then + inherited SaveToFile(FileName) + else + TAccessCustomRichEdit(RichEdit).Lines.SaveToFile(FileName); +end; + +{ TTntCustomRichEdit } + +constructor TTntCustomRichEdit.Create(AOwner: TComponent); +begin + inherited; + FRichEditStrings := TTntRichEditStrings.Create; + TTntRichEditStrings(FRichEditStrings).FMemo := Self; + TTntRichEditStrings(FRichEditStrings).FMemoLines := TAccessCustomRichEdit(Self).Lines; + TTntRichEditStrings(FRichEditStrings).FLineBreakStyle := Self.LineBreakStyle; + TTntRichEditStrings(FRichEditStrings).RichEdit := Self; +end; + +var + FRichEdit20Module: THandle = 0; + +function IsRichEdit20Available: Boolean; +const + RICHED20_DLL = 'RICHED20.DLL'; +begin + if FRichEdit20Module = 0 then + FRichEdit20Module := Tnt_LoadLibraryW(RICHED20_DLL); + Result := FRichEdit20Module <> 0; +end; + +{function IsRichEdit30Available: Boolean; +begin + Result := False; + exit; + Result := IsRichEdit20Available and (Win32MajorVersion >= 5); +end;} + +procedure TTntCustomRichEdit.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + if WordWrap then + Params.Style := Params.Style and not WS_HSCROLL; // more compatible with RichEdit 1.0 +end; + +procedure TTntCustomRichEdit.CreateWindowHandle(const Params: TCreateParams); +begin + if Win32PlatformIsUnicode and IsRichEdit20Available then + CreateUnicodeHandle(Self, Params, RICHEDIT_CLASSW) + else + inherited +end; + +var + AIMM: IActiveIMMApp = nil; + +function EnableActiveIMM: Boolean; +begin + if AIMM <> nil then + Result := True + else begin + Result := False; + try + if ClassIsRegistered(CLASS_CActiveIMM) then begin + AIMM := CoCActiveIMM.Create; + AIMM.Activate(1); + Result := True; + end; + except + AIMM := nil; + end; + end; +end; + +procedure TTntCustomRichEdit.CreateWnd; +const + EM_SETEDITSTYLE = WM_USER + 204; + SES_USEAIMM = 64; +begin + inherited; + // Only supported in RichEdit 3.0, but this flag is harmless to RichEdit1.0 or RichEdit 2.0 + if EnableActiveIMM then + SendMessage(Handle, EM_SETEDITSTYLE, SES_USEAIMM, SES_USEAIMM); +end; + +procedure TTntCustomRichEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +destructor TTntCustomRichEdit.Destroy; +begin + FreeAndNil(FRichEditStrings); + inherited; +end; + +procedure TTntCustomRichEdit.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited; + if (not WantReturns) and (Key = VK_RETURN) and (Shift <> [ssCtrl]) then + Key := 0; +end; + +function TTntCustomRichEdit.LineBreakStyle: TTntTextLineBreakStyle; +begin + if Win32PlatformIsUnicode and IsRichEdit20Available then + Result := tlbsCR + else + Result := tlbsCRLF; +end; + +procedure TTntCustomRichEdit.SetRichEditStrings(const Value: TTntStrings); +begin + FRichEditStrings.Assign(Value); +end; + +function TTntCustomRichEdit.GetSelText: string{TNT-ALLOW string}; +begin + Result := GetWideSelText; +end; + +function TTntCustomRichEdit.GetWideSelText: WideString; +var + CharRange: TCharRange; + Length: Integer; +begin + if (not IsWindowUnicode(Handle)) then + Result := inherited GetSelText + else begin + SendMessageW(Handle, EM_EXGETSEL, 0, Longint(@CharRange)); + SetLength(Result, CharRange.cpMax - CharRange.cpMin + 1); + Length := SendMessageW(Handle, EM_GETSELTEXT, 0, Longint(PWideChar(Result))); + SetLength(Result, Length); + end; + if LineBreakStyle <> tlbsCRLF then + Result := TntAdjustLineBreaks(Result, tlbsCRLF) +end; + +type + TSetTextEx = record + flags:dword; + codepage:uint; + end; + +procedure TTntCustomRichEdit.SetRTFText(Flags: DWORD; const Value: AnsiString); +const + EM_SETTEXTEX = (WM_USER + 97); +var + Info: TSetTextEx; +begin + Info.flags := Flags; + Info.codepage := CP_ACP{TNT-ALLOW CP_ACP}; + SendMessage(Handle, EM_SETTEXTEX, Integer(@Info), Integer(PAnsiChar(Value))); +end; + +procedure TTntCustomRichEdit.SetWideSelText(const Value: WideString); +const + ST_SELECTION = 2; +begin + if Win32PlatformIsUnicode and IsRichEdit20Available and IsRTF(Value) then begin + // emulate RichEdit 1.0 so that RTF code is inserted as RTF (not plain text) + SetRTFText(ST_SELECTION, Value) + end else + TntCustomEdit_SetSelText(Self, TntAdjustLineBreaks(Value, LineBreakStyle)); +end; + +function TTntCustomRichEdit.GetText: WideString; +begin + Result := TntControl_GetText(Self); + if (LineBreakStyle <> tlbsCRLF) then + Result := TntAdjustLineBreaks(Result, tlbsCRLF); +end; + +procedure TTntCustomRichEdit.SetText(const Value: WideString); +const + ST_DEFAULT = 0; +begin + if Win32PlatformIsUnicode and IsRichEdit20Available and IsRTF(Value) then begin + // emulate RichEdit 1.0 so that RTF code is inserted as RTF (not plain text) + SetRTFText(ST_DEFAULT, Value) + end else if Value <> Text then + TntControl_SetText(Self, TntAdjustLineBreaks(Value, LineBreakStyle)); +end; + +function TTntCustomRichEdit.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomRichEdit.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomRichEdit.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomRichEdit.WMGetTextLength(var Message: TWMGetTextLength); +begin + if FPrintingTextLength <> 0 then + Message.Result := FPrintingTextLength + else + inherited; +end; + +procedure TTntCustomRichEdit.Print(const Caption: string{TNT-ALLOW string}); +begin + if (LineBreakStyle <> tlbsCRLF) then + FPrintingTextLength := TntAdjustLineBreaksLength(Text, LineBreakStyle) + else + FPrintingTextLength := 0; + try + inherited + finally + FPrintingTextLength := 0; + end; +end; + +{$WARN SYMBOL_DEPRECATED OFF} + +function TTntCustomRichEdit.CharPosToGet(RawWin32CharPos: Integer): Integer; +begin + Result := EmulatedCharPos(RawWin32CharPos); +end; + +function TTntCustomRichEdit.CharPosToSet(EmulatedCharPos: Integer): Integer; +begin + Result := RawWin32CharPos(EmulatedCharPos); +end; +{$WARN SYMBOL_DEPRECATED ON} + +function TTntCustomRichEdit.EmulatedCharPos(RawWin32CharPos: Integer): Integer; +var + i: Integer; + ThisLine: Integer; + CharCount: Integer; + Line_Start: Integer; + NumLineBreaks: Integer; +begin + if (LineBreakStyle = tlbsCRLF) or (RawWin32CharPos <= 0) then + Result := RawWin32CharPos + else begin + Assert(Win32PlatformIsUnicode); + ThisLine := SendMessageW(Handle, EM_EXLINEFROMCHAR, 0, RawWin32CharPos); + if (not WordWrap) then + NumLineBreaks := ThisLine + else begin + CharCount := 0; + for i := 0 to ThisLine - 1 do + Inc(CharCount, TntMemo_LineLength(Handle, i)); + Line_Start := TntMemo_LineStart(Handle, ThisLine); + NumLineBreaks := Line_Start - CharCount; + end; + Result := RawWin32CharPos + NumLineBreaks; {inflate CR -> CR/LF} + end; +end; + +function TTntCustomRichEdit.RawWin32CharPos(EmulatedCharPos: Integer): Integer; +var + Line: Integer; + NumLineBreaks: Integer; + CharCount: Integer; + Line_Start: Integer; + LineLength: Integer; +begin + if (LineBreakStyle = tlbsCRLF) or (EmulatedCharPos <= 0) then + Result := EmulatedCharPos + else begin + Assert(Win32PlatformIsUnicode); + NumLineBreaks := 0; + CharCount := 0; + for Line := 0 to Lines.Count do begin + Line_Start := TntMemo_LineStart(Handle, Line); + if EmulatedCharPos < (Line_Start + NumLineBreaks) then + break; {found it (it must have been the line separator)} + if Line_Start > CharCount then begin + Inc(NumLineBreaks); + Inc(CharCount); + end; + LineLength := TntMemo_LineLength(Handle, Line, Line_Start); + Inc(CharCount, LineLength); + if (EmulatedCharPos >= (Line_Start + NumLineBreaks)) + and (EmulatedCharPos < (Line_Start + LineLength + NumLineBreaks)) then + break; {found it} + end; + Result := EmulatedCharPos - NumLineBreaks; {deflate CR/LF -> CR} + end; +end; + +function TTntCustomRichEdit.FindText(const SearchStr: WideString; + StartPos, Length: Integer; Options: TSearchTypes): Integer; +const + EM_FINDTEXTEXW = WM_USER + 124; +const + FR_DOWN = $00000001; + FR_WHOLEWORD = $00000002; + FR_MATCHCASE = $00000004; +var + Find: TFindTextW; + Flags: Integer; +begin + if (not Win32PlatformIsUnicode) then + Result := inherited FindText(SearchStr, StartPos, Length, Options) + else begin + with Find.chrg do + begin + cpMin := RawWin32CharPos(StartPos); + cpMax := RawWin32CharPos(StartPos + Length); + end; + Flags := FR_DOWN; { RichEdit 2.0 and later needs this } + if stWholeWord in Options then Flags := Flags or FR_WHOLEWORD; + if stMatchCase in Options then Flags := Flags or FR_MATCHCASE; + Find.lpstrText := PWideChar(SearchStr); + Result := SendMessageW(Handle, EM_FINDTEXT, Flags, LongInt(@Find)); + Result := EmulatedCharPos(Result); + end; +end; + +function TTntCustomRichEdit.GetSelStart: Integer; +begin + Result := TntCustomEdit_GetSelStart(Self); + Result := EmulatedCharPos(Result); +end; + +procedure TTntCustomRichEdit.SetSelStart(const Value: Integer); +begin + TntCustomEdit_SetSelStart(Self, RawWin32CharPos(Value)); +end; + +function TTntCustomRichEdit.GetSelLength: Integer; +var + CharRange: TCharRange; +begin + if (LineBreakStyle = tlbsCRLF) then + Result := TntCustomEdit_GetSelLength(Self) + else begin + Assert(Win32PlatformIsUnicode); + SendMessageW(Handle, EM_EXGETSEL, 0, Longint(@CharRange)); + Result := EmulatedCharPos(CharRange.cpMax) - EmulatedCharPos(CharRange.cpMin); + end; +end; + +procedure TTntCustomRichEdit.SetSelLength(const Value: Integer); +var + StartPos: Integer; + SelEnd: Integer; +begin + if (LineBreakStyle = tlbsCRLF) then + TntCustomEdit_SetSelLength(Self, Value) + else begin + StartPos := Self.SelStart; + SelEnd := StartPos + Value; + inherited SetSelLength(RawWin32CharPos(SelEnd) - RawWin32CharPos(StartPos)); + end; +end; + +procedure TTntCustomRichEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomRichEdit.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntTabStrings } + +type TAccessCustomTabControl = class(TCustomTabControl{TNT-ALLOW TCustomTabControl}); + +type + TTntTabStrings = class(TTntStrings) + private + FTabControl: TCustomTabControl{TNT-ALLOW TCustomTabControl}; + FAnsiTabs: TStrings{TNT-ALLOW TStrings}; + protected + function Get(Index: Integer): WideString; override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure Put(Index: Integer; const S: WideString); override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: WideString); override; + end; + +procedure TabControlError(const S: WideString); +begin + raise EListError.Create(S); +end; + +procedure TTntTabStrings.Clear; +begin + FAnsiTabs.Clear; +end; + +procedure TTntTabStrings.Delete(Index: Integer); +begin + FAnsiTabs.Delete(Index); +end; + +function TTntTabStrings.GetCount: Integer; +begin + Result := FAnsiTabs.Count; +end; + +function TTntTabStrings.GetObject(Index: Integer): TObject; +begin + Result := FAnsiTabs.Objects[Index]; +end; + +procedure TTntTabStrings.PutObject(Index: Integer; AObject: TObject); +begin + FAnsiTabs.Objects[Index] := AObject; +end; + +procedure TTntTabStrings.SetUpdateState(Updating: Boolean); +begin + inherited; + TAccessStrings(FAnsiTabs).SetUpdateState(Updating); +end; + +function TTntTabStrings.Get(Index: Integer): WideString; +const + RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); +var + TCItem: TTCItemW; + Buffer: array[0..4095] of WideChar; +begin + if (not Win32PlatformIsUnicode) then + Result := FAnsiTabs[Index] + else begin + TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading]; + TCItem.pszText := Buffer; + TCItem.cchTextMax := SizeOf(Buffer); + if SendMessageW(FTabControl.Handle, TCM_GETITEMW, Index, Longint(@TCItem)) = 0 then + TabControlError(WideFormat(sTabFailRetrieve, [Index])); + Result := Buffer; + end; +end; + +function GetTabControlImageIndex(Self: TCustomTabControl{TNT-ALLOW TCustomTabControl}; TabIndex: Integer): Integer; +begin + Result := TabIndex; + with TAccessCustomTabControl(Self) do + if Assigned(OnGetImageIndex) then OnGetImageIndex(Self, TabIndex, Result); +end; + +procedure TTntTabStrings.Put(Index: Integer; const S: WideString); +const + RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); +var + TCItem: TTCItemW; +begin + if (not Win32PlatformIsUnicode) then + FAnsiTabs[Index] := S + else begin + TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or TCIF_IMAGE; + TCItem.pszText := PWideChar(S); + TCItem.iImage := GetTabControlImageIndex(FTabControl, Index); + if SendMessageW(FTabControl.Handle, TCM_SETITEMW, Index, Longint(@TCItem)) = 0 then + TabControlError(WideFormat(sTabFailSet, [S, Index])); + TAccessCustomTabControl(FTabControl).UpdateTabImages; + end; +end; + +procedure TTntTabStrings.Insert(Index: Integer; const S: WideString); +const + RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); +var + TCItem: TTCItemW; +begin + if (not Win32PlatformIsUnicode) then + FAnsiTabs.Insert(Index, S) + else begin + TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or TCIF_IMAGE; + TCItem.pszText := PWideChar(S); + TCItem.iImage := GetTabControlImageIndex(FTabControl, Index); + if SendMessageW(FTabControl.Handle, TCM_INSERTITEMW, Index, Longint(@TCItem)) < 0 then + TabControlError(WideFormat(sTabFailSet, [S, Index])); + TAccessCustomTabControl(FTabControl).UpdateTabImages; + end; +end; + +{ TTntCustomTabControl } + +constructor TTntCustomTabControl.Create(AOwner: TComponent); +begin + inherited; + FTabs := TTntTabStrings.Create; + TTntTabStrings(FTabs).FTabControl := Self; + TTntTabStrings(FTabs).FAnsiTabs := inherited Tabs; +end; + +destructor TTntCustomTabControl.Destroy; +begin + TTntTabStrings(FTabs).FTabControl := nil; + TTntTabStrings(FTabs).FAnsiTabs := nil; + FreeAndNil(FTabs); + FreeAndNil(FSaveTabs); + inherited; +end; + +procedure TTntCustomTabControl.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_TABCONTROL); +end; + +procedure TTntCustomTabControl.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomTabControl.CreateWnd; +begin + inherited; + if FSaveTabs <> nil then + begin + FTabs.Assign(FSaveTabs); + FreeAndNil(FSaveTabs); + TabIndex := FSaveTabIndex; + end; +end; + +procedure TTntCustomTabControl.DestroyWnd; +begin + if (FTabs <> nil) and (FTabs.Count > 0) then + begin + FSaveTabs := TTntStringList.Create; + FSaveTabs.Assign(FTabs); + FSaveTabIndex := TabIndex; + end; + inherited; +end; + +function TTntCustomTabControl.GetTabs: TTntStrings; +begin + if FSaveTabs <> nil then + Result := FSaveTabs // Use FSaveTabs while the window is deallocated + else + Result := FTabs; +end; + +procedure TTntCustomTabControl.SetTabs(const Value: TTntStrings); +begin + FTabs.Assign(Value); +end; + +function TTntCustomTabControl.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomTabControl.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomTabControl.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomTabControl.CMDialogChar(var Message: TCMDialogChar); +var + I: Integer; +begin + for I := 0 to Tabs.Count - 1 do + if IsWideCharAccel(Message.CharCode, Tabs[I]) and CanShowTab(I) and CanFocus then + begin + Message.Result := 1; + if CanChange then + begin + TabIndex := I; + Change; + end; + Exit; + end; + Broadcast(Message); +end; + +procedure TTntCustomTabControl.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomTabControl.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntTabSheet } + +procedure TTntTabSheet.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +function TTntTabSheet.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntTabSheet.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntTabSheet.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntTabSheet.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntTabSheet.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntTabSheet.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntTabSheet.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntTabSheet.WMSetText(var Message: TWMSetText); +begin + if (not Win32PlatformIsUnicode) + or (HandleAllocated) + or (Message.Text = AnsiString(TntControl_GetText(Self))) + or (Force_Inherited_WMSETTEXT) then + inherited + else begin + // NT, handle not allocated and text is different + Force_Inherited_WMSETTEXT := True; + try + TntControl_SetText(Self, Message.Text) { sync WideCaption with ANSI Caption } + finally + Force_Inherited_WMSETTEXT := FALSE; + end; + end; +end; + +procedure TTntTabSheet.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntTabSheet.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntPageControl } + +procedure TTntPageControl.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_TABCONTROL); +end; + +procedure TTntPageControl.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPageControl.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntPageControl.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntPageControl.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntPageControl.WndProc(var Message: TMessage); +const + RTL: array[Boolean] of Cardinal = (0, TCIF_RTLREADING); +var + TCItemA: PTCItemA; + TabSheet: TTabSheet{TNT-ALLOW TTabSheet}; + Text: WideString; +begin + if (not Win32PlatformIsUnicode) then + inherited + else begin + case Message.Msg of + TCM_SETITEMA: + begin + TCItemA := PTCItemA(Message.lParam); + if ((TCItemA.mask and TCIF_PARAM) = TCIF_PARAM) then + TabSheet := TObject(TCItemA.lParam) as TTabSheet{TNT-ALLOW TTabSheet} + else if ((TCItemA.mask and TCIF_TEXT) = TCIF_TEXT) + and (Message.wParam >= 0) and (Message.wParam <= Tabs.Count - 1) then + TabSheet := Tabs.Objects[Message.wParam] as TTabSheet{TNT-ALLOW TTabSheet} + else + TabSheet := nil; + + if TabSheet = nil then begin + // will always be followed by TCM_SETITEMA(TCIF_PARAM) if TCIF_TEXT is present + TCItemA.mask := TCItemA.mask and (not TCIF_TEXT); + end else begin + // convert message to unicode, add text + Message.Msg := TCM_SETITEMW; + TCItemA.mask := TCItemA.mask or TCIF_TEXT or RTL[UseRightToLeftReading]; + if TabSheet is TTntTabSheet then + Text := TTntTabSheet(TabSheet).Caption + else + Text := TabSheet.Caption; + TCItemA.pszText := PAnsiChar(PWideChar(Text)); + end; + end; + TCM_INSERTITEMA: + begin + TCItemA := PTCItemA(Message.lParam); + // will always be followed by TCM_SETITEMA(TCIF_PARAM) if TCIF_TEXT is present + TCItemA.mask := TCItemA.mask and (not TCIF_TEXT); + end; + end; + inherited; + end; +end; + +procedure TTntPageControl.CMDialogChar(var Message: TCMDialogChar); +var + I: Integer; + TabText: WideString; +begin + for I := 0 to PageCount - 1 do begin + if Pages[i] is TTntTabSheet then + TabText := TTntTabSheet(Pages[i]).Caption + else + TabText := Pages[i].Caption; + if IsWideCharAccel(Message.CharCode, TabText) and CanShowTab(Pages[i].TabIndex) and CanFocus then + begin + Message.Result := 1; + if CanChange then + begin + TabIndex := Pages[i].TabIndex; + Change; + end; + Exit; + end; + end; + Broadcast(Message); +end; + +procedure TTntPageControl.CMDockClient(var Message: TCMDockClient); +var + IsVisible: Boolean; + DockCtl: TControl; +begin + Message.Result := 0; + FNewDockSheet := TTntTabSheet.Create(Self); + try + try + DockCtl := Message.DockSource.Control; + if DockCtl is TCustomForm then + FNewDockSheet.Caption := TntControl_GetText(DockCtl); + FNewDockSheet.PageControl := Self; + DockCtl.Dock(Self, Message.DockSource.DockRect); + except + FNewDockSheet.Free; + raise; + end; + IsVisible := DockCtl.Visible; + FNewDockSheet.TabVisible := IsVisible; + if IsVisible then ActivePage := FNewDockSheet; + DockCtl.Align := alClient; + finally + FNewDockSheet := nil; + end; +end; + +procedure TTntPageControl.DoAddDockClient(Client: TControl; const ARect: TRect); +begin + if FNewDockSheet <> nil then + Client.Parent := FNewDockSheet; +end; + +procedure TTntPageControl.CMDockNotification(var Message: TCMDockNotification); +var + I: Integer; + S: WideString; + Page: TTabSheet{TNT-ALLOW TTabSheet}; +begin + Page := GetPageFromDockClient(Message.Client); + if (Message.NotifyRec.ClientMsg <> WM_SETTEXT) + or (Page = nil) or (not (Page is TTntTabSheet)) then + inherited + else begin + if (Message.Client is TWinControl) + and (TWinControl(Message.Client).HandleAllocated) + and IsWindowUnicode(TWinControl(Message.Client).Handle) then + S := PWideChar(Message.NotifyRec.MsgLParam) + else + S := PAnsiChar(Message.NotifyRec.MsgLParam); + { Search for first CR/LF and end string there } + for I := 1 to Length(S) do + if S[I] in [CR, LF] then + begin + SetLength(S, I - 1); + Break; + end; + TTntTabSheet(Page).Caption := S; + end; +end; + +procedure TTntPageControl.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntPageControl.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntTrackBar } + +procedure TTntTrackBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, TRACKBAR_CLASS); +end; + +procedure TTntTrackBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntTrackBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntTrackBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntTrackBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntTrackBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntTrackBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntProgressBar } + +procedure TTntProgressBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, PROGRESS_CLASS); +end; + +procedure TTntProgressBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntProgressBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntProgressBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntProgressBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntProgressBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntProgressBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomUpDown } + +procedure TTntCustomUpDown.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, UPDOWN_CLASS); +end; + +procedure TTntCustomUpDown.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomUpDown.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomUpDown.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomUpDown.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomUpDown.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomUpDown.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntDateTimePicker } + +procedure TTntDateTimePicker.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, DATETIMEPICK_CLASS); +end; + +procedure TTntDateTimePicker.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDateTimePicker.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntDateTimePicker.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntDateTimePicker.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntDateTimePicker.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntDateTimePicker.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntDateTimePicker.CreateWnd; +var + SaveChecked: Boolean; +begin + FHadFirstMouseClick := False; + SaveChecked := Checked; + inherited; + // This fixes an issue where TDateTimePicker.CNNotify causes "FChecked := True" to occur + // during window creation. This issue results in .Checked to read True even though + // it is not visually checked. + Checked := SaveChecked; +end; + +procedure TTntDateTimePicker.WMLButtonDown(var Message: TWMLButtonDown); + + procedure UpdateValues; + var + Hdr: TNMDateTimeChange; + begin + Hdr.nmhdr.hwndFrom := Handle; + Hdr.nmhdr.idFrom := 0; + Hdr.nmhdr.code := DTN_DATETIMECHANGE; + Hdr.dwFlags := DateTime_GetSystemTime(Handle, Hdr.st); + if (Hdr.dwFlags <> Cardinal(GDT_ERROR)) then begin + if Hdr.dwFlags = GDT_NONE then + ZeroMemory(@Hdr.st, SizeOf(Hdr.st)); + Perform(CN_NOTIFY, Integer(Handle), Integer(@Hdr)); + end; + end; + +begin + inherited; + if ShowCheckBox and (not FHadFirstMouseClick) then begin + FHadFirstMouseClick := True; + UpdateValues; // Sometimes the first mouse click doesn't result in WM_NOTIFY. + end; +end; + +{ TTntMonthCalendar } + +procedure TTntMonthCalendar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, MONTHCAL_CLASS); + if Win32PlatformIsUnicode then begin + { For some reason WM_NOTIFY:MCN_GETDAYSTATE never gets called. } + ForceGetMonthInfo; + end; +end; + +procedure TTntMonthCalendar.ForceGetMonthInfo; +var + Hdr: TNMDayState; + Days: array of TMonthDayState; + Range: array[1..2] of TSystemTime; +begin + // populate Days array + Hdr.nmhdr.hwndFrom := Handle; + Hdr.nmhdr.idFrom := 0; + Hdr.nmhdr.code := MCN_GETDAYSTATE; + Hdr.cDayState := MonthCal_GetMonthRange(Handle, GMR_DAYSTATE, @Range[1]); + Hdr.stStart := Range[1]; + SetLength(Days, Hdr.cDayState); + Hdr.prgDayState := @Days[0]; + SendMessage(Handle, CN_NOTIFY, Integer(Handle), Integer(@Hdr)); + // update day state + SendMessage(Handle, MCM_SETDAYSTATE, Hdr.cDayState, Longint(Hdr.prgDayState)) +end; + +procedure TTntMonthCalendar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntMonthCalendar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntMonthCalendar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntMonthCalendar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntMonthCalendar.GetDate: TDate; +begin + Result := Trunc(inherited Date); { Fixes issue where Date always reflects time of saving dfm. } +end; + +procedure TTntMonthCalendar.SetDate(const Value: TDate); +begin + inherited Date := Trunc(Value); +end; + +procedure TTntMonthCalendar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntMonthCalendar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntPageScroller } + +procedure TTntPageScroller.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_PAGESCROLLER); +end; + +procedure TTntPageScroller.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPageScroller.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntPageScroller.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntPageScroller.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntPageScroller.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntPageScroller.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntStatusPanel } + +procedure TTntStatusPanel.Assign(Source: TPersistent); +begin + inherited; + if Source is TTntStatusPanel then + Text := TTntStatusPanel(Source).Text; +end; + +procedure TTntStatusPanel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntStatusPanel.GetText: Widestring; +begin + Result := GetSyncedWideString(FText, inherited Text); +end; + +procedure TTntStatusPanel.SetInheritedText(const Value: AnsiString); +begin + inherited Text := Value; +end; + +procedure TTntStatusPanel.SetText(const Value: Widestring); +begin + SetSyncedWideString(Value, FText, inherited Text, SetInheritedText); +end; + +{ TTntStatusPanels } + +function TTntStatusPanels.GetItem(Index: Integer): TTntStatusPanel; +begin + Result := (inherited GetItem(Index)) as TTntStatusPanel; +end; + +procedure TTntStatusPanels.SetItem(Index: Integer; Value: TTntStatusPanel); +begin + inherited SetItem(Index, Value); +end; + +function TTntStatusPanels.Add: TTntStatusPanel; +begin + Result := (inherited Add) as TTntStatusPanel; +end; + +function TTntStatusPanels.AddItem(Item: TTntStatusPanel; Index: Integer): TTntStatusPanel; +begin + Result := (inherited AddItem(Item, Index)) as TTntStatusPanel; +end; + +function TTntStatusPanels.Insert(Index: Integer): TTntStatusPanel; +begin + Result := (inherited Insert(Index)) as TTntStatusPanel; +end; + +{ TTntCustomStatusBar } + +function TTntCustomStatusBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomStatusBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntCustomStatusBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomStatusBar.CreatePanels: TStatusPanels{TNT-ALLOW TStatusPanels}; +begin + Result := TTntStatusPanels.Create(Self); +end; + +function TTntCustomStatusBar.GetPanelClass: TStatusPanelClass; +begin + Result := TTntStatusPanel; +end; + +function TTntCustomStatusBar.SyncLeadingTabs(const WideVal: WideString; const AnsiVal: AnsiString): WideString; + + function CountLeadingTabs(const Val: WideString): Integer; + var + i: integer; + begin + Result := 0; + for i := 1 to Length(Val) do begin + if Val[i] <> #9 then break; + Inc(Result); + end; + end; + +var + AnsiTabCount: Integer; + WideTabCount: Integer; +begin + AnsiTabCount := CountLeadingTabs(AnsiVal); + WideTabCount := CountLeadingTabs(WideVal); + Result := WideVal; + while WideTabCount < AnsiTabCount do begin + Insert(#9, Result, 1); + Inc(WideTabCount); + end; + while WideTabCount > AnsiTabCount do begin + Delete(Result, 1, 1); + Dec(WideTabCount); + end; +end; + +function TTntCustomStatusBar.GetSimpleText: WideString; +begin + FSimpleText := SyncLeadingTabs(FSimpleText, inherited SimpleText); + Result := GetSyncedWideString(FSimpleText, inherited SimpleText); +end; + +procedure TTntCustomStatusBar.SetInheritedSimpleText(const Value: AnsiString); +begin + inherited SimpleText := Value; +end; + +procedure TTntCustomStatusBar.SetSimpleText(const Value: WideString); +begin + SetSyncedWideString(Value, FSimpleText, inherited SimpleText, SetInheritedSimpleText); +end; + +procedure TTntCustomStatusBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomStatusBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle_ComCtl(Self, Params, STATUSCLASSNAME); +end; + +procedure TTntCustomStatusBar.WndProc(var Msg: TMessage); +const + SB_SIMPLEID = Integer($FF); +var + iPart: Integer; + szText: PAnsiChar; + WideText: WideString; +begin + if Win32PlatformIsUnicode and (Msg.Msg = SB_SETTEXTA) and ((Msg.WParam and SBT_OWNERDRAW) = 0) + then begin + // convert SB_SETTEXTA message to Unicode + iPart := (Msg.WParam and SB_SIMPLEID); + szText := PAnsiChar(Msg.LParam); + if iPart = SB_SIMPLEID then + WideText := SimpleText + else if Panels.Count > 0 then + WideText := Panels[iPart].Text + else begin + WideText := szText; + end; + WideText := SyncLeadingTabs(WideText, szText); + Msg.Result := SendMessageW(Handle, SB_SETTEXTW, Msg.wParam, Integer(PWideChar(WideText))); + end else + inherited; +end; + +procedure TTntCustomStatusBar.WMGetTextLength(var Message: TWMGetTextLength); +begin + Message.Result := Length(SimpleText); +end; + +procedure TTntCustomStatusBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomStatusBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntCustomStatusBar.GetPanels: TTntStatusPanels; +begin + Result := inherited Panels as TTntStatusPanels; +end; + +procedure TTntCustomStatusBar.SetPanels(const Value: TTntStatusPanels); +begin + inherited Panels := Value; +end; + +function TTntCustomStatusBar.ExecuteAction(Action: TBasicAction): Boolean; +begin + if AutoHint and (Action is TTntHintAction) and not DoHint then + begin + if SimplePanel or (Panels.Count = 0) then + SimpleText := TTntHintAction(Action).Hint else + Panels[0].Text := TTntHintAction(Action).Hint; + Result := True; + end + else Result := inherited ExecuteAction(Action); +end; + +{ TTntStatusBar } + +function TTntStatusBar.GetOnDrawPanel: TDrawPanelEvent; +begin + Result := TDrawPanelEvent(inherited OnDrawPanel); +end; + +procedure TTntStatusBar.SetOnDrawPanel(const Value: TDrawPanelEvent); +begin + inherited OnDrawPanel := TCustomDrawPanelEvent(Value); +end; + +{ TTntTreeNode } + +function TTntTreeNode.IsEqual(Node: TTntTreeNode): Boolean; +begin + Result := (Text = Node.Text) and (Data = Node.Data); +end; + +procedure TTntTreeNode.ReadData(Stream: TStream; Info: PNodeInfo); +var + I, Size, ItemCount: Integer; + LNode: TTntTreeNode; + Utf8Text: AnsiString; +begin + Owner.ClearCache; + Stream.ReadBuffer(Size, SizeOf(Size)); + Stream.ReadBuffer(Info^, Size); + + if Pos(UTF8_BOM, Info^.Text) = 1 then begin + Utf8Text := Copy(Info^.Text, Length(UTF8_BOM) + 1, MaxInt); + try + Text := UTF8ToWideString(Utf8Text); + except + Text := Utf8Text; + end; + end else + Text := Info^.Text; + + ImageIndex := Info^.ImageIndex; + SelectedIndex := Info^.SelectedIndex; + StateIndex := Info^.StateIndex; + OverlayIndex := Info^.OverlayIndex; + Data := Info^.Data; + ItemCount := Info^.Count; + for I := 0 to ItemCount - 1 do + begin + LNode := Owner.AddChild(Self, ''); + LNode.ReadData(Stream, Info); + Owner.Owner.Added(LNode); + end; +end; + +procedure TTntTreeNode.WriteData(Stream: TStream; Info: PNodeInfo); +var + I, Size, L, ItemCount: Integer; + WideLen: Integer; Utf8Text: AnsiString; +begin + WideLen := 255; + repeat + Utf8Text := UTF8_BOM + WideStringToUTF8(Copy(Text, 1, WideLen)); + L := Length(Utf8Text); + Dec(WideLen); + until + L <= 255; + + Size := SizeOf(TNodeInfo) + L - 255; + Info^.Text := Utf8Text; + Info^.ImageIndex := ImageIndex; + Info^.SelectedIndex := SelectedIndex; + Info^.OverlayIndex := OverlayIndex; + Info^.StateIndex := StateIndex; + Info^.Data := Data; + ItemCount := Count; + Info^.Count := ItemCount; + Stream.WriteBuffer(Size, SizeOf(Size)); + Stream.WriteBuffer(Info^, Size); + for I := 0 to ItemCount - 1 do + Item[I].WriteData(Stream, Info); +end; + +procedure TTntTreeNode.Assign(Source: TPersistent); +var + Node: TTntTreeNode; +begin + inherited; + if (not Deleting) and (Source is TTntTreeNode) then + begin + Node := TTntTreeNode(Source); + Text := Node.Text; + end; +end; + +function TTntTreeNode.GetText: WideString; +begin + Result := GetSyncedWideString(FText, inherited Text); +end; + +procedure TTntTreeNode.SetInheritedText(const Value: AnsiString); +begin + inherited Text := Value; +end; + +procedure TTntTreeNode.SetText(const Value: WideString); +begin + SetSyncedWideString(Value, FText, inherited Text, SetInheritedText); +end; + +function TTntTreeNode.getFirstChild: TTntTreeNode; +begin + Result := inherited getFirstChild as TTntTreeNode; +end; + +function TTntTreeNode.GetItem(Index: Integer): TTntTreeNode; +begin + Result := inherited Item[Index] as TTntTreeNode; +end; + +procedure TTntTreeNode.SetItem(Index: Integer; const Value: TTntTreeNode); +begin + inherited Item[Index] := Value; +end; + +function TTntTreeNode.GetLastChild: TTntTreeNode; +begin + Result := inherited GetLastChild as TTntTreeNode; +end; + +function TTntTreeNode.GetNext: TTntTreeNode; +begin + Result := inherited GetNext as TTntTreeNode; +end; + +function TTntTreeNode.GetNextChild(Value: TTntTreeNode): TTntTreeNode; +begin + Result := inherited GetNextChild(Value) as TTntTreeNode; +end; + +function TTntTreeNode.getNextSibling: TTntTreeNode; +begin + Result := inherited getNextSibling as TTntTreeNode; +end; + +function TTntTreeNode.GetNextVisible: TTntTreeNode; +begin + Result := inherited GetNextVisible as TTntTreeNode; +end; + +function TTntTreeNode.GetNodeOwner: TTntTreeNodes; +begin + Result := inherited Owner as TTntTreeNodes; +end; + +function TTntTreeNode.GetParent: TTntTreeNode; +begin + Result := inherited Parent as TTntTreeNode; +end; + +function TTntTreeNode.GetPrev: TTntTreeNode; +begin + Result := inherited GetPrev as TTntTreeNode; +end; + +function TTntTreeNode.GetPrevChild(Value: TTntTreeNode): TTntTreeNode; +begin + Result := inherited GetPrevChild(Value) as TTntTreeNode; +end; + +function TTntTreeNode.getPrevSibling: TTntTreeNode; +begin + Result := inherited getPrevSibling as TTntTreeNode; +end; + +function TTntTreeNode.GetPrevVisible: TTntTreeNode; +begin + Result := inherited GetPrevVisible as TTntTreeNode; +end; + +function TTntTreeNode.GetTreeView: TTntCustomTreeView; +begin + Result := inherited TreeView as TTntCustomTreeView; +end; + +{ TTntTreeNodesEnumerator } + +constructor TTntTreeNodesEnumerator.Create(ATreeNodes: TTntTreeNodes); +begin + inherited Create; + FIndex := -1; + FTreeNodes := ATreeNodes; +end; + +function TTntTreeNodesEnumerator.GetCurrent: TTntTreeNode; +begin + Result := FTreeNodes[FIndex]; +end; + +function TTntTreeNodesEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FTreeNodes.Count - 1; + if Result then + Inc(FIndex); +end; + +{ TTntTreeNodes } + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackTreeNodes = class(TPersistent) + protected + FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; + FxxxUpdateCount: Integer; + FNodeCache: TNodeCache; + FReading: Boolean; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackTreeNodes = class(TPersistent) + protected + FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; + FxxxUpdateCount: Integer; + FNodeCache: TNodeCache; + FReading: Boolean; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackTreeNodes = class(TPersistent) + protected + FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; + FxxxUpdateCount: Integer; + FNodeCache: TNodeCache; + FReading: Boolean; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackTreeNodes = class(TPersistent) + protected + FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; + FxxxUpdateCount: Integer; + FNodeCache: TNodeCache; + FReading: Boolean; + end; +{$ENDIF} + +procedure SaveNodeTextToStrings(Nodes: TTntTreeNodes; sList: TTntStrings); +var + ANode: TTntTreeNode; +begin + sList.Clear; + if Nodes.Count > 0 then + begin + ANode := Nodes[0]; + while ANode <> nil do + begin + sList.Add(ANode.Text); + ANode := ANode.GetNext; + end; + end; +end; + +procedure TTntTreeNodes.Assign(Source: TPersistent); +var + TreeNodes: TTntTreeNodes; + MemStream: TTntMemoryStream; +begin + ClearCache; + if Source is TTntTreeNodes then + begin + TreeNodes := TTntTreeNodes(Source); + Clear; + MemStream := TTntMemoryStream.Create; + try + TreeNodes.WriteData(MemStream); + MemStream.Position := 0; + ReadData(MemStream); + finally + MemStream.Free; + end; + end else + inherited Assign(Source); +end; + +function TTntTreeNodes.GetNodeFromIndex(Index: Integer): TTntTreeNode; +begin + Result := inherited Item[Index] as TTntTreeNode; +end; + +function TTntTreeNodes.AddChildFirst(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Parent, S, nil, naAddChildFirst); +end; + +function TTntTreeNodes.AddChildObjectFirst(Parent: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Parent, S, Ptr, naAddChildFirst); +end; + +function TTntTreeNodes.AddChild(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Parent, S, nil, naAddChild); +end; + +function TTntTreeNodes.AddChildObject(Parent: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Parent, S, Ptr, naAddChild); +end; + +function TTntTreeNodes.AddFirst(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, nil, naAddFirst); +end; + +function TTntTreeNodes.AddObjectFirst(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, Ptr, naAddFirst); +end; + +function TTntTreeNodes.Add(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, nil, naAdd); +end; + +function TTntTreeNodes.AddObject(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, Ptr, naAdd); +end; + +function TTntTreeNodes.Insert(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, nil, naInsert); +end; + +function TTntTreeNodes.InsertObject(Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(nil, Sibling, S, Ptr, naInsert); +end; + +function TTntTreeNodes.InsertNode(Node, Sibling: TTntTreeNode; const S: WideString; + Ptr: Pointer): TTntTreeNode; +begin + Result := AddNode(Node, Sibling, S, Ptr, naInsert); +end; + +function TTntTreeNodes.AddNode(Node, Relative: TTntTreeNode; const S: WideString; + Ptr: Pointer; Method: TNodeAttachMode): TTntTreeNode; +begin + Result := inherited AddNode(Node, Relative, '', Ptr, Method) as TTntTreeNode; + Result.Text := S; +end; + +function TTntTreeNodes.GetNode(ItemId: HTreeItem): TTntTreeNode; +begin + Result := inherited GetNode(ItemID) as TTntTreeNode; +end; + +function TTntTreeNodes.GetFirstNode: TTntTreeNode; +begin + Result := inherited GetFirstNode as TTntTreeNode; +end; + +function TTntTreeNodes.GetEnumerator: TTntTreeNodesEnumerator; +begin + Result := TTntTreeNodesEnumerator.Create(Self); +end; + +function TTntTreeNodes.GetNodesOwner: TTntCustomTreeView; +begin + Result := inherited Owner as TTntCustomTreeView; +end; + +procedure TTntTreeNodes.ClearCache; +begin + THackTreeNodes(Self).FNodeCache.CacheNode := nil; +end; + +procedure TTntTreeNodes.DefineProperties(Filer: TFiler); + + function WriteNodes: Boolean; + var + I: Integer; + Nodes: TTntTreeNodes; + begin + Nodes := TTntTreeNodes(Filer.Ancestor); + if Nodes = nil then + Result := Count > 0 + else if Nodes.Count <> Count then + Result := True + else + begin + Result := False; + for I := 0 to Count - 1 do + begin + Result := not Item[I].IsEqual(Nodes[I]); + if Result then + Break; + end + end; + end; + +begin + inherited DefineProperties(Filer); + Filer.DefineBinaryProperty('Utf8Data', ReadData, WriteData, WriteNodes); +end; + +procedure TTntTreeNodes.ReadData(Stream: TStream); +var + I, Count: Integer; + NodeInfo: TNodeInfo; + LNode: TTntTreeNode; + LHandleAllocated: Boolean; +begin + LHandleAllocated := Owner.HandleAllocated; + if LHandleAllocated then + BeginUpdate; + THackTreeNodes(Self).FReading := True; + try + Clear; + Stream.ReadBuffer(Count, SizeOf(Count)); + for I := 0 to Count - 1 do + begin + LNode := Add(nil, ''); + LNode.ReadData(Stream, @NodeInfo); + Owner.Added(LNode); + end; + finally + THackTreeNodes(Self).FReading := False; + if LHandleAllocated then + EndUpdate; + end; +end; + +procedure TTntTreeNodes.WriteData(Stream: TStream); +var + I: Integer; + Node: TTntTreeNode; + NodeInfo: TNodeInfo; +begin + I := 0; + Node := GetFirstNode; + while Node <> nil do + begin + Inc(I); + Node := Node.GetNextSibling; + end; + Stream.WriteBuffer(I, SizeOf(I)); + Node := GetFirstNode; + while Node <> nil do + begin + Node.WriteData(Stream, @NodeInfo); + Node := Node.GetNextSibling; + end; +end; + +{ TTntTreeStrings } + +type + TTntTreeStrings = class(TTntStringList) + protected + function GetBufStart(Buffer: PWideChar; var Level: Integer): PWideChar; + public + procedure SaveToTree(Tree: TTntCustomTreeView); + procedure LoadFromTree(Tree: TTntCustomTreeView); + end; + +function TTntTreeStrings.GetBufStart(Buffer: PWideChar; var Level: Integer): PWideChar; +begin + Level := 0; + while Buffer^ in [WideChar(' '), WideChar(#9)] do + begin + Inc(Buffer); + Inc(Level); + end; + Result := Buffer; +end; + +procedure TTntTreeStrings.SaveToTree(Tree: TTntCustomTreeView); +var + ANode, NextNode: TTntTreeNode; + ALevel, i: Integer; + CurrStr: WideString; + Owner: TTntTreeNodes; +begin + Owner := Tree.Items; + Owner.BeginUpdate; + try + try + Owner.Clear; + ANode := nil; + for i := 0 to Count - 1 do + begin + CurrStr := GetBufStart(PWideChar(Strings[i]), ALevel); + if ANode = nil then + ANode := Owner.AddChild(nil, CurrStr) + else if ANode.Level = ALevel then + ANode := Owner.AddChild(ANode.Parent, CurrStr) + else if ANode.Level = (ALevel - 1) then + ANode := Owner.AddChild(ANode, CurrStr) + else if ANode.Level > ALevel then + begin + NextNode := ANode.Parent; + while NextNode.Level > ALevel do + NextNode := NextNode.Parent; + ANode := Owner.AddChild(NextNode.Parent, CurrStr); + end + else + raise ETreeViewError.CreateFmt(sInvalidLevelEx, [ALevel, CurrStr]); + end; + finally + Owner.EndUpdate; + end; + except + Owner.Owner.Invalidate; // force repaint on exception + raise; + end; +end; + +procedure TTntTreeStrings.LoadFromTree(Tree: TTntCustomTreeView); +const + TabChar = #9; +var + i: Integer; + ANode: TTntTreeNode; + NodeStr: WideString; + Owner: TTntTreeNodes; +begin + Clear; + Owner := Tree.Items; + if Owner.Count > 0 then + begin + ANode := Owner[0]; + while ANode <> nil do + begin + NodeStr := ''; + for i := 0 to ANode.Level - 1 do NodeStr := NodeStr + TabChar; + NodeStr := NodeStr + ANode.Text; + Add(NodeStr); + ANode := ANode.GetNext; + end; + end; +end; + +{ _TntInternalCustomTreeView } + +function _TntInternalCustomTreeView.FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; +begin + Result := Wide_FindNextToSelect; +end; + +function _TntInternalCustomTreeView.Inherited_FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; +begin + Result := inherited FindNextToSelect; +end; + +{ TTntCustomTreeView } + +function TntDefaultTreeViewSort(Node1, Node2: TTntTreeNode; lParam: Integer): Integer; stdcall; +begin + with Node1 do + if Assigned(TreeView.OnCompare) then + TreeView.OnCompare(TreeView, Node1, Node2, lParam, Result) + else Result := lstrcmpw(PWideChar(Node1.Text), PWideChar(Node2.Text)); +end; + +constructor TTntCustomTreeView.Create(AOwner: TComponent); +begin + inherited; + FEditInstance := Classes.MakeObjectInstance(EditWndProcW); +end; + +destructor TTntCustomTreeView.Destroy; +begin + Destroying; + Classes.FreeObjectInstance(FEditInstance); + FreeAndNil(FSavedNodeText); + inherited; +end; + +var + ComCtrls_DefaultTreeViewSort: TTVCompare = nil; + +procedure TTntCustomTreeView.CreateWindowHandle(const Params: TCreateParams); + + procedure Capture_ComCtrls_DefaultTreeViewSort; + begin + FTestingForSortProc := True; + try + AlphaSort; + finally + FTestingForSortProc := False; + end; + end; + +begin + CreateUnicodeHandle_ComCtl(Self, Params, WC_TREEVIEW); + if (Win32PlatformIsUnicode) then begin + if not Assigned(ComCtrls_DefaultTreeViewSort) then + Capture_ComCtrls_DefaultTreeViewSort; + end; +end; + +procedure TTntCustomTreeView.CreateWnd; +begin + inherited; + if FSavedNodeText <> nil then begin + FreeAndNil(FSavedNodeText); + SortType := FSavedSortType; + end; +end; + +procedure TTntCustomTreeView.DestroyWnd; +begin + if (not (csDestroying in ComponentState)) then begin + FSavedNodeText := TTntStringList.Create; + FSavedSortType := SortType; + SortType := stNone; // when recreating window, we are expecting items to come back in same order + SaveNodeTextToStrings(Items, FSavedNodeText); + end; + inherited; +end; + +procedure TTntCustomTreeView.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomTreeView.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomTreeView.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomTreeView.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomTreeView.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomTreeView.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntCustomTreeView.CreateNode: TTreeNode{TNT-ALLOW TTreeNode}; +var + LClass: TClass; + TntLClass: TTntTreeNodeClass; +begin + LClass := TTntTreeNode; + if Assigned(OnCreateNodeClass) then + OnCreateNodeClass(Self, TTreeNodeClass(LClass)); + if not LClass.InheritsFrom(TTntTreeNode) then + raise ETntInternalError.Create('Internal Error: OnCreateNodeClass.ItemClass must inherit from TTntTreeNode.'); + TntLClass := TTntTreeNodeClass(LClass); + Result := TntLClass.Create(inherited Items); +end; + +function TTntCustomTreeView.CreateNodes: TTreeNodes{TNT-ALLOW TTreeNodes}; +begin + Result := TTntTreeNodes.Create(Self); +end; + +function TTntCustomTreeView.GetTreeNodes: TTntTreeNodes; +begin + Result := inherited Items as TTntTreeNodes; +end; + +procedure TTntCustomTreeView.SetTreeNodes(const Value: TTntTreeNodes); +begin + Items.Assign(Value); +end; + +function TTntCustomTreeView.GetNodeFromItem(const Item: TTVItem): TTntTreeNode; +begin + Result := nil; + if Items <> nil then + with Item do + if (state and TVIF_PARAM) <> 0 then + Result := Pointer(lParam) + else + Result := Items.GetNode(hItem); +end; + +function TTntCustomTreeView.Wide_FindNextToSelect: TTntTreeNode; +begin + Result := FindNextToSelect; +end; + +function TTntCustomTreeView.FindNextToSelect: TTntTreeNode; +begin + Result := Inherited_FindNextToSelect as TTntTreeNode; +end; + +function TTntCustomTreeView.GetDropTarget: TTntTreeNode; +begin + Result := inherited DropTarget as TTntTreeNode; +end; + +function TTntCustomTreeView.GetNodeAt(X, Y: Integer): TTntTreeNode; +begin + Result := inherited GetNodeAt(X, Y) as TTntTreeNode; +end; + +function TTntCustomTreeView.GetSelected: TTntTreeNode; +begin + Result := inherited Selected as TTntTreeNode; +end; + +function TTntCustomTreeView.GetSelection(Index: Integer): TTntTreeNode; +begin + Result := inherited Selections[Index] as TTntTreeNode; +end; + +function TTntCustomTreeView.GetSelections(AList: TList): TTntTreeNode; +begin + Result := inherited GetSelections(AList) as TTntTreeNode; +end; + +function TTntCustomTreeView.GetTopItem: TTntTreeNode; +begin + Result := inherited TopItem as TTntTreeNode; +end; + +procedure TTntCustomTreeView.SetDropTarget(const Value: TTntTreeNode); +begin + inherited DropTarget := Value; +end; + +procedure TTntCustomTreeView.SetSelected(const Value: TTntTreeNode); +begin + inherited Selected := Value; +end; + +procedure TTntCustomTreeView.SetTopItem(const Value: TTntTreeNode); +begin + inherited TopItem := Value; +end; + +procedure TTntCustomTreeView.WndProc(var Message: TMessage); +type + PTVSortCB = ^TTVSortCB; +begin + with Message do begin + // capture ANSI version of DefaultTreeViewSort from ComCtrls + if (FTestingForSortProc) + and (Msg = TVM_SORTCHILDRENCB) then begin + ComCtrls_DefaultTreeViewSort := PTVSortCB(lParam).lpfnCompare; + exit; + end; + + if (Win32PlatformIsUnicode) + and (Msg = TVM_SORTCHILDRENCB) + and (@PTVSortCB(lParam).lpfnCompare = @ComCtrls_DefaultTreeViewSort) then + begin + // Unicode:: call wide version of sort proc instead + PTVSortCB(lParam)^.lpfnCompare := TTVCompare(@TntDefaultTreeViewSort); + Result := SendMessageW(Handle, TVM_SORTCHILDRENCB, wParam, lParam); + end else + inherited; + end; +end; + +procedure TTntCustomTreeView.CNNotify(var Message: TWMNotify); +var + Node: TTntTreeNode; +begin + if (not Win32PlatformIsUnicode) then + inherited + else begin + with Message do begin + case NMHdr^.code of + TVN_BEGINDRAGW: + begin + NMHdr^.code := TVN_BEGINDRAGA; + try + inherited; + finally + NMHdr^.code := TVN_BEGINDRAGW; + end; + end; + TVN_BEGINLABELEDITW: + begin + with PTVDispInfo(NMHdr)^ do + if Dragging or not CanEdit(GetNodeFromItem(item)) then + Result := 1; + if Result = 0 then + begin + FEditHandle := TreeView_GetEditControl(Handle); + FDefEditProc := Pointer(GetWindowLongW(FEditHandle, GWL_WNDPROC)); + SetWindowLongW(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance)); + end; + end; + TVN_ENDLABELEDITW: + Edit(PTVDispInfo(NMHdr)^.item); + TVN_ITEMEXPANDINGW: + begin + NMHdr^.code := TVN_ITEMEXPANDINGA; + try + inherited; + finally + NMHdr^.code := TVN_ITEMEXPANDINGW; + end; + end; + TVN_ITEMEXPANDEDW: + begin + NMHdr^.code := TVN_ITEMEXPANDEDA; + try + inherited; + finally + NMHdr^.code := TVN_ITEMEXPANDEDW; + end; + end; + TVN_DELETEITEMW: + begin + NMHdr^.code := TVN_DELETEITEMA; + try + inherited; + finally + NMHdr^.code := TVN_DELETEITEMW; + end; + end; + TVN_SETDISPINFOW: + with PTVDispInfo(NMHdr)^ do + begin + Node := GetNodeFromItem(item); + if (Node <> nil) and ((item.mask and TVIF_TEXT) <> 0) then + Node.Text := TTVItemW(item).pszText; + end; + TVN_GETDISPINFOW: + with PTVDispInfo(NMHdr)^ do + begin + Node := GetNodeFromItem(item); + if Node <> nil then + begin + if (item.mask and TVIF_TEXT) <> 0 then begin + if (FSavedNodeText <> nil) + and (FSavedNodeText.Count > 0) + and (AnsiString(FSavedNodeText[0]) = AnsiString(Node.Text)) then + begin + Node.FText := FSavedNodeText[0]; // recover saved text + FSavedNodeText.Delete(0); + end; + WStrLCopy(TTVItemW(item).pszText, PWideChar(Node.Text), item.cchTextMax - 1); + end; + + if (item.mask and TVIF_IMAGE) <> 0 then + begin + GetImageIndex(Node); + item.iImage := Node.ImageIndex; + end; + if (item.mask and TVIF_SELECTEDIMAGE) <> 0 then + begin + GetSelectedIndex(Node); + item.iSelectedImage := Node.SelectedIndex; + end; + end; + end; + else + inherited; + end; + end; + end; +end; + +procedure TTntCustomTreeView.WMNotify(var Message: TWMNotify); +var + Node: TTntTreeNode; + FWideText: WideString; + MaxTextLen: Integer; + Pt: TPoint; +begin + with Message do + if NMHdr^.code = TTN_NEEDTEXTW then + begin + // Work around NT COMCTL32 problem with tool tips >= 80 characters + GetCursorPos(Pt); + Pt := ScreenToClient(Pt); + Node := GetNodeAt(Pt.X, Pt.Y); + if (Node = nil) or (Node.Text = '') or + (PToolTipTextW(NMHdr)^.uFlags and TTF_IDISHWND = 0) then Exit; + if (GetComCtlVersion >= ComCtlVersionIE4) + or {Borland's VCL wrongly uses "and"} (Length(Node.Text) < 80) then + begin + DefaultHandler(Message); + Exit; + end; + FWideText := Node.Text; + MaxTextLen := SizeOf(PToolTipTextW(NMHdr)^.szText) div SizeOf(WideChar); + if Length(FWideText) >= MaxTextLen then + SetLength(FWideText, MaxTextLen - 1); + PToolTipTextW(NMHdr)^.lpszText := PWideChar(FWideText); + FillChar(PToolTipTextW(NMHdr)^.szText, MaxTextLen, 0); + Move(Pointer(FWideText)^, PToolTipTextW(NMHdr)^.szText, Length(FWideText) * SizeOf(WideChar)); + PToolTipTextW(NMHdr)^.hInst := 0; + SetWindowPos(NMHdr^.hwndFrom, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE or + SWP_NOSIZE or SWP_NOMOVE or SWP_NOOWNERZORDER); + Result := 1; + end + else inherited; +end; + +procedure TTntCustomTreeView.Edit(const Item: TTVItem); +var + S: WideString; + AnsiS: AnsiString; + Node: TTntTreeNode; + AnsiEvent: TTVEditedEvent; +begin + with Item do + begin + Node := GetNodeFromItem(Item); + if pszText <> nil then + begin + if Win32PlatformIsUnicode then + S := TTVItemW(Item).pszText + else + S := pszText; + + if Assigned(FOnEdited) then + FOnEdited(Self, Node, S) + else if Assigned(inherited OnEdited) then + begin + AnsiEvent := inherited OnEdited; + AnsiS := S; + AnsiEvent(Self, Node, AnsiS); + S := AnsiS; + end; + + if Node <> nil then Node.Text := S; + end + else if Assigned(OnCancelEdit) then + OnCancelEdit(Self, Node); + end; +end; + +procedure TTntCustomTreeView.EditWndProcW(var Message: TMessage); +begin + Assert(Win32PlatformIsUnicode); + try + with Message do + begin + case Msg of + WM_KEYDOWN, + WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit; + WM_CHAR: + begin + MakeWMCharMsgSafeForAnsi(Message); + try + if DoKeyPress(TWMKey(Message)) then Exit; + finally + RestoreWMCharMsg(Message); + end; + end; + WM_KEYUP, + WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit; + CN_KEYDOWN, + CN_CHAR, CN_SYSKEYDOWN, + CN_SYSCHAR: + begin + WndProc(Message); + Exit; + end; + end; + Result := CallWindowProcW(FDefEditProc, FEditHandle, Msg, WParam, LParam); + end; + except + Application.HandleException(Self); + end; +end; + +procedure TTntCustomTreeView.LoadFromFile(const FileName: WideString); +var + TreeStrings: TTntTreeStrings; +begin + TreeStrings := TTntTreeStrings.Create; + try + TreeStrings.LoadFromFile(FileName); + TreeStrings.SaveToTree(Self); + finally + TreeStrings.Free; + end; +end; + +procedure TTntCustomTreeView.LoadFromStream(Stream: TStream); +var + TreeStrings: TTntTreeStrings; +begin + TreeStrings := TTntTreeStrings.Create; + try + TreeStrings.LoadFromStream(Stream); + TreeStrings.SaveToTree(Self); + finally + TreeStrings.Free; + end; +end; + +procedure TTntCustomTreeView.SaveToFile(const FileName: WideString); +var + TreeStrings: TTntTreeStrings; +begin + TreeStrings := TTntTreeStrings.Create; + try + TreeStrings.LoadFromTree(Self); + TreeStrings.SaveToFile(FileName); + finally + TreeStrings.Free; + end; +end; + +procedure TTntCustomTreeView.SaveToStream(Stream: TStream); +var + TreeStrings: TTntTreeStrings; +begin + TreeStrings := TTntTreeStrings.Create; + try + TreeStrings.LoadFromTree(Self); + TreeStrings.SaveToStream(Stream); + finally + TreeStrings.Free; + end; +end; + +initialization + +finalization + if Assigned(AIMM) then + AIMM.Deactivate; + if FRichEdit20Module <> 0 then + FreeLibrary(FRichEdit20Module); + +end. diff --git a/Source/TntCompilers.inc b/Source/TntCompilers.inc new file mode 100644 index 0000000..5ab1390 --- /dev/null +++ b/Source/TntCompilers.inc @@ -0,0 +1,356 @@ +//---------------------------------------------------------------------------------------------------------------------- +// Include file to determine which compiler is currently being used to build the project/component. +// This file uses ideas from Brad Stowers DFS.inc file (www.delphifreestuff.com). +// +// Portions created by Mike Lischke are Copyright +// (C) 1999-2002 Dipl. Ing. Mike Lischke. All Rights Reserved. +//---------------------------------------------------------------------------------------------------------------------- +// The following symbols are defined: +// +// COMPILER_1 : Kylix/Delphi/BCB 1.x is the compiler. +// COMPILER_1_UP : Kylix/Delphi/BCB 1.x or higher is the compiler. +// COMPILER_2 : Kylix/Delphi 2.x or BCB 1.x is the compiler. +// COMPILER_2_UP : Kylix/Delphi 2.x or higher, or BCB 1.x or higher is the compiler. +// COMPILER_3 : Kylix/Delphi/BCB 3.x is the compiler. +// COMPILER_3_UP : Kylix/Delphi/BCB 3.x or higher is the compiler. +// COMPILER_4 : Kylix/Delphi/BCB 4.x is the compiler. +// COMPILER_4_UP : Kylix/Delphi/BCB 4.x or higher is the compiler. +// COMPILER_5 : Kylix/Delphi/BCB 5.x is the compiler. +// COMPILER_5_UP : Kylix/Delphi/BCB 5.x or higher is the compiler. +// COMPILER_6 : Kylix/Delphi/BCB 6.x is the compiler. +// COMPILER_6_UP : Kylix/Delphi/BCB 6.x or higher is the compiler. +// COMPILER_7 : Kylix/Delphi/BCB 7.x is the compiler. +// COMPILER_7_UP : Kylix/Delphi/BCB 7.x or higher is the compiler. +// +// Only defined if Windows is the target: +// CPPB : Any version of BCB is being used. +// CPPB_1 : BCB v1.x is being used. +// CPPB_3 : BCB v3.x is being used. +// CPPB_3_UP : BCB v3.x or higher is being used. +// CPPB_4 : BCB v4.x is being used. +// CPPB_4_UP : BCB v4.x or higher is being used. +// CPPB_5 : BCB v5.x is being used. +// CPPB_5_UP : BCB v5.x or higher is being used. +// CPPB_6 : BCB v6.x is being used. +// CPPB_6_UP : BCB v6.x or higher is being used. +// +// Only defined if Windows is the target: +// DELPHI : Any version of Delphi is being used. +// DELPHI_1 : Delphi v1.x is being used. +// DELPHI_2 : Delphi v2.x is being used. +// DELPHI_2_UP : Delphi v2.x or higher is being used. +// DELPHI_3 : Delphi v3.x is being used. +// DELPHI_3_UP : Delphi v3.x or higher is being used. +// DELPHI_4 : Delphi v4.x is being used. +// DELPHI_4_UP : Delphi v4.x or higher is being used. +// DELPHI_5 : Delphi v5.x is being used. +// DELPHI_5_UP : Delphi v5.x or higher is being used. +// DELPHI_6 : Delphi v6.x is being used. +// DELPHI_6_UP : Delphi v6.x or higher is being used. +// DELPHI_7 : Delphi v7.x is being used. +// DELPHI_7_UP : Delphi v7.x or higher is being used. +// +// Only defined if Linux is the target: +// KYLIX : Any version of Kylix is being used. +// KYLIX_1 : Kylix 1.x is being used. +// KYLIX_1_UP : Kylix 1.x or higher is being used. +// KYLIX_2 : Kylix 2.x is being used. +// KYLIX_2_UP : Kylix 2.x or higher is being used. +// KYLIX_3 : Kylix 3.x is being used. +// KYLIX_3_UP : Kylix 3.x or higher is being used. +// +// Only defined if Linux is the target: +// QT_CLX : Trolltech's QT library is being used. +//---------------------------------------------------------------------------------------------------------------------- + +{$ifdef Win32} + + {$ifdef VER180} + {$define COMPILER_10} + {$define DELPHI} + {$define DELPHI_10} + {$endif} + + {$ifdef VER170} + {$define COMPILER_9} + {$define DELPHI} + {$define DELPHI_9} + {$endif} + + {$ifdef VER150} + {$define COMPILER_7} + {$define DELPHI} + {$define DELPHI_7} + {$endif} + + {$ifdef VER140} + {$define COMPILER_6} + {$ifdef BCB} + {$define CPPB} + {$define CPPB_6} + {$else} + {$define DELPHI} + {$define DELPHI_6} + {$endif} + {$endif} + + {$ifdef VER130} + {$define COMPILER_5} + {$ifdef BCB} + {$define CPPB} + {$define CPPB_5} + {$else} + {$define DELPHI} + {$define DELPHI_5} + {$endif} + {$endif} + + {$ifdef VER125} + {$define COMPILER_4} + {$define CPPB} + {$define CPPB_4} + {$endif} + + {$ifdef VER120} + {$define COMPILER_4} + {$define DELPHI} + {$define DELPHI_4} + {$endif} + + {$ifdef VER110} + {$define COMPILER_3} + {$define CPPB} + {$define CPPB_3} + {$endif} + + {$ifdef VER100} + {$define COMPILER_3} + {$define DELPHI} + {$define DELPHI_3} + {$endif} + + {$ifdef VER93} + {$define COMPILER_2} // C++ Builder v1 compiler is really v2 + {$define CPPB} + {$define CPPB_1} + {$endif} + + {$ifdef VER90} + {$define COMPILER_2} + {$define DELPHI} + {$define DELPHI_2} + {$endif} + + {$ifdef VER80} + {$define COMPILER_1} + {$define DELPHI} + {$define DELPHI_1} + {$endif} + + {$ifdef DELPHI_2} + {$define DELPHI_2_UP} + {$endif} + + {$ifdef DELPHI_3} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$endif} + + {$ifdef DELPHI_4} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$endif} + + {$ifdef DELPHI_5} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$endif} + + {$ifdef DELPHI_6} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$endif} + + {$ifdef DELPHI_7} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$endif} + + {$ifdef DELPHI_9} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_9_UP} + {$endif} + + {$ifdef DELPHI_10} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_9_UP} + {$define DELPHI_10_UP} + {$endif} + + {$ifdef CPPB_3} + {$define CPPB_3_UP} + {$endif} + + {$ifdef CPPB_4} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$endif} + + {$ifdef CPPB_5} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$define CPPB_5_UP} + {$endif} + + {$ifdef CPPB_6} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$define CPPB_5_UP} + {$define CPPB_6_UP} + {$endif} + + {$ifdef CPPB_3_UP} + // C++ Builder requires this if you use Delphi components in run-time packages. + {$ObjExportAll On} + {$endif} + +{$else (not Windows)} + // Linux is the target + {$define QT_CLX} + + {$define KYLIX} + {$define KYLIX_1} + {$define KYLIX_1_UP} + + {$ifdef VER150} + {$define COMPILER_7} + {$define KYLIX_3} + {$endif} + + {$ifdef VER140} + {$define COMPILER_6} + {$define KYLIX_2} + {$endif} + + {$ifdef KYLIX_2} + {$define KYLIX_2_UP} + {$endif} + + {$ifdef KYLIX_3} + {$define KYLIX_2_UP} + {$define KYLIX_3_UP} + {$endif} + +{$endif} + +// Compiler defines common to all platforms. +{$ifdef COMPILER_1} + {$define COMPILER_1_UP} +{$endif} + +{$ifdef COMPILER_2} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} +{$endif} + +{$ifdef COMPILER_3} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} +{$endif} + +{$ifdef COMPILER_4} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} +{$endif} + +{$ifdef COMPILER_5} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} +{$endif} + +{$ifdef COMPILER_6} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} +{$endif} + +{$ifdef COMPILER_7} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} +{$endif} + +{$ifdef COMPILER_9} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} + {$define COMPILER_9_UP} +{$endif} + +{$ifdef COMPILER_10} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} + {$define COMPILER_9_UP} + {$define COMPILER_10_UP} +{$endif} + +//---------------------------------------------------------------------------------------------------------------------- + +{$ALIGN ON} +{$BOOLEVAL OFF} + +{$ifdef COMPILER_7_UP} + {$define THEME_7_UP} { Allows experimental theme support on pre-Delphi 7. } +{$endif} + +{$IFDEF COMPILER_6_UP} +{$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! } +{$ENDIF} + +{$IFDEF COMPILER_7_UP} +{$WARN UNSAFE_CODE OFF} { We are not going to be "safe"! } +{$WARN UNSAFE_TYPE OFF} +{$WARN UNSAFE_CAST OFF} +{$ENDIF} \ No newline at end of file diff --git a/Source/TntControls.pas b/Source/TntControls.pas new file mode 100644 index 0000000..55025ec --- /dev/null +++ b/Source/TntControls.pas @@ -0,0 +1,1099 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntControls; + +{$INCLUDE TntCompilers.inc} + +{ + Windows NT provides support for native Unicode windows. To add Unicode support to a + TWinControl descendant, override CreateWindowHandle() and call CreateUnicodeHandle(). + + One major reason this works is because the VCL only uses the ANSI version of + SendMessage() -- SendMessageA(). If you call SendMessageA() on a UNICODE + window, Windows deals with the ANSI/UNICODE conversion automatically. So + for example, if the VCL sends WM_SETTEXT to a window using SendMessageA, + Windows actually *expects* a PAnsiChar even if the target window is a UNICODE + window. So caling SendMessageA with PChars causes no problems. + + A problem in the VCL has to do with the TControl.Perform() method. Perform() + calls the window procedure directly and assumes an ANSI window. This is a + problem if, for example, the VCL calls Perform(WM_SETTEXT, ...) passing in a + PAnsiChar which eventually gets passed downto DefWindowProcW() which expects a PWideChar. + + This is the reason for SubClassUnicodeControl(). This procedure will subclass the + Windows WndProc, and the TWinControl.WindowProc pointer. It will determine if the + message came from Windows or if the WindowProc was called directly. It will then + call SendMessageA() for Windows to perform proper conversion on certain text messages. + + Another problem has to do with TWinControl.DoKeyPress(). It is called from the WM_CHAR + message. It casts the WideChar to an AnsiChar, and sends the resulting character to + DefWindowProc. In order to avoid this, the DefWindowProc is subclassed as well. WindowProc + will make a WM_CHAR message safe for ANSI handling code by converting the char code to + #FF before passing it on. It stores the original WideChar in the .Unused field of TWMChar. + The code #FF is converted back to the WideChar before passing onto DefWindowProc. +} + +{ + Things to consider when designing new controls: + 1) Check that a WideString Hint property is published. + 2) If descending from TWinControl, override CreateWindowHandle(). + 3) If not descending from TWinControl, handle CM_HINTSHOW message. + 4) Check to make sure that CN_CHAR, CN_SYSCHAR and CM_DIALOGCHAR are handled properly. + 5) If descending from TWinControl, verify Unicode chars are preserved after RecreateWnd. + 6) Consider using storage specifiers for Hint and Caption properties. + 7) If any class could possibly have published WideString properties, + override DefineProperties and call TntPersistent_AfterInherited_DefineProperties. + 8) Check if TTntThemeManager needs to be updated. + 9) Override GetActionLinkClass() and ActionChange(). + 10) If class updates Application.Hint then update TntApplication.Hint instead. +} + +interface + +{ TODO: Unicode enable .OnKeyPress event } + +uses + Classes, Windows, Messages, Controls, Menus; + + +{TNT-WARN TCaption} +type TWideCaption = type WideString; + +// caption/text management +function TntControl_IsCaptionStored(Control: TControl): Boolean; +function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString; +procedure TntControl_SetStoredText(Control: TControl; const Value: WideString); +function TntControl_GetText(Control: TControl): WideString; +procedure TntControl_SetText(Control: TControl; const Text: WideString); + +// hint management +function TntControl_IsHintStored(Control: TControl): Boolean; +function TntControl_GetHint(Control: TControl): WideString; +procedure TntControl_SetHint(Control: TControl; const Value: WideString); + +function WideGetHint(Control: TControl): WideString; +function WideGetShortHint(const Hint: WideString): WideString; +function WideGetLongHint(const Hint: WideString): WideString; +procedure ProcessCMHintShowMsg(var Message: TMessage); + +type + TTntCustomHintWindow = class(THintWindow) + private + FActivating: Boolean; + FBlockPaint: Boolean; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; +{$IFNDEF COMPILER_7_UP} + procedure CreateParams(var Params: TCreateParams); override; +{$ENDIF} + procedure Paint; override; + public + procedure ActivateHint(Rect: TRect; const AHint: AnsiString); override; + procedure ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); override; + function CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; override; + property Caption: TWideCaption read GetCaption write SetCaption; + end; + + TTntHintWindow = class(TTntCustomHintWindow) + public + procedure ActivateHint(Rect: TRect; const AHint: WideString); reintroduce; + procedure ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); reintroduce; + function CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; reintroduce; + end; + +// text/char message +function IsTextMessage(Msg: UINT): Boolean; +procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage); +procedure RestoreWMCharMsg(var Message: TMessage); +function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar; +procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar); + +// register/create window +procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False); +procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False); +procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams; + const SubClass: WideString; IDEWindow: Boolean = False); +procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False); + +type + IWideCustomListControl = interface + ['{C1801F41-51E9-4DB5-8DB8-58AC86698C2E}'] + procedure AddItem(const Item: WideString; AObject: TObject); + end; + +procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject); + +var + _IsShellProgramming: Boolean = False; + +var + TNT_WM_DESTROY: Cardinal; + +implementation + +uses + ActnList, Forms, SysUtils, Contnrs, + TntGraphics, TntWindows, TntClasses, TntMenus, TntSysUtils; + +type + TAccessControl = class(TControl); + TAccessWinControl = class(TWinControl); + TAccessControlActionLink = class(TControlActionLink{TNT-ALLOW TControlActionLink}); + +//----------------------------------------------- WIDE CAPTION HOLDERS -------- + +{ TWideControlHelper } + +var + WideControlHelpers: TComponentList = nil; + +type + TWideControlHelper = class(TWideComponentHelper) + private + FControl: TControl; + FWideCaption: WideString; + FWideHint: WideString; + procedure SetAnsiText(const Value: AnsiString); + procedure SetAnsiHint(const Value: AnsiString); + public + constructor Create(AOwner: TControl); reintroduce; + property WideCaption: WideString read FWideCaption; + property WideHint: WideString read FWideHint; + end; + +constructor TWideControlHelper.Create(AOwner: TControl); +begin + inherited CreateHelper(AOwner, WideControlHelpers); + FControl := AOwner; +end; + +procedure TWideControlHelper.SetAnsiText(const Value: AnsiString); +begin + TAccessControl(FControl).Text := Value; +end; + +procedure TWideControlHelper.SetAnsiHint(const Value: AnsiString); +begin + FControl.Hint := Value; +end; + +function FindWideControlHelper(Control: TControl; CreateIfNotFound: Boolean = True): TWideControlHelper; +begin + Result := TWideControlHelper(FindWideComponentHelper(WideControlHelpers, Control)); + if (Result = nil) and CreateIfNotFound then + Result := TWideControlHelper.Create(Control); +end; + +//----------------------------------------------- GET/SET WINDOW CAPTION/HINT ------------- + +function TntControl_IsCaptionStored(Control: TControl): Boolean; +begin + with TAccessControl(Control) do + Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsCaptionLinked; +end; + +function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString; +var + WideControlHelper: TWideControlHelper; +begin + WideControlHelper := FindWideControlHelper(Control, False); + if WideControlHelper <> nil then + Result := WideControlHelper.WideCaption + else + Result := Default; +end; + +procedure TntControl_SetStoredText(Control: TControl; const Value: WideString); +begin + FindWideControlHelper(Control).FWideCaption := Value; + TAccessControl(Control).Text := Value; +end; + +function TntControl_GetText(Control: TControl): WideString; +var + WideControlHelper: TWideControlHelper; +begin + if (not Win32PlatformIsUnicode) + or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then + // Win9x / non-unicode handle + Result := TAccessControl(Control).Text + else if (not (Control is TWinControl)) then begin + // non-windowed TControl + WideControlHelper := FindWideControlHelper(Control, False); + if WideControlHelper = nil then + Result := TAccessControl(Control).Text + else + Result := GetSyncedWideString(WideControlHelper.FWideCaption, TAccessControl(Control).Text); + end else if (not TWinControl(Control).HandleAllocated) then begin + // NO HANDLE + Result := TntControl_GetStoredText(Control, TAccessControl(Control).Text) + end else begin + // UNICODE & HANDLE + SetLength(Result, GetWindowTextLengthW(TWinControl(Control).Handle) + 1); + GetWindowTextW(TWinControl(Control).Handle, PWideChar(Result), Length(Result)); + SetLength(Result, Length(Result) - 1); + end; +end; + +procedure TntControl_SetText(Control: TControl; const Text: WideString); +begin + if (not Win32PlatformIsUnicode) + or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then + // Win9x / non-unicode handle + TAccessControl(Control).Text := Text + else if (not (Control is TWinControl)) then begin + // non-windowed TControl + with FindWideControlHelper(Control) do + SetSyncedWideString(Text, FWideCaption, TAccessControl(Control).Text, SetAnsiText) + end else if (not TWinControl(Control).HandleAllocated) then begin + // NO HANDLE + TntControl_SetStoredText(Control, Text); + end else if TntControl_GetText(Control) <> Text then begin + // UNICODE & HANDLE + Tnt_SetWindowTextW(TWinControl(Control).Handle, PWideChar(Text)); + Control.Perform(CM_TEXTCHANGED, 0, 0); + end; +end; + +// hint management ----------------------------------------------------------------------- + +function TntControl_IsHintStored(Control: TControl): Boolean; +begin + with TAccessControl(Control) do + Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsHintLinked; +end; + +function TntControl_GetHint(Control: TControl): WideString; +var + WideControlHelper: TWideControlHelper; +begin + if (not Win32PlatformIsUnicode) then + Result := Control.Hint + else begin + WideControlHelper := FindWideControlHelper(Control, False); + if WideControlHelper <> nil then + Result := GetSyncedWideString(WideControlHelper.FWideHint, Control.Hint) + else + Result := Control.Hint; + end; +end; + +procedure TntControl_SetHint(Control: TControl; const Value: WideString); +begin + if (not Win32PlatformIsUnicode) then + Control.Hint := Value + else + with FindWideControlHelper(Control) do + SetSyncedWideString(Value, FWideHint, Control.Hint, SetAnsiHint); +end; + +function WideGetHint(Control: TControl): WideString; +begin + while Control <> nil do + if TntControl_GetHint(Control) = '' then + Control := Control.Parent + else + begin + Result := TntControl_GetHint(Control); + Exit; + end; + Result := ''; +end; + +function WideGetShortHint(const Hint: WideString): WideString; +var + I: Integer; +begin + I := Pos('|', Hint); + if I = 0 then + Result := Hint else + Result := Copy(Hint, 1, I - 1); +end; + +function WideGetLongHint(const Hint: WideString): WideString; +var + I: Integer; +begin + I := Pos('|', Hint); + if I = 0 then + Result := Hint else + Result := Copy(Hint, I + 1, Maxint); +end; + +//---------------------------------------------------------------------------------------- + +var UnicodeCreationControl: TWinControl = nil; + +function IsUnicodeCreationControl(Handle: HWND): Boolean; +begin + Result := (UnicodeCreationControl <> nil) + and (UnicodeCreationControl.HandleAllocated) + and (UnicodeCreationControl.Handle = Handle); +end; + +function WMNotifyFormatResult(FromHandle: HWND): Integer; +begin + if Win32PlatformIsUnicode + and (IsWindowUnicode(FromHandle) or IsUnicodeCreationControl(FromHandle)) then + Result := NFR_UNICODE + else + Result := NFR_ANSI; +end; + +function IsTextMessage(Msg: UINT): Boolean; +begin + // WM_CHAR is omitted because of the special handling it receives + Result := (Msg = WM_SETTEXT) + or (Msg = WM_GETTEXT) + or (Msg = WM_GETTEXTLENGTH); +end; + +const + ANSI_UNICODE_HOLDER = $FF; + +procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage); +begin + with TWMChar(Message) do begin + Assert(Msg = WM_CHAR); + if not _IsShellProgramming then + Assert(Unused = 0) + else begin + Assert((Unused = 0) or (CharCode <= Word(High(AnsiChar)))); + // When a Unicode control is embedded under non-Delphi Unicode + // window something strange happens + if (Unused <> 0) then begin + CharCode := (Unused shl 8) or CharCode; + end; + end; + if (CharCode > Word(High(AnsiChar))) then begin + Unused := CharCode; + CharCode := ANSI_UNICODE_HOLDER; + end; + end; +end; + +procedure RestoreWMCharMsg(var Message: TMessage); +begin + with TWMChar(Message) do begin + Assert(Message.Msg = WM_CHAR); + if (Unused > 0) + and (CharCode = ANSI_UNICODE_HOLDER) then + CharCode := Unused; + Unused := 0; + end; +end; + +function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar; +begin + if (Message.CharCode = ANSI_UNICODE_HOLDER) + and (Message.Unused <> 0) then + Result := WideChar(Message.Unused) + else + Result := WideChar(Message.CharCode); +end; + +procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar); +begin + Message.CharCode := Word(Ch); + Message.Unused := 0; + MakeWMCharMsgSafeForAnsi(TMessage(Message)); +end; + +//----------------------------------------------------------------------------------- +type + TWinControlTrap = class(TComponent) + private + WinControl_ObjectInstance: Pointer; + ObjectInstance: Pointer; + DefObjectInstance: Pointer; + function IsInSubclassChain(Control: TWinControl): Boolean; + procedure SubClassWindowProc; + private + FControl: TAccessWinControl; + Handle: THandle; + PrevWin32Proc: Pointer; + PrevDefWin32Proc: Pointer; + PrevWindowProc: TWndMethod; + private + LastWin32Msg: UINT; + Win32ProcLevel: Integer; + IDEWindow: Boolean; + DestroyTrap: Boolean; + TestForNull: Boolean; + FoundNull: Boolean; + {$IFDEF TNT_VERIFY_WINDOWPROC} + LastVerifiedWindowProc: TWndMethod; + {$ENDIF} + procedure Win32Proc(var Message: TMessage); + procedure DefWin32Proc(var Message: TMessage); + procedure WindowProc(var Message: TMessage); + private + procedure SubClassControl(Params_Caption: PAnsiChar); + procedure UnSubClassUnicodeControl; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + +constructor TWinControlTrap.Create(AOwner: TComponent); +begin + FControl := TAccessWinControl(AOwner as TWinControl); + inherited Create(nil); + FControl.FreeNotification(Self); + + WinControl_ObjectInstance := Classes.MakeObjectInstance(FControl.MainWndProc); + ObjectInstance := Classes.MakeObjectInstance(Win32Proc); + DefObjectInstance := Classes.MakeObjectInstance(DefWin32Proc); +end; + +destructor TWinControlTrap.Destroy; +begin + Classes.FreeObjectInstance(ObjectInstance); + Classes.FreeObjectInstance(DefObjectInstance); + Classes.FreeObjectInstance(WinControl_ObjectInstance); + inherited; +end; + +procedure TWinControlTrap.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (AComponent = FControl) and (Operation = opRemove) then begin + FControl := nil; + if Win32ProcLevel = 0 then + Free + else + DestroyTrap := True; + end; +end; + +procedure TWinControlTrap.SubClassWindowProc; +begin + if not IsInSubclassChain(FControl) then begin + PrevWindowProc := FControl.WindowProc; + FControl.WindowProc := Self.WindowProc; + end; + {$IFDEF TNT_VERIFY_WINDOWPROC} + LastVerifiedWindowProc := FControl.WindowProc; + {$ENDIF} +end; + +procedure TWinControlTrap.SubClassControl(Params_Caption: PAnsiChar); +begin + // initialize trap object + Handle := FControl.Handle; + PrevWin32Proc := Pointer(GetWindowLongW(FControl.Handle, GWL_WNDPROC)); + PrevDefWin32Proc := FControl.DefWndProc; + + // subclass Window Procedures + SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(ObjectInstance)); + FControl.DefWndProc := DefObjectInstance; + SubClassWindowProc; + + // For some reason, caption gets garbled after calling SetWindowLongW(.., GWL_WNDPROC). + TntControl_SetText(FControl, TntControl_GetStoredText(FControl, Params_Caption)); +end; + +function SameWndMethod(A, B: TWndMethod): Boolean; +begin + Result := @A = @B; +end; + +var + PendingRecreateWndTrapList: TComponentList = nil; + +procedure TWinControlTrap.UnSubClassUnicodeControl; +begin + // remember caption for future window creation + if not (csDestroying in FControl.ComponentState) then + TntControl_SetStoredText(FControl, TntControl_GetText(FControl)); + + // restore window procs (restore WindowProc only if we are still the direct subclass) + if SameWndMethod(FControl.WindowProc, Self.WindowProc) then + FControl.WindowProc := PrevWindowProc; + TAccessWinControl(FControl).DefWndProc := PrevDefWin32Proc; + SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(PrevWin32Proc)); + + if IDEWindow then + DestroyTrap := True + else if not (csDestroying in FControl.ComponentState) then + // control not being destroyed, probably recreating window + PendingRecreateWndTrapList.Add(Self); +end; + +var + Finalized: Boolean; { If any tnt controls are still around after finalization it must be due to a memory leak. + Windows will still try to send a WM_DESTROY, but we will just ignore it if we're finalized. } + +procedure TWinControlTrap.Win32Proc(var Message: TMessage); +begin + if (not Finalized) then begin + Inc(Win32ProcLevel); + try + with Message do begin + {$IFDEF TNT_VERIFY_WINDOWPROC} + if not SameWndMethod(FControl.WindowProc, LastVerifiedWindowProc) then begin + SubClassWindowProc; + LastVerifiedWindowProc := FControl.WindowProc; + end; + {$ENDIF} + LastWin32Msg := Msg; + Result := CallWindowProcW(PrevWin32Proc, Handle, Msg, wParam, lParam); + end; + finally + Dec(Win32ProcLevel); + end; + if (Win32ProcLevel = 0) and (DestroyTrap) then + Free; + end else if (Message.Msg = WM_DESTROY) or (Message.Msg = TNT_WM_DESTROY) then + FControl.WindowHandle := 0 +end; + +procedure TWinControlTrap.DefWin32Proc(var Message: TMessage); + + function IsChildEdit(AHandle: HWND): Boolean; + var + AHandleClass: WideString; + begin + Result := False; + if (FControl.Handle = GetParent(Handle)) then begin + // child control + SetLength(AHandleClass, 255); + SetLength(AHandleClass, GetClassNameW(AHandle, PWideChar(AHandleClass), Length(AHandleClass))); + Result := WideSameText(AHandleClass, 'EDIT'); + end; + end; + +begin + with Message do begin + if Msg = WM_NOTIFYFORMAT then + Result := WMNotifyFormatResult(HWND(Message.wParam)) + else begin + if (Msg = WM_CHAR) then begin + RestoreWMCharMsg(Message) + end; + if (Msg = WM_IME_CHAR) and (not _IsShellProgramming) and (not Win32PlatformIsXP) then + begin + { In Windows XP, DefWindowProc handles WM_IME_CHAR fine for VCL windows. } + { Before XP, DefWindowProc will sometimes produce incorrect, non-Unicode WM_CHAR. } + { Also, using PostMessageW on Windows 2000 didn't always produce the correct results. } + Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam) + end else if (Msg = WM_IME_CHAR) and (_IsShellProgramming) then begin + { When a Tnt control is hosted by a non-delphi control, DefWindowProc doesn't always work even on XP. } + if IsChildEdit(Handle) then + Message.Result := Integer(PostMessageW(Handle, WM_CHAR, wParam, lParam)) // native edit child control + else + Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam); + end else begin + if (Msg = WM_DESTROY) then begin + UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. } + end; + { Normal DefWindowProc } + Result := CallWindowProcW(PrevDefWin32Proc, Handle, Msg, wParam, lParam); + end; + end; + end; +end; + +procedure ProcessCMHintShowMsg(var Message: TMessage); +begin + if Win32PlatformIsUnicode then begin + with TCMHintShow(Message) do begin + if (HintInfo.HintWindowClass = THintWindow) + or (HintInfo.HintWindowClass.InheritsFrom(TTntCustomHintWindow)) then begin + if (HintInfo.HintWindowClass = THintWindow) then + HintInfo.HintWindowClass := TTntCustomHintWindow; + HintInfo.HintData := HintInfo; + HintInfo.HintStr := WideGetShortHint(WideGetHint(HintInfo.HintControl)); + end; + end; + end; +end; + +function TWinControlTrap.IsInSubclassChain(Control: TWinControl): Boolean; +var + Message: TMessage; +begin + if SameWndMethod(Control.WindowProc, TAccessWinControl(Control).WndProc) then + Result := False { no subclassing } + else if SameWndMethod(Control.WindowProc, Self.WindowProc) then + Result := True { directly subclassed } + else begin + TestForNull := True; + FoundNull := False; + ZeroMemory(@Message, SizeOf(Message)); + Message.Msg := WM_NULL; + Control.WindowProc(Message); + Result := FoundNull; { indirectly subclassed } + end; +end; + +procedure TWinControlTrap.WindowProc(var Message: TMessage); +var + CameFromWindows: Boolean; +begin + if TestForNull and (Message.Msg = WM_NULL) then + FoundNull := True; + + if (not FControl.HandleAllocated) then + FControl.WndProc(Message) + else begin + CameFromWindows := LastWin32Msg <> WM_NULL; + LastWin32Msg := WM_NULL; + with Message do begin + if Msg = CM_HINTSHOW then + ProcessCMHintShowMsg(Message); + if (not CameFromWindows) + and (IsTextMessage(Msg)) then + Result := SendMessageA(Handle, Msg, wParam, lParam) + else begin + if (Msg = WM_CHAR) then begin + MakeWMCharMsgSafeForAnsi(Message); + end; + PrevWindowProc(Message) + end; + if (Msg = TNT_WM_DESTROY) then + UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. } + end; + end; +end; + +//---------------------------------------------------------------------------------- + +function FindOrCreateWinControlTrap(Control: TWinControl): TWinControlTrap; +var + i: integer; +begin + // find or create trap object + Result := nil; + for i := PendingRecreateWndTrapList.Count - 1 downto 0 do begin + if TWinControlTrap(PendingRecreateWndTrapList[i]).FControl = Control then begin + Result := TWinControlTrap(PendingRecreateWndTrapList[i]); + PendingRecreateWndTrapList.Delete(i); + break; { found it } + end; + end; + if Result = nil then + Result := TWinControlTrap.Create(Control); +end; + +procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False); +var + WinControlTrap: TWinControlTrap; +begin + if not IsWindowUnicode(Control.Handle) then + raise ETntInternalError.Create('Internal Error: SubClassUnicodeControl.Control is not Unicode.'); + + WinControlTrap := FindOrCreateWinControlTrap(Control); + WinControlTrap.SubClassControl(Params_Caption); + WinControlTrap.IDEWindow := IDEWindow; +end; + + +//----------------------------------------------- CREATE/DESTROY UNICODE HANDLE + +var + WindowAtom: TAtom; + ControlAtom: TAtom; + WindowAtomString: AnsiString; + ControlAtomString: AnsiString; + +type + TWndProc = function(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; + +function InitWndProcW(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; + + function GetObjectInstance(Control: TWinControl): Pointer; + var + WinControlTrap: TWinControlTrap; + begin + WinControlTrap := FindOrCreateWinControlTrap(Control); + PendingRecreateWndTrapList.Add(WinControlTrap); + Result := WinControlTrap.WinControl_ObjectInstance; + end; + +var + ObjectInstance: Pointer; +begin + TAccessWinControl(CreationControl).WindowHandle := HWindow; + ObjectInstance := GetObjectInstance(CreationControl); + {Controls.InitWndProc converts control to ANSI here by calling SetWindowLongA()!} + SetWindowLongW(HWindow, GWL_WNDPROC, Integer(ObjectInstance)); + if (GetWindowLongW(HWindow, GWL_STYLE) and WS_CHILD <> 0) + and (GetWindowLongW(HWindow, GWL_ID) = 0) then + SetWindowLongW(HWindow, GWL_ID, Integer(HWindow)); + SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl)); + SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl)); + CreationControl := nil; + Result := TWndProc(ObjectInstance)(HWindow, Message, WParam, lParam); +end; + +procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False); +const + UNICODE_CLASS_EXT = '.UnicodeClass'; +var + TempClass: TWndClassW; + WideClass: TWndClassW; + ClassRegistered: Boolean; + InitialProc: TFNWndProc; +begin + if IDEWindow then + InitialProc := @InitWndProc + else + InitialProc := @InitWndProcW; + + with Params do begin + WideWinClassName := WinClassName + UNICODE_CLASS_EXT; + ClassRegistered := GetClassInfoW(hInstance, PWideChar(WideWinClassName), TempClass); + if (not ClassRegistered) or (TempClass.lpfnWndProc <> InitialProc) + then begin + if ClassRegistered then Win32Check(Windows.UnregisterClassW(PWideChar(WideWinClassName), hInstance)); + // Prepare a TWndClassW record + WideClass := TWndClassW(WindowClass); + WideClass.hInstance := hInstance; + WideClass.lpfnWndProc := InitialProc; + if not Tnt_Is_IntResource(PWideChar(WindowClass.lpszMenuName)) then begin + WideClass.lpszMenuName := PWideChar(WideString(WindowClass.lpszMenuName)); + end; + WideClass.lpszClassName := PWideChar(WideWinClassName); + + // Register the UNICODE class + if RegisterClassW(WideClass) = 0 then RaiseLastOSError; + end; + end; +end; + +procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams; + const SubClass: WideString; IDEWindow: Boolean = False); +var + TempSubClass: TWndClassW; + WideWinClassName: WideString; + Handle: THandle; +begin + if (not Win32PlatformIsUnicode) then begin + with Params do + TAccessWinControl(Control).WindowHandle := CreateWindowEx(ExStyle, WinClassName, + Caption, Style, X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param); + end else begin + // SubClass the unicode version of this control by getting the correct DefWndProc + if (SubClass <> '') + and GetClassInfoW(Params.WindowClass.hInstance, PWideChar(SubClass), TempSubClass) then + TAccessWinControl(Control).DefWndProc := TempSubClass.lpfnWndProc + else + TAccessWinControl(Control).DefWndProc := @DefWindowProcW; + + // make sure Unicode window class is registered + RegisterUnicodeClass(Params, WideWinClassName, IDEWindow); + + // Create UNICODE window handle + UnicodeCreationControl := Control; + try + with Params do + Handle := CreateWindowExW(ExStyle, PWideChar(WideWinClassName), nil, + Style, X, Y, Width, Height, WndParent, 0, hInstance, Param); + if Handle = 0 then + RaiseLastOSError; + TAccessWinControl(Control).WindowHandle := Handle; + if IDEWindow then + SetWindowLongW(Handle, GWL_WNDPROC, GetWindowLong(Handle, GWL_WNDPROC)); + finally + UnicodeCreationControl := nil; + end; + + SubClassUnicodeControl(Control, Params.Caption, IDEWindow); + end; +end; + +procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False); +var + WasFocused: Boolean; + Params: TCreateParams; +begin + with TAccessWinControl(Control) do begin + WasFocused := Focused; + DestroyHandle; + CreateParams(Params); + CreationControl := Control; + CreateUnicodeHandle(Control, Params, SubClass, IDEWindow); + StrDispose{TNT-ALLOW StrDispose}(WindowText); + WindowText := nil; + Perform(WM_SETFONT, Integer(Font.Handle), 1); + if AutoSize then AdjustSize; + UpdateControlState; + if WasFocused and (WindowHandle <> 0) then Windows.SetFocus(WindowHandle); + end; +end; + +{ TTntCustomHintWindow procs } + +function DataPointsToHintInfoForTnt(AData: Pointer): Boolean; +begin + try + Result := (AData <> nil) + and (PHintInfo(AData).HintData = AData) {points to self} + and (PHintInfo(AData).HintWindowClass.InheritsFrom(TTntCustomHintWindow)); + except + Result := False; + end; +end; + +function ExtractTntHintCaption(AData: Pointer): WideString; +var + Control: TControl; + WideHint: WideString; + AnsiHintWithShortCut: AnsiString; + ShortCut: TShortCut; +begin + Result := PHintInfo(AData).HintStr; + if Result <> '' then begin + Control := PHintInfo(AData).HintControl; + WideHint := WideGetShortHint(WideGetHint(Control)); + if (AnsiString(WideHint) = PHintInfo(AData).HintStr) then + Result := WideHint + else if Application.HintShortCuts and (Control <> nil) + and (Control.Action is TCustomAction{TNT-ALLOW TCustomAction}) then begin + ShortCut := TCustomAction{TNT-ALLOW TCustomAction}(Control.Action).ShortCut; + if (ShortCut <> scNone) then + begin + AnsiHintWithShortCut := Format{TNT-ALLOW Format}('%s (%s)', [WideHint, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut)]); + if AnsiHintWithShortCut = PHintInfo(AData).HintStr then + Result := WideFormat('%s (%s)', [WideHint, WideShortCutToText(ShortCut)]); + end; + end; + end; +end; + +{ TTntCustomHintWindow } + +procedure TTntCustomHintWindow.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +{$IFNDEF COMPILER_7_UP} +procedure TTntCustomHintWindow.CreateParams(var Params: TCreateParams); +const + CS_DROPSHADOW = $00020000; +begin + inherited; + if Win32PlatformIsXP then { Enable drop shadow effect on Windows XP and later. } + Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW; +end; +{$ENDIF} + +function TTntCustomHintWindow.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomHintWindow.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomHintWindow.Paint; +var + R: TRect; +begin + if FBlockPaint then + exit; + if (not Win32PlatformIsUnicode) then + inherited + else begin + R := ClientRect; + Inc(R.Left, 2); + Inc(R.Top, 2); + Canvas.Font.Color := Screen.HintFont.Color; + Tnt_DrawTextW(Canvas.Handle, PWideChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or + DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly); + end; +end; + +procedure TTntCustomHintWindow.CMTextChanged(var Message: TMessage); +begin + { Avoid flicker when calling ActivateHint } + if FActivating then Exit; + Width := WideCanvasTextWidth(Canvas, Caption) + 6; + Height := WideCanvasTextHeight(Canvas, Caption) + 6; +end; + +procedure TTntCustomHintWindow.ActivateHint(Rect: TRect; const AHint: AnsiString); +var + SaveActivating: Boolean; +begin + SaveActivating := FActivating; + try + FActivating := True; + inherited; + finally + FActivating := SaveActivating; + end; +end; + +procedure TTntCustomHintWindow.ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); +var + SaveActivating: Boolean; +begin + if (not Win32PlatformIsUnicode) + or (not DataPointsToHintInfoForTnt(AData)) then + inherited + else begin + FBlockPaint := True; + try + SaveActivating := FActivating; + try + FActivating := True; + inherited; + Caption := ExtractTntHintCaption(AData); + finally + FActivating := SaveActivating; + end; + finally + FBlockPaint := False; + end; + Invalidate; + end; +end; + +function TntHintWindow_CalcHintRect(HintWindow: TTntCustomHintWindow; MaxWidth: Integer; const AHint: WideString): TRect; +begin + Result := Rect(0, 0, MaxWidth, 0); + Tnt_DrawTextW(HintWindow.Canvas.Handle, PWideChar(AHint), -1, Result, DT_CALCRECT or DT_LEFT or + DT_WORDBREAK or DT_NOPREFIX or HintWindow.DrawTextBiDiModeFlagsReadingOnly); + Inc(Result.Right, 6); + Inc(Result.Bottom, 2); +end; + +function TTntCustomHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; +var + WideHintStr: WideString; +begin + if (not Win32PlatformIsUnicode) + or (not DataPointsToHintInfoForTnt(AData)) then + Result := inherited CalcHintRect(MaxWidth, AHint, AData) + else begin + WideHintStr := ExtractTntHintCaption(AData); + Result := TntHintWindow_CalcHintRect(Self, MaxWidth, WideHintStr); + end; +end; + +{ TTntHintWindow } + +procedure TTntHintWindow.ActivateHint(Rect: TRect; const AHint: WideString); +var + SaveActivating: Boolean; +begin + SaveActivating := FActivating; + try + FActivating := True; + Caption := AHint; + inherited ActivateHint(Rect, AHint); + finally + FActivating := SaveActivating; + end; +end; + +procedure TTntHintWindow.ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); +var + SaveActivating: Boolean; +begin + FBlockPaint := True; + try + SaveActivating := FActivating; + try + FActivating := True; + Caption := AHint; + inherited ActivateHintData(Rect, AHint, AData); + finally + FActivating := SaveActivating; + end; + finally + FBlockPaint := False; + end; + Invalidate; +end; + +function TTntHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; +begin + Result := TntHintWindow_CalcHintRect(Self, MaxWidth, AHint); +end; + +procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject); +var + WideControl: IWideCustomListControl; +begin + if Control.GetInterface(IWideCustomListControl, WideControl) then + WideControl.AddItem(Item, AObject) + else + Control.AddItem(Item, AObject); +end; + +procedure InitControls; + + procedure InitAtomStrings_D6_D7_D9; + var + Controls_HInstance: Cardinal; + begin + Controls_HInstance := FindClassHInstance(TWinControl); + WindowAtomString := Format{TNT-ALLOW Format}('Delphi%.8X',[GetCurrentProcessID]); + ControlAtomString := Format{TNT-ALLOW Format}('ControlOfs%.8X%.8X', [Controls_HInstance, GetCurrentThreadID]); + end; + + {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + procedure InitAtomStrings; + begin + InitAtomStrings_D6_D7_D9; + end; + {$ENDIF} + {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + procedure InitAtomStrings; + begin + InitAtomStrings_D6_D7_D9; + end; + {$ENDIF} + {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + procedure InitAtomStrings; + begin + InitAtomStrings_D6_D7_D9; + end; + {$ENDIF} + {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + procedure InitAtomStrings; + begin + InitAtomStrings_D6_D7_D9; + end; + {$ENDIF} + +begin + InitAtomStrings; + WindowAtom := WinCheckH(GlobalAddAtom(PAnsiChar(WindowAtomString))); + ControlAtom := WinCheckH(GlobalAddAtom(PAnsiChar(ControlAtomString))); +end; + +initialization + TNT_WM_DESTROY := RegisterWindowMessage('TntUnicodeVcl.DestroyWindow'); + WideControlHelpers := TComponentList.Create(True); + PendingRecreateWndTrapList := TComponentList.Create(False); + InitControls; + +finalization + GlobalDeleteAtom(ControlAtom); + GlobalDeleteAtom(WindowAtom); + FreeAndNil(WideControlHelpers); + FreeAndNil(PendingRecreateWndTrapList); + Finalized := True; + +end. diff --git a/Source/TntDB.pas b/Source/TntDB.pas new file mode 100644 index 0000000..4490bd1 --- /dev/null +++ b/Source/TntDB.pas @@ -0,0 +1,900 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDB; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, DB; + +type +{TNT-WARN TDateTimeField} + TTntDateTimeField = class(TDateTimeField{TNT-ALLOW TDateTimeField}) + protected + procedure SetAsString(const Value: AnsiString); override; + end; + +{TNT-WARN TDateField} + TTntDateField = class(TDateField{TNT-ALLOW TDateField}) + protected + procedure SetAsString(const Value: AnsiString); override; + end; + +{TNT-WARN TTimeField} + TTntTimeField = class(TTimeField{TNT-ALLOW TTimeField}) + protected + procedure SetAsString(const Value: AnsiString); override; + end; + + TFieldGetWideTextEvent = procedure(Sender: TField; var Text: WideString; + DoDisplayText: Boolean) of object; + TFieldSetWideTextEvent = procedure(Sender: TField; const Text: WideString) of object; + + IWideStringField = interface + ['{679C5F1A-4356-4696-A8F3-9C7C6970A9F6}'] + {$IFNDEF COMPILER_10_UP} + function GetAsWideString: WideString; + procedure SetAsWideString(const Value: WideString); + {$ENDIF} + function GetWideDisplayText: WideString; + function GetWideEditText: WideString; + procedure SetWideEditText(const Value: WideString); + //-- + {$IFNDEF COMPILER_10_UP} + property AsWideString: WideString read GetAsWideString write SetAsWideString{inherited}; + {$ENDIF} + property WideDisplayText: WideString read GetWideDisplayText; + property WideText: WideString read GetWideEditText write SetWideEditText; + end; + +{TNT-WARN TWideStringField} + TTntWideStringField = class(TWideStringField{TNT-ALLOW TWideStringField}, IWideStringField) + private + FOnGetText: TFieldGetWideTextEvent; + FOnSetText: TFieldSetWideTextEvent; + procedure SetOnGetText(const Value: TFieldGetWideTextEvent); + procedure SetOnSetText(const Value: TFieldSetWideTextEvent); + procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); + procedure LegacySetText(Sender: TField; const AnsiText: AnsiString); + function GetWideDisplayText: WideString; + function GetWideEditText: WideString; + procedure SetWideEditText(const Value: WideString); + protected + {$IFNDEF COMPILER_10_UP} + function GetAsWideString: WideString; + {$ENDIF} + public + property Value: WideString read GetAsWideString write SetAsWideString; + property DisplayText{TNT-ALLOW DisplayText}: WideString read GetWideDisplayText; + property Text: WideString read GetWideEditText write SetWideEditText; + {$IFNDEF COMPILER_10_UP} + property AsWideString: WideString read GetAsWideString write SetAsWideString; + {$ENDIF} + property WideDisplayText: WideString read GetWideDisplayText; + property WideText: WideString read GetWideEditText write SetWideEditText; + published + property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText; + property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText; + end; + + TTntStringFieldEncodingMode = (emNone, emUTF8, emUTF7, emFixedCodePage, emFixedCodePage_Safe); + + //------------------------------------------------------------------------------------------- + // Comments on TTntStringFieldEncodingMode: + // + // emNone - Works like TStringField. + // emUTF8 - Should work well most databases. + // emUTF7 - Almost guaranteed to work with any database. Wasteful in database space. + // emFixedCodePage - Only tested it with Access 97, which doesn't support Unicode. + // emFixedCodePage_Safe - Like emFixedCodePage but uses char<=#128. Wasteful in database space. + // + // Only emUTF8 and emUTF7 fully support Unicode. + //------------------------------------------------------------------------------------------- + + TTntStringFieldCodePageEnum = (fcpOther, + fcpThai, fcpJapanese, fcpSimplifiedChinese, fcpTraditionalChinese, fcpKorean, + fcpCentralEuropean, fcpCyrillic, fcpLatinWestern, fcpGreek, fcpTurkish, + fcpHebrew, fcpArabic, fcpBaltic, fcpVietnamese); + +const + TntStringFieldCodePageEnumMap: array[TTntStringFieldCodePageEnum] of Word = (0, + 874, 932, 936, 950, 949, + 1250, 1251, 1252, 1253, 1254, + 1255, 1256, 1257, 1258); + +type +{TNT-WARN TStringField} + TTntStringField = class(TStringField{TNT-ALLOW TStringField},IWideStringField) + private + FOnGetText: TFieldGetWideTextEvent; + FOnSetText: TFieldSetWideTextEvent; + FEncodingMode: TTntStringFieldEncodingMode; + FFixedCodePage: Word; + FRawVariantAccess: Boolean; + procedure SetOnGetText(const Value: TFieldGetWideTextEvent); + procedure SetOnSetText(const Value: TFieldSetWideTextEvent); + procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); + procedure LegacySetText(Sender: TField; const AnsiText: AnsiString); + function GetWideDisplayText: WideString; + function GetWideEditText: WideString; + procedure SetWideEditText(const Value: WideString); + function GetFixedCodePageEnum: TTntStringFieldCodePageEnum; + procedure SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); + function IsFixedCodePageStored: Boolean; + protected + {$IFDEF COMPILER_10_UP} + function GetAsWideString: WideString; override; + procedure SetAsWideString(const Value: WideString); override; + {$ELSE} + function GetAsWideString: WideString; virtual; + procedure SetAsWideString(const Value: WideString); virtual; + {$ENDIF} + function GetAsVariant: Variant; override; + procedure SetVarValue(const Value: Variant); override; + function GetAsString: string{TNT-ALLOW string}; override; + procedure SetAsString(const Value: string{TNT-ALLOW string}); override; + public + constructor Create(AOwner: TComponent); override; + property Value: WideString read GetAsWideString write SetAsWideString; + property DisplayText{TNT-ALLOW DisplayText}: WideString read GetWideDisplayText; + property Text: WideString read GetWideEditText write SetWideEditText; + {$IFNDEF COMPILER_10_UP} + property AsWideString: WideString read GetAsWideString write SetAsWideString; + {$ENDIF} + property WideDisplayText: WideString read GetWideDisplayText; + property WideText: WideString read GetWideEditText write SetWideEditText; + published + property EncodingMode: TTntStringFieldEncodingMode read FEncodingMode write FEncodingMode default emUTF8; + property FixedCodePageEnum: TTntStringFieldCodePageEnum read GetFixedCodePageEnum write SetFixedCodePageEnum stored False; + property FixedCodePage: Word read FFixedCodePage write FFixedCodePage stored IsFixedCodePageStored; + property RawVariantAccess: Boolean read FRawVariantAccess write FRawVariantAccess default False; + property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText; + property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText; + end; + +//====================== +type +{TNT-WARN TMemoField} + TTntMemoField = class(TMemoField{TNT-ALLOW TMemoField}, IWideStringField) + private + FOnGetText: TFieldGetWideTextEvent; + FOnSetText: TFieldSetWideTextEvent; + FEncodingMode: TTntStringFieldEncodingMode; + FFixedCodePage: Word; + FRawVariantAccess: Boolean; + procedure SetOnGetText(const Value: TFieldGetWideTextEvent); + procedure SetOnSetText(const Value: TFieldSetWideTextEvent); + procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); + procedure LegacySetText(Sender: TField; const AnsiText: AnsiString); + function GetWideDisplayText: WideString; + function GetWideEditText: WideString; + procedure SetWideEditText(const Value: WideString); + function GetFixedCodePageEnum: TTntStringFieldCodePageEnum; + procedure SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); + function IsFixedCodePageStored: Boolean; + protected + {$IFDEF COMPILER_10_UP} + function GetAsWideString: WideString; override; + procedure SetAsWideString(const Value: WideString); override; + {$ELSE} + function GetAsWideString: WideString; virtual; + procedure SetAsWideString(const Value: WideString); virtual; + {$ENDIF} + function GetAsVariant: Variant; override; + procedure SetVarValue(const Value: Variant); override; + function GetAsString: string{TNT-ALLOW string}; override; + procedure SetAsString(const Value: string{TNT-ALLOW string}); override; + public + constructor Create(AOwner: TComponent); override; + property Value: WideString read GetAsWideString write SetAsWideString; + property DisplayText{TNT-ALLOW DisplayText}: WideString read GetWideDisplayText; + property Text: WideString read GetWideEditText write SetWideEditText; + {$IFNDEF COMPILER_10_UP} + property AsWideString: WideString read GetAsWideString write SetAsWideString; + {$ENDIF} + property WideDisplayText: WideString read GetWideDisplayText; + property WideText: WideString read GetWideEditText write SetWideEditText; + published + property EncodingMode: TTntStringFieldEncodingMode read FEncodingMode write FEncodingMode default emUTF8; + property FixedCodePageEnum: TTntStringFieldCodePageEnum read GetFixedCodePageEnum write SetFixedCodePageEnum stored False; + property FixedCodePage: Word read FFixedCodePage write FFixedCodePage stored IsFixedCodePageStored; + property RawVariantAccess: Boolean read FRawVariantAccess write FRawVariantAccess default False; + property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText; + property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText; + end; + +//====================== +function GetTntFieldClass(FieldClass: TFieldClass): TFieldClass; + +function GetWideDisplayName(Field: TField): WideString; deprecated; // for Unicode-enabled functionality, use Delphi 2006 or newer +function GetWideDisplayLabel(Field: TField): WideString; deprecated; // for Unicode-enabled functionality, use Delphi 2006 or newer +procedure SetWideDisplayLabel(Field: TField; const Value: WideString); deprecated; // for Unicode-enabled functionality, use Delphi 2006 or newer + +{TNT-WARN AsString} +{TNT-WARN DisplayText} + +function GetAsWideString(Field: TField): WideString; +procedure SetAsWideString(Field: TField; const Value: WideString); + +function GetWideDisplayText(Field: TField): WideString; + +function GetWideText(Field: TField): WideString; +procedure SetWideText(Field: TField; const Value: WideString); + +procedure RegisterTntFields; + +{ TTntWideStringField / TTntStringField common handlers } +procedure TntWideStringField_GetWideText(Field: TField; + var Text: WideString; DoDisplayText: Boolean); +function TntWideStringField_GetWideDisplayText(Field: TField; + OnGetText: TFieldGetWideTextEvent): WideString; +function TntWideStringField_GetWideEditText(Field: TField; + OnGetText: TFieldGetWideTextEvent): WideString; +procedure TntWideStringField_SetWideText(Field: TField; + const Value: WideString); +procedure TntWideStringField_SetWideEditText(Field: TField; + OnSetText: TFieldSetWideTextEvent; const Value: WideString); + + +implementation + +uses + SysUtils, MaskUtils, Variants, Contnrs, TntSystem, TntSysUtils; + +function GetTntFieldClass(FieldClass: TFieldClass): TFieldClass; +begin + if FieldClass = TDateTimeField{TNT-ALLOW TDateTimeField} then + Result := TTntDateTimeField + else if FieldClass = TDateField{TNT-ALLOW TDateField} then + Result := TTntDateField + else if FieldClass = TTimeField{TNT-ALLOW TTimeField} then + Result := TTntTimeField + else if FieldClass = TWideStringField{TNT-ALLOW TWideStringField} then + Result := TTntWideStringField + else if FieldClass = TStringField{TNT-ALLOW TStringField} then + Result := TTntStringField + else + Result := FieldClass; +end; + +function GetWideDisplayName(Field: TField): WideString; +begin + Result := Field.DisplayName; +end; + +function GetWideDisplayLabel(Field: TField): WideString; +begin + Result := Field.DisplayLabel; +end; + +procedure SetWideDisplayLabel(Field: TField; const Value: WideString); +begin + Field.DisplayLabel := Value; +end; + +function GetAsWideString(Field: TField): WideString; +{$IFDEF COMPILER_10_UP} +begin + if (Field.ClassType = TMemoField{TNT-ALLOW TMemoField}) then + Result := VarToWideStr(Field.AsVariant) { works for NexusDB BLOB Wide } + else + Result := Field.AsWideString +end; +{$ELSE} +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + Result := WideField.AsWideString + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) then + begin + if Field.IsNull then + // This fixes a bug in TWideStringField.GetAsWideString which does not handle Null at all. + Result := '' + else + Result := TWideStringField{TNT-ALLOW TWideStringField}(Field).Value + end else if (Field is TMemoField{TNT-ALLOW TMemoField}) then + Result := VarToWideStr(Field.AsVariant) { works for NexusDB BLOB Wide } + else + Result := Field.AsString{TNT-ALLOW AsString}; +end; +{$ENDIF} + +procedure SetAsWideString(Field: TField; const Value: WideString); +{$IFDEF COMPILER_10_UP} +begin + if (Field.ClassType = TMemoField{TNT-ALLOW TMemoField}) then + Field.AsVariant := Value { works for NexusDB BLOB Wide } + else + Field.AsWideString := Value; +end; +{$ELSE} +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + WideField.AsWideString := Value + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) then + TWideStringField{TNT-ALLOW TWideStringField}(Field).Value := Value + else if (Field is TMemoField{TNT-ALLOW TMemoField}) then + Field.AsVariant := Value { works for NexusDB BLOB Wide } + else + Field.AsString{TNT-ALLOW AsString} := Value; +end; +{$ENDIF} + +function GetWideDisplayText(Field: TField): WideString; +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + Result := WideField.WideDisplayText + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) + and (not Assigned(Field.OnGetText)) then + Result := GetAsWideString(Field) + else + Result := Field.DisplayText{TNT-ALLOW DisplayText}; +end; + +function GetWideText(Field: TField): WideString; +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + Result := WideField.WideText + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) + and (not Assigned(Field.OnGetText)) then + Result := GetAsWideString(Field) + else + Result := Field.Text; +end; + +procedure SetWideText(Field: TField; const Value: WideString); +var + WideField: IWideStringField; +begin + if Field.GetInterface(IWideStringField, WideField) then + WideField.WideText := Value + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) + and (not Assigned(Field.OnSetText)) then + SetAsWideString(Field, Value) + else + Field.Text := Value +end; + +{ TTntDateTimeField } + +procedure TTntDateTimeField.SetAsString(const Value: AnsiString); +begin + if Value = '' then + inherited + else + SetAsDateTime(TntStrToDateTime(Value)); +end; + +{ TTntDateField } + +procedure TTntDateField.SetAsString(const Value: AnsiString); +begin + if Value = '' then + inherited + else + SetAsDateTime(TntStrToDate(Value)); +end; + +{ TTntTimeField } + +procedure TTntTimeField.SetAsString(const Value: AnsiString); +begin + if Value = '' then + inherited + else + SetAsDateTime(TntStrToTime(Value)); +end; + +{ TTntWideStringField / TTntStringField common handlers } + +procedure TntWideStringField_LegacyGetText(Sender: TField; OnGetText: TFieldGetWideTextEvent; + var AnsiText: AnsiString; DoDisplayText: Boolean); +var + WideText: WideString; +begin + if Assigned(OnGetText) then begin + WideText := AnsiText; + OnGetText(Sender, WideText, DoDisplayText); + AnsiText := WideText; + end; +end; + +procedure TntWideStringField_LegacySetText(Sender: TField; OnSetText: TFieldSetWideTextEvent; + const AnsiText: AnsiString); +begin + if Assigned(OnSetText) then + OnSetText(Sender, AnsiText); +end; + +procedure TntWideStringField_GetWideText(Field: TField; + var Text: WideString; DoDisplayText: Boolean); +var + WideStringField: IWideStringField; +begin + Field.GetInterface(IWideStringField, WideStringField); + Assert(WideStringField <> nil); + if DoDisplayText and (Field.EditMaskPtr <> '') then + { to gain the mask, we lose Unicode! } + Text := FormatMaskText(Field.EditMaskPtr, GetAsWideString(Field)) + else + Text := GetAsWideString(Field); +end; + +function TntWideStringField_GetWideDisplayText(Field: TField; + OnGetText: TFieldGetWideTextEvent): WideString; +begin + Result := ''; + if Assigned(OnGetText) then + OnGetText(Field, Result, True) + else if Assigned(Field.OnGetText) then + Result := Field.DisplayText{TNT-ALLOW DisplayText} {we lose Unicode to handle this event} + else + TntWideStringField_GetWideText(Field, Result, True); +end; + +function TntWideStringField_GetWideEditText(Field: TField; + OnGetText: TFieldGetWideTextEvent): WideString; +begin + Result := ''; + if Assigned(OnGetText) then + OnGetText(Field, Result, False) + else if Assigned(Field.OnGetText) then + Result := Field.Text {we lose Unicode to handle this event} + else + TntWideStringField_GetWideText(Field, Result, False); +end; + +procedure TntWideStringField_SetWideText(Field: TField; + const Value: WideString); +{$IFDEF COMPILER_10_UP} +begin + Field.AsWideString := Value; +end; +{$ELSE} +var + WideStringField: IWideStringField; +begin + Field.GetInterface(IWideStringField, WideStringField); + Assert(WideStringField <> nil); + WideStringField.SetAsWideString(Value); +end; +{$ENDIF} + +procedure TntWideStringField_SetWideEditText(Field: TField; + OnSetText: TFieldSetWideTextEvent; const Value: WideString); +begin + if Assigned(OnSetText) then + OnSetText(Field, Value) + else if Assigned(Field.OnSetText) then + Field.Text := Value {we lose Unicode to handle this event} + else + TntWideStringField_SetWideText(Field, Value); +end; + +{ TTntWideStringField } + +{$IFNDEF COMPILER_10_UP} +function TTntWideStringField.GetAsWideString: WideString; +begin + if not GetData(@Result, False) then + Result := ''; {fixes a bug in inherited which has unpredictable results for NULL} +end; +{$ENDIF} + +procedure TTntWideStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; + DoDisplayText: Boolean); +begin + TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText); +end; + +procedure TTntWideStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString); +begin + TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText); +end; + +procedure TTntWideStringField.SetOnGetText(const Value: TFieldGetWideTextEvent); +begin + FOnGetText := Value; + if Assigned(OnGetText) then + inherited OnGetText := LegacyGetText + else + inherited OnGetText := nil; +end; + +procedure TTntWideStringField.SetOnSetText(const Value: TFieldSetWideTextEvent); +begin + FOnSetText := Value; + if Assigned(OnSetText) then + inherited OnSetText := LegacySetText + else + inherited OnSetText := nil; +end; + +function TTntWideStringField.GetWideDisplayText: WideString; +begin + Result := TntWideStringField_GetWideDisplayText(Self, OnGetText); +end; + +function TTntWideStringField.GetWideEditText: WideString; +begin + Result := TntWideStringField_GetWideEditText(Self, OnGetText); +end; + +procedure TTntWideStringField.SetWideEditText(const Value: WideString); +begin + TntWideStringField_SetWideEditText(Self, OnSetText, Value); +end; + +(* This stuffing method works with CJK codepages - intended to store accented characters in Access 97 *) + +function SafeStringToWideStringEx(const S: AnsiString; Codepage: Word): WideString; +var + R: AnsiString; + i: Integer; +begin + R := ''; + i := 1; + while i <= Length(S) do + begin + if (S[i] = #128) then + begin + Inc(i); + if S[i] = #128 then + R := R + #128 + else + R := R + Chr(Ord(S[i]) + 128); + Inc(i); + end + else + begin + R := R + S[I]; + Inc(i); + end; + end; + Result := StringToWideStringEx(R, CodePage); +end; + +function SafeWideStringToStringEx(const W: WideString; CodePage: Word): AnsiString; +var + TempS: AnsiString; + i: integer; +begin + TempS := WideStringToStringEx(W, CodePage); + Result := ''; + for i := 1 to Length(TempS) do + begin + if TempS[i] > #128 then + Result := Result + #128 + Chr(Ord(TempS[i]) - 128) + else if TempS[i] = #128 then + Result := Result + #128 + #128 + else + Result := Result + TempS[i]; + end; +end; + +{ TTntStringField } + +constructor TTntStringField.Create(AOwner: TComponent); +begin + inherited; + FEncodingMode := emUTF8; + FFixedCodePage := TntStringFieldCodePageEnumMap[fcpLatinWestern] +end; + +function TTntStringField.GetFixedCodePageEnum: TTntStringFieldCodePageEnum; +var + i: TTntStringFieldCodePageEnum; +begin + Result := fcpOther; + for i := Low(TntStringFieldCodePageEnumMap) to High(TntStringFieldCodePageEnumMap) do begin + if TntStringFieldCodePageEnumMap[i] = FixedCodePage then begin + Result := i; + Break; {found it} + end; + end; +end; + +procedure TTntStringField.SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); +begin + if (Value <> fcpOther) then + FixedCodePage := TntStringFieldCodePageEnumMap[Value]; +end; + +function TTntStringField.GetAsVariant: Variant; +begin + if RawVariantAccess then + Result := inherited GetAsVariant + else if IsNull then + Result := Null + else + Result := GetAsWideString; +end; + +procedure TTntStringField.SetVarValue(const Value: Variant); +begin + if RawVariantAccess then + inherited + else + SetAsWideString(Value); +end; + +function TTntStringField.GetAsWideString: WideString; +begin + case EncodingMode of + emNone: Result := (inherited GetAsString); + emUTF8: Result := UTF8ToWideString(inherited GetAsString); + emUTF7: try + Result := UTF7ToWideString(inherited GetAsString); + except + Result := inherited GetAsString; + end; + emFixedCodePage: Result := StringToWideStringEx(inherited GetAsString, FixedCodePage); + emFixedCodePage_Safe: Result := SafeStringToWideStringEx(inherited GetAsString, FixedCodePage); + else + raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); + end; +end; + +procedure TTntStringField.SetAsWideString(const Value: WideString); +begin + case EncodingMode of + emNone: inherited SetAsString(Value); + emUTF8: inherited SetAsString(WideStringToUTF8(Value)); + emUTF7: inherited SetAsString(WideStringToUTF7(Value)); + emFixedCodePage: inherited SetAsString(WideStringToStringEx(Value, FixedCodePage)); + emFixedCodePage_Safe: inherited SetAsString(SafeWideStringToStringEx(Value, FixedCodePage)); + else + raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); + end; +end; + +function TTntStringField.GetAsString: string{TNT-ALLOW string}; +begin + if EncodingMode = emNone then + Result := inherited GetAsString + else + Result := GetAsWideString; +end; + +procedure TTntStringField.SetAsString(const Value: string{TNT-ALLOW string}); +begin + if EncodingMode = emNone then + inherited SetAsString(Value) + else + SetAsWideString(Value); +end; + +procedure TTntStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; + DoDisplayText: Boolean); +begin + TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText); +end; + +procedure TTntStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString); +begin + TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText); +end; + +procedure TTntStringField.SetOnGetText(const Value: TFieldGetWideTextEvent); +begin + FOnGetText := Value; + if Assigned(OnGetText) then + inherited OnGetText := LegacyGetText + else + inherited OnGetText := nil; +end; + +procedure TTntStringField.SetOnSetText(const Value: TFieldSetWideTextEvent); +begin + FOnSetText := Value; + if Assigned(OnSetText) then + inherited OnSetText := LegacySetText + else + inherited OnSetText := nil; +end; + +function TTntStringField.GetWideDisplayText: WideString; +begin + Result := TntWideStringField_GetWideDisplayText(Self, OnGetText) +end; + +function TTntStringField.GetWideEditText: WideString; +begin + Result := TntWideStringField_GetWideEditText(Self, OnGetText); +end; + +procedure TTntStringField.SetWideEditText(const Value: WideString); +begin + TntWideStringField_SetWideEditText(Self, OnSetText, Value); +end; + +function TTntStringField.IsFixedCodePageStored: Boolean; +begin + Result := EncodingMode = emFixedCodePage; +end; + +//--------------------------------------------------------------------------------------------- +{ TTntMemoField } + +constructor TTntMemoField.Create(AOwner: TComponent); +begin + inherited; + FEncodingMode := emUTF8; + FFixedCodePage := TntStringFieldCodePageEnumMap[fcpLatinWestern] +end; + +function TTntMemoField.GetFixedCodePageEnum: TTntStringFieldCodePageEnum; +var + i: TTntStringFieldCodePageEnum; +begin + Result := fcpOther; + for i := Low(TntStringFieldCodePageEnumMap) to High(TntStringFieldCodePageEnumMap) do begin + if TntStringFieldCodePageEnumMap[i] = FixedCodePage then begin + Result := i; + Break; {found it} + end; + end; +end; + +procedure TTntMemoField.SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); +begin + if (Value <> fcpOther) then + FixedCodePage := TntStringFieldCodePageEnumMap[Value]; +end; + +function TTntMemoField.GetAsVariant: Variant; +begin + if RawVariantAccess then + Result := inherited GetAsVariant + else if IsNull then + Result := Null + else + Result := GetAsWideString; +end; + +procedure TTntMemoField.SetVarValue(const Value: Variant); +begin + if RawVariantAccess then + inherited + else + SetAsWideString(Value); +end; + +function TTntMemoField.GetAsWideString: WideString; +begin + case EncodingMode of + emNone: Result := (inherited GetAsString); + emUTF8: Result := UTF8ToWideString(inherited GetAsString); + emUTF7: try + Result := UTF7ToWideString(inherited GetAsString); + except + Result := inherited GetAsString; + end; + emFixedCodePage: Result := StringToWideStringEx(inherited GetAsString, FixedCodePage); + emFixedCodePage_Safe: Result := SafeStringToWideStringEx(inherited GetAsString, FixedCodePage); + else + raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); + end; +end; + +procedure TTntMemoField.SetAsWideString(const Value: WideString); +begin + case EncodingMode of + emNone: inherited SetAsString(Value); + emUTF8: inherited SetAsString(WideStringToUTF8(Value)); + emUTF7: inherited SetAsString(WideStringToUTF7(Value)); + emFixedCodePage: inherited SetAsString(WideStringToStringEx(Value, FixedCodePage)); + emFixedCodePage_Safe: inherited SetAsString(SafeWideStringToStringEx(Value, FixedCodePage)); + else + raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); + end; +end; + +function TTntMemoField.GetAsString: string{TNT-ALLOW string}; +begin + if EncodingMode = emNone then + Result := inherited GetAsString + else + Result := GetAsWideString; +end; + +procedure TTntMemoField.SetAsString(const Value: string{TNT-ALLOW string}); +begin + if EncodingMode = emNone then + inherited SetAsString(Value) + else + SetAsWideString(Value); +end; + +procedure TTntMemoField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; + DoDisplayText: Boolean); +begin + TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText); +end; + +procedure TTntMemoField.LegacySetText(Sender: TField; const AnsiText: AnsiString); +begin + TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText); +end; + +procedure TTntMemoField.SetOnGetText(const Value: TFieldGetWideTextEvent); +begin + FOnGetText := Value; + if Assigned(OnGetText) then + inherited OnGetText := LegacyGetText + else + inherited OnGetText := nil; +end; + +procedure TTntMemoField.SetOnSetText(const Value: TFieldSetWideTextEvent); +begin + FOnSetText := Value; + if Assigned(OnSetText) then + inherited OnSetText := LegacySetText + else + inherited OnSetText := nil; +end; + +function TTntMemoField.GetWideDisplayText: WideString; +begin + Result := TntWideStringField_GetWideDisplayText(Self, OnGetText) +end; + +function TTntMemoField.GetWideEditText: WideString; +begin + Result := TntWideStringField_GetWideEditText(Self, OnGetText); +end; + +procedure TTntMemoField.SetWideEditText(const Value: WideString); +begin + TntWideStringField_SetWideEditText(Self, OnSetText, Value); +end; + +function TTntMemoField.IsFixedCodePageStored: Boolean; +begin + Result := EncodingMode = emFixedCodePage; +end; +//================================================================== +procedure RegisterTntFields; +begin + RegisterFields([TTntDateTimeField]); + RegisterFields([TTntDateField]); + RegisterFields([TTntTimeField]); + RegisterFields([TTntWideStringField]); + RegisterFields([TTntStringField]); + RegisterFields([TTntMemoField]); +end; + +type PFieldClass = ^TFieldClass; + +initialization +{$IFDEF TNT_FIELDS} + PFieldClass(@DefaultFieldClasses[ftDate])^ := TTntDateField; + PFieldClass(@DefaultFieldClasses[ftTime])^ := TTntTimeField; + PFieldClass(@DefaultFieldClasses[ftDateTime])^ := TTntDateTimeField; + PFieldClass(@DefaultFieldClasses[ftWideString])^ := TTntWideStringField; + PFieldClass(@DefaultFieldClasses[ftString])^ := TTntStringField; + PFieldClass(@DefaultFieldClasses[ftFixedChar])^ := TTntStringField; +{$ENDIF} + +finalization + +end. diff --git a/Source/TntDBActns.pas b/Source/TntDBActns.pas new file mode 100644 index 0000000..681257e --- /dev/null +++ b/Source/TntDBActns.pas @@ -0,0 +1,594 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, ActnList, DBActns, TntActnList; + +type +{TNT-WARN TDataSetAction} + TTntDataSetAction = class(TDataSetAction{TNT-ALLOW TDataSetAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetFirst} + TTntDataSetFirst = class(TDataSetFirst{TNT-ALLOW TDataSetFirst}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetPrior} + TTntDataSetPrior = class(TDataSetPrior{TNT-ALLOW TDataSetPrior}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetNext} + TTntDataSetNext = class(TDataSetNext{TNT-ALLOW TDataSetNext}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetLast} + TTntDataSetLast = class(TDataSetLast{TNT-ALLOW TDataSetLast}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetInsert} + TTntDataSetInsert = class(TDataSetInsert{TNT-ALLOW TDataSetInsert}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetDelete} + TTntDataSetDelete = class(TDataSetDelete{TNT-ALLOW TDataSetDelete}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetEdit} + TTntDataSetEdit = class(TDataSetEdit{TNT-ALLOW TDataSetEdit}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetPost} + TTntDataSetPost = class(TDataSetPost{TNT-ALLOW TDataSetPost}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetCancel} + TTntDataSetCancel = class(TDataSetCancel{TNT-ALLOW TDataSetCancel}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDataSetRefresh} + TTntDataSetRefresh = class(TDataSetRefresh{TNT-ALLOW TDataSetRefresh}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +procedure TntDBActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); + +implementation + +uses + TntClasses; + +{TNT-IGNORE-UNIT} + +procedure TntDBActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntAction_AfterInherited_Assign(Action, Source); + // TDataSetAction + if (Action is TDataSetAction) and (Source is TDataSetAction) then begin + TDataSetAction(Action).DataSource := TDataSetAction(Source).DataSource; + end; +end; + +//------------------------- +// TNT DB ACTNS +//------------------------- + +{ TTntDataSetAction } + +procedure TTntDataSetAction.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetFirst } + +procedure TTntDataSetFirst.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetFirst.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetFirst.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetFirst.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetFirst.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetFirst.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetPrior } + +procedure TTntDataSetPrior.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetPrior.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetPrior.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetPrior.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetPrior.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetPrior.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetNext } + +procedure TTntDataSetNext.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetNext.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetNext.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetNext.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetNext.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetNext.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetLast } + +procedure TTntDataSetLast.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetLast.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetLast.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetLast.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetLast.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetLast.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetInsert } + +procedure TTntDataSetInsert.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetInsert.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetInsert.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetInsert.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetInsert.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetInsert.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetDelete } + +procedure TTntDataSetDelete.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetDelete.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetDelete.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetDelete.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetDelete.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetDelete.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetEdit } + +procedure TTntDataSetEdit.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetEdit.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetEdit.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetEdit.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetEdit.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetPost } + +procedure TTntDataSetPost.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetPost.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetPost.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetPost.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetPost.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetPost.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetCancel } + +procedure TTntDataSetCancel.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetCancel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetCancel.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetCancel.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetCancel.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetCancel.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDataSetRefresh } + +procedure TTntDataSetRefresh.Assign(Source: TPersistent); +begin + inherited; + TntDBActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDataSetRefresh.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDataSetRefresh.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDataSetRefresh.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDataSetRefresh.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDataSetRefresh.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/Source/TntDBClientActns.pas b/Source/TntDBClientActns.pas new file mode 100644 index 0000000..98904c7 --- /dev/null +++ b/Source/TntDBClientActns.pas @@ -0,0 +1,197 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBClientActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, ActnList, DBClientActns, TntActnList; + +type +{TNT-WARN TClientDataSetApply} + TTntClientDataSetApply = class(TClientDataSetApply{TNT-ALLOW TClientDataSetApply}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TClientDataSetRevert} + TTntClientDataSetRevert = class(TClientDataSetRevert{TNT-ALLOW TClientDataSetRevert}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TClientDataSetUndo} + TTntClientDataSetUndo = class(TClientDataSetUndo{TNT-ALLOW TClientDataSetUndo}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +implementation + +uses + TntClasses, TntDBActns; + +{TNT-IGNORE-UNIT} + +procedure TntDBClientActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntDBActn_AfterInherited_Assign(Action, Source); + // TClientDataSetApply + if (Action is TClientDataSetApply) and (Source is TClientDataSetApply) then begin + TClientDataSetApply(Action).MaxErrors := TClientDataSetApply(Source).MaxErrors; + TClientDataSetApply(Action).DisplayErrorDlg := TClientDataSetApply(Source).DisplayErrorDlg; + end; + // TClientDataSetUndo + if (Action is TClientDataSetUndo) and (Source is TClientDataSetUndo) then begin + TClientDataSetUndo(Action).FollowChange := TClientDataSetUndo(Source).FollowChange; + end; +end; + +//------------------------- +// TNT DB ACTNS +//------------------------- + +{ TTntClientDataSetApply } + +procedure TTntClientDataSetApply.Assign(Source: TPersistent); +begin + inherited; + TntDBClientActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntClientDataSetApply.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntClientDataSetApply.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntClientDataSetApply.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntClientDataSetApply.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntClientDataSetApply.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntClientDataSetRevert } + +procedure TTntClientDataSetRevert.Assign(Source: TPersistent); +begin + inherited; + TntDBClientActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntClientDataSetRevert.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntClientDataSetRevert.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntClientDataSetRevert.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntClientDataSetRevert.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntClientDataSetRevert.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntClientDataSetUndo } + +procedure TTntClientDataSetUndo.Assign(Source: TPersistent); +begin + inherited; + TntDBClientActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntClientDataSetUndo.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntClientDataSetUndo.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntClientDataSetUndo.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntClientDataSetUndo.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntClientDataSetUndo.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/Source/TntDBCtrls.pas b/Source/TntDBCtrls.pas new file mode 100644 index 0000000..49111d4 --- /dev/null +++ b/Source/TntDBCtrls.pas @@ -0,0 +1,2195 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Windows, Messages, DB, DBCtrls, Controls, StdCtrls, + TntClasses, TntStdCtrls, TntControls, TntComCtrls, TntExtCtrls; + +type +{TNT-WARN TPaintControl} + TTntPaintControl = class + private + FOwner: TWinControl; + FClassName: WideString; + FHandle: HWnd; + FObjectInstance: Pointer; + FDefWindowProc: Pointer; + FCtl3dButton: Boolean; + function GetHandle: HWnd; + procedure SetCtl3DButton(Value: Boolean); + procedure WndProc(var Message: TMessage); + public + constructor Create(AOwner: TWinControl; const ClassName: WideString); + destructor Destroy; override; + procedure DestroyHandle; + property Ctl3DButton: Boolean read FCtl3dButton write SetCtl3dButton; + property Handle: HWnd read GetHandle; + end; + +type +{TNT-WARN TDBEdit} + TTntDBEdit = class(TDBEdit{TNT-ALLOW TDBEdit}) + private + InheritedDataChange: TNotifyEvent; + FPasswordChar: WideChar; + procedure DataChange(Sender: TObject); + procedure UpdateData(Sender: TObject); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + function GetTextMargins: TPoint; + function GetPasswordChar: WideChar; + procedure SetPasswordChar(const Value: WideChar); + procedure CMEnter(var Message: TCMEnter); message CM_ENTER; + private + function GetSelStart: Integer; reintroduce; virtual; + procedure SetSelStart(const Value: Integer); reintroduce; virtual; + function GetSelLength: Integer; reintroduce; virtual; + procedure SetSelLength(const Value: Integer); reintroduce; virtual; + function GetSelText: WideString; reintroduce; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property PasswordChar: WideChar read GetPasswordChar write SetPasswordChar default #0; + end; + +{TNT-WARN TDBText} + TTntDBText = class(TDBText{TNT-ALLOW TDBText}) + private + FDataLink: TFieldDataLink; + InheritedDataChange: TNotifyEvent; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + function GetCaption: TWideCaption; + function IsCaptionStored: Boolean; + procedure SetCaption(const Value: TWideCaption); + function GetFieldText: WideString; + procedure DataChange(Sender: TObject); + protected + procedure DefineProperties(Filer: TFiler); override; + function GetLabelText: WideString; reintroduce; virtual; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure DoDrawText(var Rect: TRect; Flags: Longint); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TDBComboBox} + TTntCustomDBComboBox = class(TDBComboBox{TNT-ALLOW TDBComboBox}, + IWideCustomListControl) + private + FDataLink: TFieldDataLink; + FFilter: WideString; + FLastTime: Cardinal; + procedure UpdateData(Sender: TObject); + procedure EditingChange(Sender: TObject); + procedure CMEnter(var Message: TCMEnter); message CM_ENTER; + procedure SetReadOnly; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Message: TWMChar); message WM_CHAR; + private + FItems: TTntStrings; + FSaveItems: TTntStrings; + FSaveItemIndex: integer; + function GetItems: TTntStrings; + procedure SetItems(const Value: TTntStrings); reintroduce; + function GetSelStart: Integer; + procedure SetSelStart(const Value: Integer); + function GetSelLength: Integer; + procedure SetSelLength(const Value: Integer); + function GetSelText: WideString; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + protected + procedure DataChange(Sender: TObject); + function GetAutoComplete_UniqueMatchOnly: Boolean; dynamic; + function GetAutoComplete_PreserveDataEntryCase: Boolean; dynamic; + procedure DoEditCharMsg(var Message: TWMChar); virtual; + function GetFieldValue: Variant; virtual; + procedure SetFieldValue(const Value: Variant); virtual; + function GetComboValue: Variant; virtual; abstract; + procedure SetComboValue(const Value: Variant); virtual; abstract; + {$IFDEF DELPHI_7} // fix for Delphi 7 only + function GetItemsClass: TCustomComboBoxStringsClass; override; + {$ENDIF} + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure WndProc(var Message: TMessage); override; + procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); override; + procedure KeyPress(var Key: AnsiChar); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + public + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property Items: TTntStrings read GetItems write SetItems; + end; + + TTntDBComboBox = class(TTntCustomDBComboBox) + protected + function GetFieldValue: Variant; override; + procedure SetFieldValue(const Value: Variant); override; + function GetComboValue: Variant; override; + procedure SetComboValue(const Value: Variant); override; + end; + +type +{TNT-WARN TDBCheckBox} + TTntDBCheckBox = class(TDBCheckBox{TNT-ALLOW TDBCheckBox}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure Toggle; override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TDBRichEdit} + TTntDBRichEdit = class(TTntCustomRichEdit) + private + FDataLink: TFieldDataLink; + FAutoDisplay: Boolean; + FFocused: Boolean; + FMemoLoaded: Boolean; + FDataSave: AnsiString; + procedure BeginEditing; + procedure DataChange(Sender: TObject); + procedure EditingChange(Sender: TObject); + function GetDataField: WideString; + function GetDataSource: TDataSource; + function GetField: TField; + function GetReadOnly: Boolean; + procedure SetDataField(const Value: WideString); + procedure SetDataSource(Value: TDataSource); + procedure SetReadOnly(Value: Boolean); + procedure SetAutoDisplay(Value: Boolean); + procedure SetFocused(Value: Boolean); + procedure UpdateData(Sender: TObject); + procedure WMCut(var Message: TMessage); message WM_CUT; + procedure WMPaste(var Message: TMessage); message WM_PASTE; + procedure CMEnter(var Message: TCMEnter); message CM_ENTER; + procedure CMExit(var Message: TCMExit); message CM_EXIT; + procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; + procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; + procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; + protected + procedure InternalLoadMemo; dynamic; + procedure InternalSaveMemo; dynamic; + protected + procedure Change; override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: AnsiChar); override; + procedure Loaded; override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function ExecuteAction(Action: TBasicAction): Boolean; override; + procedure LoadMemo; virtual; + function UpdateAction(Action: TBasicAction): Boolean; override; + function UseRightToLeftAlignment: Boolean; override; + property Field: TField read GetField; + published + property Align; + property Alignment; + property Anchors; + property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property Color; + property Constraints; + property Ctl3D; + property DataField: WideString read GetDataField write SetDataField; + property DataSource: TDataSource read GetDataSource write SetDataSource; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property HideScrollBars; + property ImeMode; + property ImeName; + property MaxLength; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PlainText; + property PopupMenu; + property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; + property ScrollBars; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property WantReturns; + property WantTabs; + property WordWrap; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnResizeRequest; + property OnSelectionChange; + property OnProtectChange; + property OnSaveClipboard; + property OnStartDock; + property OnStartDrag; + end; + +type +{TNT-WARN TDBMemo} + TTntDBMemo = class(TTntCustomMemo) + private + FDataLink: TFieldDataLink; + FAutoDisplay: Boolean; + FFocused: Boolean; + FMemoLoaded: Boolean; + FPaintControl: TTntPaintControl; + procedure DataChange(Sender: TObject); + procedure EditingChange(Sender: TObject); + function GetDataField: WideString; + function GetDataSource: TDataSource; + function GetField: TField; + function GetReadOnly: Boolean; + procedure SetDataField(const Value: WideString); + procedure SetDataSource(Value: TDataSource); + procedure SetReadOnly(Value: Boolean); + procedure SetAutoDisplay(Value: Boolean); + procedure SetFocused(Value: Boolean); + procedure UpdateData(Sender: TObject); + procedure WMCut(var Message: TMessage); message WM_CUT; + procedure WMPaste(var Message: TMessage); message WM_PASTE; + procedure WMUndo(var Message: TMessage); message WM_UNDO; + procedure CMEnter(var Message: TCMEnter); message CM_ENTER; + procedure CMExit(var Message: TCMExit); message CM_EXIT; + procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; + protected + procedure Change; override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; + procedure Loaded; override; + procedure Notification(AComponent: TComponent; + Operation: TOperation); override; + procedure WndProc(var Message: TMessage); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function ExecuteAction(Action: TBasicAction): Boolean; override; + procedure LoadMemo; virtual; + function UpdateAction(Action: TBasicAction): Boolean; override; + function UseRightToLeftAlignment: Boolean; override; + property Field: TField read GetField; + published + property Align; + property Alignment; + property Anchors; + property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property Color; + property Constraints; + property Ctl3D; + property DataField: WideString read GetDataField write SetDataField; + property DataSource: TDataSource read GetDataSource write SetDataSource; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property ImeMode; + property ImeName; + property MaxLength; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; + property ScrollBars; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property WantReturns; + property WantTabs; + property WordWrap; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +{ TDBRadioGroup } +type + TTntDBRadioGroup = class(TTntCustomRadioGroup) + private + FDataLink: TFieldDataLink; + FValue: WideString; + FValues: TTntStrings; + FInSetValue: Boolean; + FOnChange: TNotifyEvent; + procedure DataChange(Sender: TObject); + procedure UpdateData(Sender: TObject); + function GetDataField: WideString; + function GetDataSource: TDataSource; + function GetField: TField; + function GetReadOnly: Boolean; + function GetButtonValue(Index: Integer): WideString; + procedure SetDataField(const Value: WideString); + procedure SetDataSource(Value: TDataSource); + procedure SetReadOnly(Value: Boolean); + procedure SetValue(const Value: WideString); + procedure SetItems(Value: TTntStrings); + procedure SetValues(Value: TTntStrings); + procedure CMExit(var Message: TCMExit); message CM_EXIT; + procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; + protected + procedure Change; dynamic; + procedure Click; override; + procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; + function CanModify: Boolean; override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + property DataLink: TFieldDataLink read FDataLink; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function ExecuteAction(Action: TBasicAction): Boolean; override; + function UpdateAction(Action: TBasicAction): Boolean; override; + function UseRightToLeftAlignment: Boolean; override; + property Field: TField read GetField; + property ItemIndex; + property Value: WideString read FValue write SetValue; + published + property Align; + property Anchors; + property BiDiMode; + property Caption; + property Color; + property Columns; + property Constraints; + property Ctl3D; + property DataField: WideString read GetDataField write SetDataField; + property DataSource: TDataSource read GetDataSource write SetDataSource; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property Items write SetItems; + {$IFDEF COMPILER_7_UP} + property ParentBackground; + {$ENDIF} + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; + property ShowHint; + property TabOrder; + property TabStop; + property Values: TTntStrings read FValues write SetValues; + property Visible; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnStartDock; + property OnStartDrag; + end; + +implementation + +uses + Forms, SysUtils, Graphics, Variants, TntDB, + TntActnList, TntGraphics, TntSysUtils, RichEdit, Mask; + +function FieldIsBlobLike(Field: TField): Boolean; +begin + Result := False; + if Assigned(Field) then begin + if (Field.IsBlob) + or (Field.DataType in [Low(TBlobType).. High(TBlobType)]) then + Result := True + else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) + and (Field.Size = MaxInt) then + Result := True; { wide string field filling in for a blob field } + end; +end; + +{ TTntPaintControl } + +type + TAccessWinControl = class(TWinControl); + +constructor TTntPaintControl.Create(AOwner: TWinControl; const ClassName: WideString); +begin + FOwner := AOwner; + FClassName := ClassName; +end; + +destructor TTntPaintControl.Destroy; +begin + DestroyHandle; +end; + +procedure TTntPaintControl.DestroyHandle; +begin + if FHandle <> 0 then DestroyWindow(FHandle); + Classes.FreeObjectInstance(FObjectInstance); + FHandle := 0; + FObjectInstance := nil; +end; + +function TTntPaintControl.GetHandle: HWnd; +var + Params: TCreateParams; +begin + if FHandle = 0 then + begin + FObjectInstance := Classes.MakeObjectInstance(WndProc); + TAccessWinControl(FOwner).CreateParams(Params); + Params.Style := Params.Style and not (WS_HSCROLL or WS_VSCROLL); + if (not Win32PlatformIsUnicode) then begin + with Params do + FHandle := CreateWindowEx(ExStyle, PAnsiChar(AnsiString(FClassName)), + PAnsiChar(TAccessWinControl(FOwner).Text), Style or WS_VISIBLE, + X, Y, Width, Height, Application.Handle, 0, HInstance, nil); + FDefWindowProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC)); + SetWindowLong(FHandle, GWL_WNDPROC, Integer(FObjectInstance)); + end else begin + with Params do + FHandle := CreateWindowExW(ExStyle, PWideChar(FClassName), + PWideChar(TntControl_GetText(FOwner)), Style or WS_VISIBLE, + X, Y, Width, Height, Application.Handle, 0, HInstance, nil); + FDefWindowProc := Pointer(GetWindowLongW(FHandle, GWL_WNDPROC)); + SetWindowLongW(FHandle, GWL_WNDPROC, Integer(FObjectInstance)); + end; + SendMessage(FHandle, WM_SETFONT, Integer(TAccessWinControl(FOwner).Font.Handle), 1); + end; + Result := FHandle; +end; + +procedure TTntPaintControl.SetCtl3DButton(Value: Boolean); +begin + if FHandle <> 0 then DestroyHandle; + FCtl3DButton := Value; +end; + +procedure TTntPaintControl.WndProc(var Message: TMessage); +begin + with Message do + if (Msg >= CN_CTLCOLORMSGBOX) and (Msg <= CN_CTLCOLORSTATIC) then + Result := FOwner.Perform(Msg, WParam, LParam) + else if (not Win32PlatformIsUnicode) then + Result := CallWindowProcA(FDefWindowProc, FHandle, Msg, WParam, LParam) + else + Result := CallWindowProcW(FDefWindowProc, FHandle, Msg, WParam, LParam); +end; + +{ THackFieldDataLink } +type + THackFieldDataLink_D6_D7_D9 = class(TDataLink) + protected + FxxxField: TField; + FxxxFieldName: string{TNT-ALLOW string}; + FxxxControl: TComponent; + FxxxEditing: Boolean; + FModified: Boolean; + end; + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackFieldDataLink = THackFieldDataLink_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackFieldDataLink = THackFieldDataLink_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackFieldDataLink = THackFieldDataLink_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackFieldDataLink = class(TDataLink) + protected + FxxxField: TField; + FxxxFieldName: WideString; + FxxxControl: TComponent; + FxxxEditing: Boolean; + FModified: Boolean; + end; +{$ENDIF} + +{ TTntDBEdit } + +type + THackDBEdit_D6_D7_D9 = class(TCustomMaskEdit) + protected + FDataLink: TFieldDataLink; + FCanvas: TControlCanvas; + FAlignment: TAlignment; + FFocused: Boolean; + end; + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackDBEdit = THackDBEdit_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackDBEdit = THackDBEdit_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackDBEdit = THackDBEdit_D6_D7_D9; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackDBEdit = THackDBEdit_D6_D7_D9; +{$ENDIF} + +constructor TTntDBEdit.Create(AOwner: TComponent); +begin + inherited; + InheritedDataChange := THackDBEdit(Self).FDataLink.OnDataChange; + THackDBEdit(Self).FDataLink.OnDataChange := DataChange; + THackDBEdit(Self).FDataLink.OnUpdateData := UpdateData; +end; + +procedure TTntDBEdit.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'EDIT'); +end; + +procedure TTntDBEdit.CreateWnd; +begin + inherited; + TntCustomEdit_AfterInherited_CreateWnd(Self, FPasswordChar); +end; + +procedure TTntDBEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDBEdit.GetSelStart: Integer; +begin + Result := TntCustomEdit_GetSelStart(Self); +end; + +procedure TTntDBEdit.SetSelStart(const Value: Integer); +begin + TntCustomEdit_SetSelStart(Self, Value); +end; + +function TTntDBEdit.GetSelLength: Integer; +begin + Result := TntCustomEdit_GetSelLength(Self); +end; + +procedure TTntDBEdit.SetSelLength(const Value: Integer); +begin + TntCustomEdit_SetSelLength(Self, Value); +end; + +function TTntDBEdit.GetSelText: WideString; +begin + Result := TntCustomEdit_GetSelText(Self); +end; + +procedure TTntDBEdit.SetSelText(const Value: WideString); +begin + TntCustomEdit_SetSelText(Self, Value); +end; + +function TTntDBEdit.GetPasswordChar: WideChar; +begin + Result := TntCustomEdit_GetPasswordChar(Self, FPasswordChar) +end; + +procedure TTntDBEdit.SetPasswordChar(const Value: WideChar); +begin + TntCustomEdit_SetPasswordChar(Self, FPasswordChar, Value); +end; + +function TTntDBEdit.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntDBEdit.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntDBEdit.DataChange(Sender: TObject); +begin + with THackDBEdit(Self), Self do begin + if Field = nil then + InheritedDataChange(Sender) + else begin + if FAlignment <> Field.Alignment then + begin + EditText := ''; {forces update} + FAlignment := Field.Alignment; + end; + EditMask := Field.EditMask; + if not (csDesigning in ComponentState) then + begin + if (Field.DataType in [ftString, ftWideString]) and (MaxLength = 0) then + MaxLength := Field.Size; + end; + if FFocused and FDataLink.CanModify then + Text := GetWideText(Field) + else + begin + Text := GetWideDisplayText(Field); + if FDataLink.Editing and THackFieldDataLink(FDataLink).FModified then + Modified := True; + end; + end; + end; +end; + +procedure TTntDBEdit.UpdateData(Sender: TObject); +begin + ValidateEdit; + SetWideText(Field, Text); +end; + +procedure TTntDBEdit.CMEnter(var Message: TCMEnter); +var + SaveFarEast: Boolean; +begin + SaveFarEast := SysLocale.FarEast; + try + SysLocale.FarEast := False; + inherited; // inherited tries to work around Win95 FarEast bug, but introduces others + finally + SysLocale.FarEast := SaveFarEast; + end; +end; + +function TTntDBEdit.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntDBEdit.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntDBEdit.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntDBEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntDBEdit.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntDBEdit.WMPaint(var Message: TWMPaint); +const + AlignStyle : array[Boolean, TAlignment] of DWORD = + ((WS_EX_LEFT, WS_EX_RIGHT, WS_EX_LEFT), + (WS_EX_RIGHT, WS_EX_LEFT, WS_EX_LEFT)); +var + ALeft: Integer; + _Margins: TPoint; + R: TRect; + DC: HDC; + PS: TPaintStruct; + S: WideString; + AAlignment: TAlignment; + I: Integer; +begin + with THackDBEdit(Self), Self do begin + AAlignment := FAlignment; + if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment); + if ((AAlignment = taLeftJustify) or FFocused) and (not (csPaintCopy in ControlState)) + or (not Win32PlatformIsUnicode) then + begin + inherited; + Exit; + end; + { Since edit controls do not handle justification unless multi-line (and + then only poorly) we will draw right and center justify manually unless + the edit has the focus. } + if FCanvas = nil then + begin + FCanvas := TControlCanvas.Create; + FCanvas.Control := Self; + end; + DC := Message.DC; + if DC = 0 then DC := BeginPaint(Handle, PS); + FCanvas.Handle := DC; + try + FCanvas.Font := Font; + with FCanvas do + begin + R := ClientRect; + if not (NewStyleControls and Ctl3D) and (BorderStyle = bsSingle) then + begin + Brush.Color := clWindowFrame; + FrameRect(R); + InflateRect(R, -1, -1); + end; + Brush.Color := Color; + if not Enabled then + Font.Color := clGrayText; + if (csPaintCopy in ControlState) and (Field <> nil) then + begin + S := GetWideDisplayText(Field); + case CharCase of + ecUpperCase: + S := Tnt_WideUpperCase(S); + ecLowerCase: + S := Tnt_WideLowerCase(S); + end; + end else + S := Text { EditText? }; + if PasswordChar <> #0 then + for I := 1 to Length(S) do S[I] := PasswordChar; + _Margins := GetTextMargins; + case AAlignment of + taLeftJustify: ALeft := _Margins.X; + taRightJustify: ALeft := ClientWidth - WideCanvasTextWidth(FCanvas, S) - _Margins.X - 1; + else + ALeft := (ClientWidth - WideCanvasTextWidth(FCanvas, S)) div 2; + end; + if SysLocale.MiddleEast then UpdateTextFlags; + WideCanvasTextRect(FCanvas, R, ALeft, _Margins.Y, S); + end; + finally + FCanvas.Handle := 0; + if Message.DC = 0 then EndPaint(Handle, PS); + end; + end; +end; + +function TTntDBEdit.GetTextMargins: TPoint; +var + DC: HDC; + SaveFont: HFont; + I: Integer; + SysMetrics, Metrics: TTextMetric; +begin + if NewStyleControls then + begin + if BorderStyle = bsNone then I := 0 else + if Ctl3D then I := 1 else I := 2; + Result.X := SendMessage(Handle, EM_GETMARGINS, 0, 0) and $0000FFFF + I; + Result.Y := I; + end else + begin + if BorderStyle = bsNone then I := 0 else + begin + DC := GetDC(0); + GetTextMetrics(DC, SysMetrics); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + I := SysMetrics.tmHeight; + if I > Metrics.tmHeight then I := Metrics.tmHeight; + I := I div 4; + end; + Result.X := I; + Result.Y := I; + end; +end; + +{ TTntDBText } + +constructor TTntDBText.Create(AOwner: TComponent); +begin + inherited; + FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; + InheritedDataChange := FDataLink.OnDataChange; + FDataLink.OnDataChange := DataChange; +end; + +destructor TTntDBText.Destroy; +begin + FDataLink := nil; + inherited; +end; + +procedure TTntDBText.CMDialogChar(var Message: TCMDialogChar); +begin + TntLabel_CMDialogChar(Self, Message, Caption); +end; + +function TTntDBText.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntDBText.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntDBText.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntDBText.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDBText.GetLabelText: WideString; +begin + if csPaintCopy in ControlState then + Result := GetFieldText + else + Result := Caption; +end; + +procedure TTntDBText.DoDrawText(var Rect: TRect; Flags: Integer); +begin + if not TntLabel_DoDrawText(Self, Rect, Flags, GetLabelText) then + inherited; +end; + +function TTntDBText.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntDBText.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntDBText.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntDBText.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntDBText.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntDBText.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +function TTntDBText.GetFieldText: WideString; +begin + if Field <> nil then + Result := GetWideDisplayText(Field) + else + if csDesigning in ComponentState then Result := Name else Result := ''; +end; + +procedure TTntDBText.DataChange(Sender: TObject); +begin + Caption := GetFieldText; +end; + +{ TTntCustomDBComboBox } + +constructor TTntCustomDBComboBox.Create(AOwner: TComponent); +begin + inherited; + FItems := TTntComboBoxStrings.Create; + TTntComboBoxStrings(FItems).ComboBox := Self; + FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; + FDataLink.OnDataChange := DataChange; + FDataLink.OnUpdateData := UpdateData; + FDataLink.OnEditingChange := EditingChange; +end; + +destructor TTntCustomDBComboBox.Destroy; +begin + FreeAndNil(FItems); + FreeAndNil(FSaveItems); + FDataLink := nil; + inherited; +end; + +procedure TTntCustomDBComboBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'COMBOBOX'); +end; + +procedure TTntCustomDBComboBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +type + TAccessCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}); + +procedure TTntCustomDBComboBox.CreateWnd; +var + PreInheritedAnsiText: AnsiString; +begin + PreInheritedAnsiText := TAccessCustomComboBox(Self).Text; + inherited; + TntCombo_AfterInherited_CreateWnd(Self, Items, FSaveItems, FSaveItemIndex, PreInheritedAnsiText); +end; + +procedure TTntCustomDBComboBox.DestroyWnd; +var + SavedText: WideString; +begin + if not (csDestroyingHandle in ControlState) then begin { avoid recursion when parent is TToolBar and system font changes. } + TntCombo_BeforeInherited_DestroyWnd(Self, Items, FSaveItems, ItemIndex, FSaveItemIndex, SavedText); + inherited; + TntControl_SetStoredText(Self, SavedText); + end; +end; + +procedure TTntCustomDBComboBox.SetReadOnly; +begin + if (Style in [csDropDown, csSimple]) and HandleAllocated then + SendMessage(EditHandle, EM_SETREADONLY, Ord(not FDataLink.CanModify), 0); +end; + +procedure TTntCustomDBComboBox.EditingChange(Sender: TObject); +begin + SetReadOnly; +end; + +procedure TTntCustomDBComboBox.CMEnter(var Message: TCMEnter); +var + SaveFarEast: Boolean; +begin + SaveFarEast := SysLocale.FarEast; + try + SysLocale.FarEast := False; + inherited; // inherited tries to work around Win95 FarEast bug, but introduces others + finally + SysLocale.FarEast := SaveFarEast; + end; +end; + +procedure TTntCustomDBComboBox.WndProc(var Message: TMessage); +begin + if (not (csDesigning in ComponentState)) + and (Message.Msg = CB_SHOWDROPDOWN) + and (Message.WParam = 0) + and (not FDataLink.Editing) then begin + DataChange(Self); {Restore text} + Dispatch(Message); {Do NOT call inherited!} + end else + inherited WndProc(Message); +end; + +procedure TTntCustomDBComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); +begin + if not TntCombo_ComboWndProc(Self, Message, ComboWnd, ComboProc, DoEditCharMsg) then + inherited; +end; + +procedure TTntCustomDBComboBox.KeyPress(var Key: AnsiChar); +var + SaveAutoComplete: Boolean; +begin + TntCombo_BeforeKeyPress(Self, SaveAutoComplete); + try + inherited; + finally + TntCombo_AfterKeyPress(Self, SaveAutoComplete); + end; +end; + +procedure TTntCustomDBComboBox.DoEditCharMsg(var Message: TWMChar); +begin + TntCombo_AutoCompleteKeyPress(Self, Items, Message, + GetAutoComplete_UniqueMatchOnly, GetAutoComplete_PreserveDataEntryCase); +end; + +procedure TTntCustomDBComboBox.WMChar(var Message: TWMChar); +begin + TntCombo_AutoSearchKeyPress(Self, Items, Message, FFilter, FLastTime); + inherited; +end; + +function TTntCustomDBComboBox.GetItems: TTntStrings; +begin + Result := FItems; +end; + +procedure TTntCustomDBComboBox.SetItems(const Value: TTntStrings); +begin + FItems.Assign(Value); + DataChange(Self); +end; + +function TTntCustomDBComboBox.GetSelStart: Integer; +begin + Result := TntCombo_GetSelStart(Self); +end; + +procedure TTntCustomDBComboBox.SetSelStart(const Value: Integer); +begin + TntCombo_SetSelStart(Self, Value); +end; + +function TTntCustomDBComboBox.GetSelLength: Integer; +begin + Result := TntCombo_GetSelLength(Self); +end; + +procedure TTntCustomDBComboBox.SetSelLength(const Value: Integer); +begin + TntCombo_SetSelLength(Self, Value); +end; + +function TTntCustomDBComboBox.GetSelText: WideString; +begin + Result := TntCombo_GetSelText(Self); +end; + +procedure TTntCustomDBComboBox.SetSelText(const Value: WideString); +begin + TntCombo_SetSelText(Self, Value); +end; + +function TTntCustomDBComboBox.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomDBComboBox.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomDBComboBox.CNCommand(var Message: TWMCommand); +begin + if not TntCombo_CNCommand(Self, Items, Message) then + inherited; +end; + +function TTntCustomDBComboBox.GetFieldValue: Variant; +begin + Result := Field.Value; +end; + +procedure TTntCustomDBComboBox.SetFieldValue(const Value: Variant); +begin + Field.Value := Value; +end; + +procedure TTntCustomDBComboBox.DataChange(Sender: TObject); +begin + if not (Style = csSimple) and DroppedDown then Exit; + if Field <> nil then + SetComboValue(GetFieldValue) + else + if csDesigning in ComponentState then + SetComboValue(Name) + else + SetComboValue(Null); +end; + +procedure TTntCustomDBComboBox.UpdateData(Sender: TObject); +begin + SetFieldValue(GetComboValue); +end; + +function TTntCustomDBComboBox.GetAutoComplete_PreserveDataEntryCase: Boolean; +begin + Result := True; +end; + +function TTntCustomDBComboBox.GetAutoComplete_UniqueMatchOnly: Boolean; +begin + Result := False; +end; + +function TTntCustomDBComboBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomDBComboBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomDBComboBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomDBComboBox.AddItem(const Item: WideString; AObject: TObject); +begin + TntComboBox_AddItem(Items, Item, AObject); +end; + +procedure TTntCustomDBComboBox.CopySelection(Destination: TCustomListControl); +begin + TntComboBox_CopySelection(Items, ItemIndex, Destination); +end; + +procedure TTntCustomDBComboBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomDBComboBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{$IFDEF DELPHI_7} // fix for Delphi 7 only +function TTntCustomDBComboBox.GetItemsClass: TCustomComboBoxStringsClass; +begin + Result := TD7PatchedComboBoxStrings; +end; +{$ENDIF} + +{ TTntDBComboBox } + +function TTntDBComboBox.GetFieldValue: Variant; +begin + Result := GetWideText(Field); +end; + +procedure TTntDBComboBox.SetFieldValue(const Value: Variant); +begin + SetWideText(Field, Value); +end; + +procedure TTntDBComboBox.SetComboValue(const Value: Variant); +var + I: Integer; + Redraw: Boolean; + OldValue: WideString; + NewValue: WideString; +begin + OldValue := VarToWideStr(GetComboValue); + NewValue := VarToWideStr(Value); + + if NewValue <> OldValue then + begin + if Style <> csDropDown then + begin + Redraw := (Style <> csSimple) and HandleAllocated; + if Redraw then Items.BeginUpdate; + try + if NewValue = '' then I := -1 else I := Items.IndexOf(NewValue); + ItemIndex := I; + finally + Items.EndUpdate; + end; + if I >= 0 then Exit; + end; + if Style in [csDropDown, csSimple] then Text := NewValue; + end; +end; + +function TTntDBComboBox.GetComboValue: Variant; +var + I: Integer; +begin + if Style in [csDropDown, csSimple] then Result := Text else + begin + I := ItemIndex; + if I < 0 then Result := '' else Result := Items[I]; + end; +end; + +{ TTntDBCheckBox } + +procedure TTntDBCheckBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntDBCheckBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDBCheckBox.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntDBCheckBox.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntDBCheckBox.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntDBCheckBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntDBCheckBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntDBCheckBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntDBCheckBox.Toggle; +var + FDataLink: TDataLink; +begin + inherited; + FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; + FDataLink.UpdateRecord; +end; + +procedure TTntDBCheckBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntDBCheckBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntDBRichEdit } + +constructor TTntDBRichEdit.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + inherited ReadOnly := True; + FAutoDisplay := True; + FDataLink := TFieldDataLink.Create; + FDataLink.Control := Self; + FDataLink.OnDataChange := DataChange; + FDataLink.OnEditingChange := EditingChange; + FDataLink.OnUpdateData := UpdateData; +end; + +destructor TTntDBRichEdit.Destroy; +begin + FDataLink.Free; + FDataLink := nil; + inherited Destroy; +end; + +procedure TTntDBRichEdit.Loaded; +begin + inherited Loaded; + if (csDesigning in ComponentState) then + DataChange(Self) +end; + +procedure TTntDBRichEdit.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (Operation = opRemove) and (FDataLink <> nil) and + (AComponent = DataSource) then DataSource := nil; +end; + +function TTntDBRichEdit.UseRightToLeftAlignment: Boolean; +begin + Result := DBUseRightToLeftAlignment(Self, Field); +end; + +procedure TTntDBRichEdit.BeginEditing; +begin + if not FDataLink.Editing then + try + if FieldIsBlobLike(Field) then + FDataSave := Field.AsString{TNT-ALLOW AsString}; + FDataLink.Edit; + finally + FDataSave := ''; + end; +end; + +procedure TTntDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited KeyDown(Key, Shift); + if FMemoLoaded then + begin + if (Key = VK_DELETE) or (Key = VK_BACK) or + ((Key = VK_INSERT) and (ssShift in Shift)) or + (((Key = Ord('V')) or (Key = Ord('X'))) and (ssCtrl in Shift)) then + BeginEditing; + end; +end; + +procedure TTntDBRichEdit.KeyPress(var Key: AnsiChar); +begin + inherited KeyPress(Key); + if FMemoLoaded then + begin + if (Key in [#32..#255]) and (Field <> nil) and + not Field.IsValidChar(Key) then + begin + MessageBeep(0); + Key := #0; + end; + case Key of + ^H, ^I, ^J, ^M, ^V, ^X, #32..#255: + BeginEditing; + #27: + FDataLink.Reset; + end; + end else + begin + if Key = #13 then LoadMemo; + Key := #0; + end; +end; + +procedure TTntDBRichEdit.Change; +begin + if FMemoLoaded then + FDataLink.Modified; + FMemoLoaded := True; + inherited Change; +end; + +procedure TTntDBRichEdit.CNNotify(var Message: TWMNotify); +begin + inherited; + if Message.NMHdr^.code = EN_PROTECTED then + Message.Result := 0 { allow the operation (otherwise the control might appear stuck) } +end; + +function TTntDBRichEdit.GetDataSource: TDataSource; +begin + Result := FDataLink.DataSource; +end; + +procedure TTntDBRichEdit.SetDataSource(Value: TDataSource); +begin + FDataLink.DataSource := Value; + if Value <> nil then Value.FreeNotification(Self); +end; + +function TTntDBRichEdit.GetDataField: WideString; +begin + Result := FDataLink.FieldName; +end; + +procedure TTntDBRichEdit.SetDataField(const Value: WideString); +begin + FDataLink.FieldName := Value; +end; + +function TTntDBRichEdit.GetReadOnly: Boolean; +begin + Result := FDataLink.ReadOnly; +end; + +procedure TTntDBRichEdit.SetReadOnly(Value: Boolean); +begin + FDataLink.ReadOnly := Value; +end; + +function TTntDBRichEdit.GetField: TField; +begin + Result := FDataLink.Field; +end; + +procedure TTntDBRichEdit.InternalLoadMemo; +var + Stream: TStringStream{TNT-ALLOW TStringStream}; +begin + if PlainText then + Text := GetAsWideString(Field) + else begin + Stream := TStringStream{TNT-ALLOW TStringStream}.Create(Field.AsString{TNT-ALLOW AsString}); + try + Lines.LoadFromStream(Stream); + finally + Stream.Free; + end; + end; +end; + +procedure TTntDBRichEdit.LoadMemo; +begin + if not FMemoLoaded and Assigned(Field) and FieldIsBlobLike(Field) then + begin + try + InternalLoadMemo; + FMemoLoaded := True; + except + { Rich Edit Load failure } + on E:EOutOfResources do + Lines.Text := WideFormat('(%s)', [E.Message]); + end; + EditingChange(Self); + end; +end; + +procedure TTntDBRichEdit.DataChange(Sender: TObject); +begin + if Field <> nil then + if FieldIsBlobLike(Field) then + begin + if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then + begin + { Check if the data has changed since we read it the first time } + if (FDataSave <> '') and (FDataSave = Field.AsString{TNT-ALLOW AsString}) then Exit; + FMemoLoaded := False; + LoadMemo; + end else + begin + Text := WideFormat('(%s)', [Field.DisplayName]); + FMemoLoaded := False; + end; + end else + begin + if FFocused and FDataLink.CanModify then + Text := GetWideText(Field) + else + Text := GetWideDisplayText(Field); + FMemoLoaded := True; + end + else + begin + if csDesigning in ComponentState then Text := Name else Text := ''; + FMemoLoaded := False; + end; + if HandleAllocated then + RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME); +end; + +procedure TTntDBRichEdit.EditingChange(Sender: TObject); +begin + inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded); +end; + +procedure TTntDBRichEdit.InternalSaveMemo; +var + Stream: TStringStream{TNT-ALLOW TStringStream}; +begin + if PlainText then + SetAsWideString(Field, Text) + else begin + Stream := TStringStream{TNT-ALLOW TStringStream}.Create(''); + try + Lines.SaveToStream(Stream); + Field.AsString{TNT-ALLOW AsString} := Stream.DataString; + finally + Stream.Free; + end; + end; +end; + +procedure TTntDBRichEdit.UpdateData(Sender: TObject); +begin + if FieldIsBlobLike(Field) then + InternalSaveMemo + else + SetAsWideString(Field, Text); +end; + +procedure TTntDBRichEdit.SetFocused(Value: Boolean); +begin + if FFocused <> Value then + begin + FFocused := Value; + if not Assigned(Field) or not FieldIsBlobLike(Field) then + FDataLink.Reset; + end; +end; + +procedure TTntDBRichEdit.CMEnter(var Message: TCMEnter); +begin + SetFocused(True); + inherited; +end; + +procedure TTntDBRichEdit.CMExit(var Message: TCMExit); +begin + try + FDataLink.UpdateRecord; + except + SetFocus; + raise; + end; + SetFocused(False); + inherited; +end; + +procedure TTntDBRichEdit.SetAutoDisplay(Value: Boolean); +begin + if FAutoDisplay <> Value then + begin + FAutoDisplay := Value; + if Value then LoadMemo; + end; +end; + +procedure TTntDBRichEdit.WMLButtonDblClk(var Message: TWMLButtonDblClk); +begin + if not FMemoLoaded then LoadMemo else inherited; +end; + +procedure TTntDBRichEdit.WMCut(var Message: TMessage); +begin + BeginEditing; + inherited; +end; + +procedure TTntDBRichEdit.WMPaste(var Message: TMessage); +begin + BeginEditing; + inherited; +end; + +procedure TTntDBRichEdit.CMGetDataLink(var Message: TMessage); +begin + Message.Result := Integer(FDataLink); +end; + +function TTntDBRichEdit.ExecuteAction(Action: TBasicAction): Boolean; +begin + Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and + FDataLink.ExecuteAction(Action); +end; + +function TTntDBRichEdit.UpdateAction(Action: TBasicAction): Boolean; +begin + Result := inherited UpdateAction(Action) or (FDataLink <> nil) and + FDataLink.UpdateAction(Action); +end; + +{ TTntDBMemo } + +constructor TTntDBMemo.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + inherited ReadOnly := True; + ControlStyle := ControlStyle + [csReplicatable]; + FAutoDisplay := True; + FDataLink := TFieldDataLink.Create; + FDataLink.Control := Self; + FDataLink.OnDataChange := DataChange; + FDataLink.OnEditingChange := EditingChange; + FDataLink.OnUpdateData := UpdateData; + FPaintControl := TTntPaintControl.Create(Self, 'EDIT'); +end; + +destructor TTntDBMemo.Destroy; +begin + FPaintControl.Free; + FDataLink.Free; + FDataLink := nil; + inherited Destroy; +end; + +procedure TTntDBMemo.Loaded; +begin + inherited Loaded; + if (csDesigning in ComponentState) then DataChange(Self); +end; + +procedure TTntDBMemo.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (FDataLink <> nil) and + (AComponent = DataSource) then DataSource := nil; +end; + +function TTntDBMemo.UseRightToLeftAlignment: Boolean; +begin + Result := DBUseRightToLeftAlignment(Self, Field); +end; + +procedure TTntDBMemo.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited KeyDown(Key, Shift); + if FMemoLoaded then + begin + if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then + FDataLink.Edit; + end; +end; + +procedure TTntDBMemo.KeyPress(var Key: Char{TNT-ALLOW Char}); +begin + inherited KeyPress(Key); + if FMemoLoaded then + begin + if (Key in [#32..#255]) and (FDataLink.Field <> nil) and + not FDataLink.Field.IsValidChar(Key) then + begin + MessageBeep(0); + Key := #0; + end; + case Key of + ^H, ^I, ^J, ^M, ^V, ^X, #32..#255: + FDataLink.Edit; + #27: + FDataLink.Reset; + end; + end else + begin + if Key = #13 then LoadMemo; + Key := #0; + end; +end; + +procedure TTntDBMemo.Change; +begin + if FMemoLoaded then FDataLink.Modified; + FMemoLoaded := True; + inherited Change; +end; + +function TTntDBMemo.GetDataSource: TDataSource; +begin + Result := FDataLink.DataSource; +end; + +procedure TTntDBMemo.SetDataSource(Value: TDataSource); +begin + if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then + FDataLink.DataSource := Value; + if Value <> nil then Value.FreeNotification(Self); +end; + +function TTntDBMemo.GetDataField: WideString; +begin + Result := FDataLink.FieldName; +end; + +procedure TTntDBMemo.SetDataField(const Value: WideString); +begin + FDataLink.FieldName := Value; +end; + +function TTntDBMemo.GetReadOnly: Boolean; +begin + Result := FDataLink.ReadOnly; +end; + +procedure TTntDBMemo.SetReadOnly(Value: Boolean); +begin + FDataLink.ReadOnly := Value; +end; + +function TTntDBMemo.GetField: TField; +begin + Result := FDataLink.Field; +end; + +procedure TTntDBMemo.LoadMemo; +begin + if not FMemoLoaded and Assigned(FDataLink.Field) and FieldIsBlobLike(FDataLink.Field) then + begin + try + Lines.Text := GetAsWideString(FDataLink.Field); + FMemoLoaded := True; + except + { Memo too large } + on E:EInvalidOperation do + Lines.Text := WideFormat('(%s)', [E.Message]); + end; + EditingChange(Self); + end; +end; + +procedure TTntDBMemo.DataChange(Sender: TObject); +begin + if FDataLink.Field <> nil then + if FieldIsBlobLike(FDataLink.Field) then + begin + if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then + begin + FMemoLoaded := False; + LoadMemo; + end else + begin + Text := WideFormat('(%s)', [FDataLink.Field.DisplayName]); + FMemoLoaded := False; + EditingChange(Self); + end; + end else + begin + if FFocused and FDataLink.CanModify then + Text := GetWideText(FDataLink.Field) + else + Text := GetWideDisplayText(FDataLink.Field); + FMemoLoaded := True; + end + else + begin + if csDesigning in ComponentState then Text := Name else Text := ''; + FMemoLoaded := False; + end; + if HandleAllocated then + RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME); +end; + +procedure TTntDBMemo.EditingChange(Sender: TObject); +begin + inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded); +end; + +procedure TTntDBMemo.UpdateData(Sender: TObject); +begin + SetAsWideString(FDataLink.Field, Text); +end; + +procedure TTntDBMemo.SetFocused(Value: Boolean); +begin + if FFocused <> Value then + begin + FFocused := Value; + if not Assigned(FDataLink.Field) or not FieldIsBlobLike(FDataLink.Field) then + FDataLink.Reset; + end; +end; + +procedure TTntDBMemo.WndProc(var Message: TMessage); +begin + with Message do + if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or + (Msg = CM_FONTCHANGED) then FPaintControl.DestroyHandle; + inherited; +end; + +procedure TTntDBMemo.CMEnter(var Message: TCMEnter); +begin + SetFocused(True); + inherited; +end; + +procedure TTntDBMemo.CMExit(var Message: TCMExit); +begin + try + FDataLink.UpdateRecord; + except + SetFocus; + raise; + end; + SetFocused(False); + inherited; +end; + +procedure TTntDBMemo.SetAutoDisplay(Value: Boolean); +begin + if FAutoDisplay <> Value then + begin + FAutoDisplay := Value; + if Value then LoadMemo; + end; +end; + +procedure TTntDBMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk); +begin + if not FMemoLoaded then LoadMemo else inherited; +end; + +procedure TTntDBMemo.WMCut(var Message: TMessage); +begin + FDataLink.Edit; + inherited; +end; + +procedure TTntDBMemo.WMUndo(var Message: TMessage); +begin + FDataLink.Edit; + inherited; +end; + +procedure TTntDBMemo.WMPaste(var Message: TMessage); +begin + FDataLink.Edit; + inherited; +end; + +procedure TTntDBMemo.CMGetDataLink(var Message: TMessage); +begin + Message.Result := Integer(FDataLink); +end; + +procedure TTntDBMemo.WMPaint(var Message: TWMPaint); +var + S: WideString; +begin + if not (csPaintCopy in ControlState) then + inherited + else begin + if FDataLink.Field <> nil then + if FieldIsBlobLike(FDataLink.Field) then + begin + if FAutoDisplay then + S := TntAdjustLineBreaks(GetAsWideString(FDataLink.Field)) else + S := WideFormat('(%s)', [FDataLink.Field.DisplayName]); + end else + S := GetWideDisplayText(FDataLink.Field); + if (not Win32PlatformIsUnicode) then + SendMessageA(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PAnsiChar(AnsiString(S)))) + else begin + SendMessageW(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PWideChar(S))); + end; + SendMessage(FPaintControl.Handle, WM_ERASEBKGND, Integer(Message.DC), 0); + SendMessage(FPaintControl.Handle, WM_PAINT, Integer(Message.DC), 0); + end; +end; + +function TTntDBMemo.ExecuteAction(Action: TBasicAction): Boolean; +begin + Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and + FDataLink.ExecuteAction(Action); +end; + +function TTntDBMemo.UpdateAction(Action: TBasicAction): Boolean; +begin + Result := inherited UpdateAction(Action) or (FDataLink <> nil) and + FDataLink.UpdateAction(Action); +end; + +{ TTntDBRadioGroup } + +constructor TTntDBRadioGroup.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FDataLink := TFieldDataLink.Create; + FDataLink.Control := Self; + FDataLink.OnDataChange := DataChange; + FDataLink.OnUpdateData := UpdateData; + FValues := TTntStringList.Create; +end; + +destructor TTntDBRadioGroup.Destroy; +begin + FDataLink.Free; + FDataLink := nil; + FValues.Free; + inherited Destroy; +end; + +procedure TTntDBRadioGroup.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (FDataLink <> nil) and + (AComponent = DataSource) then DataSource := nil; +end; + +function TTntDBRadioGroup.UseRightToLeftAlignment: Boolean; +begin + Result := inherited UseRightToLeftAlignment; +end; + +procedure TTntDBRadioGroup.DataChange(Sender: TObject); +begin + if FDataLink.Field <> nil then + Value := GetWideText(FDataLink.Field) else + Value := ''; +end; + +procedure TTntDBRadioGroup.UpdateData(Sender: TObject); +begin + if FDataLink.Field <> nil then + SetWideText(FDataLink.Field, Value); +end; + +function TTntDBRadioGroup.GetDataSource: TDataSource; +begin + Result := FDataLink.DataSource; +end; + +procedure TTntDBRadioGroup.SetDataSource(Value: TDataSource); +begin + FDataLink.DataSource := Value; + if Value <> nil then Value.FreeNotification(Self); +end; + +function TTntDBRadioGroup.GetDataField: WideString; +begin + Result := FDataLink.FieldName; +end; + +procedure TTntDBRadioGroup.SetDataField(const Value: WideString); +begin + FDataLink.FieldName := Value; +end; + +function TTntDBRadioGroup.GetReadOnly: Boolean; +begin + Result := FDataLink.ReadOnly; +end; + +procedure TTntDBRadioGroup.SetReadOnly(Value: Boolean); +begin + FDataLink.ReadOnly := Value; +end; + +function TTntDBRadioGroup.GetField: TField; +begin + Result := FDataLink.Field; +end; + +function TTntDBRadioGroup.GetButtonValue(Index: Integer): WideString; +begin + if (Index < FValues.Count) and (FValues[Index] <> '') then + Result := FValues[Index] + else if Index < Items.Count then + Result := Items[Index] + else + Result := ''; +end; + +procedure TTntDBRadioGroup.SetValue(const Value: WideString); +var + WasFocused: Boolean; + I, Index: Integer; +begin + if FValue <> Value then + begin + FInSetValue := True; + try + WasFocused := (ItemIndex > -1) and (Buttons[ItemIndex].Focused); + Index := -1; + for I := 0 to Items.Count - 1 do + if Value = GetButtonValue(I) then + begin + Index := I; + Break; + end; + ItemIndex := Index; + // Move the focus rect along with the selected index + if WasFocused then + Buttons[ItemIndex].SetFocus; + finally + FInSetValue := False; + end; + FValue := Value; + Change; + end; +end; + +procedure TTntDBRadioGroup.CMExit(var Message: TCMExit); +begin + try + FDataLink.UpdateRecord; + except + if ItemIndex >= 0 then + (Controls[ItemIndex] as TTntRadioButton).SetFocus else + (Controls[0] as TTntRadioButton).SetFocus; + raise; + end; + inherited; +end; + +procedure TTntDBRadioGroup.CMGetDataLink(var Message: TMessage); +begin + Message.Result := Integer(FDataLink); +end; + +procedure TTntDBRadioGroup.Click; +begin + if not FInSetValue then + begin + inherited Click; + if ItemIndex >= 0 then Value := GetButtonValue(ItemIndex); + if FDataLink.Editing then FDataLink.Modified; + end; +end; + +procedure TTntDBRadioGroup.SetItems(Value: TTntStrings); +begin + Items.Assign(Value); + DataChange(Self); +end; + +procedure TTntDBRadioGroup.SetValues(Value: TTntStrings); +begin + FValues.Assign(Value); + DataChange(Self); +end; + +procedure TTntDBRadioGroup.Change; +begin + if Assigned(FOnChange) then FOnChange(Self); +end; + +procedure TTntDBRadioGroup.KeyPress(var Key: Char{TNT-ALLOW Char}); +begin + inherited KeyPress(Key); + case Key of + #8, ' ': FDataLink.Edit; + #27: FDataLink.Reset; + end; +end; + +function TTntDBRadioGroup.CanModify: Boolean; +begin + Result := FDataLink.Edit; +end; + +function TTntDBRadioGroup.ExecuteAction(Action: TBasicAction): Boolean; +begin + Result := inherited ExecuteAction(Action) or (DataLink <> nil) and + DataLink.ExecuteAction(Action); +end; + +function TTntDBRadioGroup.UpdateAction(Action: TBasicAction): Boolean; +begin + Result := inherited UpdateAction(Action) or (DataLink <> nil) and + DataLink.UpdateAction(Action); +end; + +end. diff --git a/Source/TntDBGrids.pas b/Source/TntDBGrids.pas new file mode 100644 index 0000000..2664bf7 --- /dev/null +++ b/Source/TntDBGrids.pas @@ -0,0 +1,1175 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBGrids; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, TntClasses, Controls, Windows, Grids, DBGrids, Messages, DBCtrls, DB, TntStdCtrls; + +type +{TNT-WARN TColumnTitle} + TTntColumnTitle = class(TColumnTitle{TNT-ALLOW TColumnTitle}) + private + FCaption: WideString; + procedure SetInheritedCaption(const Value: AnsiString); + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function IsCaptionStored: Boolean; + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + procedure RestoreDefaults; override; + function DefaultCaption: WideString; + published + property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored; + end; + +{TNT-WARN TColumn} +type + TTntColumn = class(TColumn{TNT-ALLOW TColumn}) + private + FWidePickList: TTntStrings; + function GetWidePickList: TTntStrings; + procedure SetWidePickList(const Value: TTntStrings); + procedure HandlePickListChange(Sender: TObject); + function GetTitle: TTntColumnTitle; + procedure SetTitle(const Value: TTntColumnTitle); + protected + procedure DefineProperties(Filer: TFiler); override; + function CreateTitle: TColumnTitle{TNT-ALLOW TColumnTitle}; override; + public + destructor Destroy; override; + property WidePickList: TTntStrings read GetWidePickList write SetWidePickList; + published +{TNT-WARN PickList} + property PickList{TNT-ALLOW PickList}: TTntStrings read GetWidePickList write SetWidePickList; + property Title: TTntColumnTitle read GetTitle write SetTitle; + end; + + { TDBGridInplaceEdit adds support for a button on the in-place editor, + which can be used to drop down a table-based lookup list, a stringlist-based + pick list, or (if button style is esEllipsis) fire the grid event + OnEditButtonClick. } + +type + TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit} = class(TInplaceEditList) + private + {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + FDataList: TDBLookupListBox; // 1st field - Delphi/BCB 6 TCustomDBGrid assumes this + FUseDataList: Boolean; // 2nd field - Delphi/BCB 6 TCustomDBGrid assumes this + {$ENDIF} + {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + FDataList: TDBLookupListBox; // 1st field - Delphi 7 TCustomDBGrid assumes this + FUseDataList: Boolean; // 2nd field - Delphi 7 TCustomDBGrid assumes this + {$ENDIF} + {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + FDataList: TDBLookupListBox; // 1st field - Delphi 9 TCustomDBGrid assumes this + FUseDataList: Boolean; // 2nd field - Delphi 9 TCustomDBGrid assumes this + {$ENDIF} + {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + FDataList: TDBLookupListBox; // 1st field - Delphi 10 TCustomDBGrid assumes this + FUseDataList: Boolean; // 2nd field - Delphi 10 TCustomDBGrid assumes this + {$ENDIF} + FLookupSource: TDatasource; + FWidePickListBox: TTntCustomListbox; + function GetWidePickListBox: TTntCustomListbox; + protected + procedure CloseUp(Accept: Boolean); override; + procedure DoEditButtonClick; override; + procedure DropDown; override; + procedure UpdateContents; override; + property UseDataList: Boolean read FUseDataList; + public + constructor Create(Owner: TComponent); override; + property DataList: TDBLookupListBox read FDataList; + property WidePickListBox: TTntCustomListbox read GetWidePickListBox; + end; + +type +{TNT-WARN TDBGridInplaceEdit} + TTntDBGridInplaceEdit = class(TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}) + private + FInDblClick: Boolean; + FBlockSetText: Boolean; + procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; + protected + function GetText: WideString; virtual; + procedure SetText(const Value: WideString); virtual; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure UpdateContents; override; + procedure DblClick; override; + public + property Text: WideString read GetText write SetText; + end; + +{TNT-WARN TDBGridColumns} + TTntDBGridColumns = class(TDBGridColumns{TNT-ALLOW TDBGridColumns}) + private + function GetColumn(Index: Integer): TTntColumn; + procedure SetColumn(Index: Integer; const Value: TTntColumn); + public + function Add: TTntColumn; + property Items[Index: Integer]: TTntColumn read GetColumn write SetColumn; default; + end; + + TTntGridDataLink = class(TGridDataLink) + private + OriginalSetText: TFieldSetTextEvent; + procedure GridUpdateFieldText(Sender: TField; const Text: AnsiString); + protected + procedure UpdateData; override; + procedure RecordChanged(Field: TField); override; + end; + +{TNT-WARN TCustomDBGrid} + TTntCustomDBGrid = class(TCustomDBGrid{TNT-ALLOW TCustomDBGrid}) + private + FEditText: WideString; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Msg: TWMChar); message WM_CHAR; + function GetColumns: TTntDBGridColumns; + procedure SetColumns(const Value: TTntDBGridColumns); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure ShowEditorChar(Ch: WideChar); dynamic; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function CreateColumns: TDBGridColumns{TNT-ALLOW TDBGridColumns}; override; + property Columns: TTntDBGridColumns read GetColumns write SetColumns; + function CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; override; + function CreateDataLink: TGridDataLink; override; + function GetEditText(ACol, ARow: Longint): WideString; reintroduce; + procedure DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState); override; + procedure SetEditText(ACol, ARow: Longint; const Value: AnsiString); override; + public + procedure DefaultDrawColumnCell(const Rect: TRect; DataCol: Integer; + Column: TTntColumn; State: TGridDrawState); dynamic; + procedure DefaultDrawDataCell(const Rect: TRect; Field: TField; + State: TGridDrawState); + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TDBGrid} + TTntDBGrid = class(TTntCustomDBGrid) + public + property Canvas; + property SelectedRows; + published + property Align; + property Anchors; + property BiDiMode; + property BorderStyle; + property Color; + property Columns stored False; //StoreColumns; + property Constraints; + property Ctl3D; + property DataSource; + property DefaultDrawing; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property FixedColor; + property Font; + property ImeMode; + property ImeName; + property Options; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly; + property ShowHint; + property TabOrder; + property TabStop; + property TitleFont; + property Visible; + property OnCellClick; + property OnColEnter; + property OnColExit; + property OnColumnMoved; + property OnDrawDataCell; { obsolete } + property OnDrawColumnCell; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditButtonClick; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnStartDock; + property OnStartDrag; + property OnTitleClick; + end; + +implementation + +uses + SysUtils, TntControls, Math, Variants, Forms, + TntGraphics, Graphics, TntDB, TntActnList, TntSysUtils, TntWindows; + +{ TTntColumnTitle } + +procedure TTntColumnTitle.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntColumnTitle.DefaultCaption: WideString; +var + Field: TField; +begin + Field := Column.Field; + if Assigned(Field) then + Result := Field.DisplayName + else + Result := Column.FieldName; +end; + +function TTntColumnTitle.IsCaptionStored: Boolean; +begin + Result := (cvTitleCaption in Column.AssignedValues) and + (FCaption <> DefaultCaption); +end; + +procedure TTntColumnTitle.SetInheritedCaption(const Value: AnsiString); +begin + inherited Caption := Value; +end; + +function TTntColumnTitle.GetCaption: WideString; +begin + if cvTitleCaption in Column.AssignedValues then + Result := GetSyncedWideString(FCaption, inherited Caption) + else + Result := DefaultCaption; +end; + +procedure TTntColumnTitle.SetCaption(const Value: WideString); +begin + if not (Column as TTntColumn).IsStored then + inherited Caption := Value + else begin + if (cvTitleCaption in Column.AssignedValues) and (Value = FCaption) then Exit; + SetSyncedWideString(Value, FCaption, inherited Caption, SetInheritedCaption); + end; +end; + +procedure TTntColumnTitle.Assign(Source: TPersistent); +begin + inherited Assign(Source); + if Source is TTntColumnTitle then + begin + if cvTitleCaption in TTntColumnTitle(Source).Column.AssignedValues then + Caption := TTntColumnTitle(Source).Caption; + end; +end; + +procedure TTntColumnTitle.RestoreDefaults; +begin + FCaption := ''; + inherited; +end; + +{ TTntColumn } + +procedure TTntColumn.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntColumn.CreateTitle: TColumnTitle{TNT-ALLOW TColumnTitle}; +begin + Result := TTntColumnTitle.Create(Self); +end; + +function TTntColumn.GetTitle: TTntColumnTitle; +begin + Result := (inherited Title) as TTntColumnTitle; +end; + +procedure TTntColumn.SetTitle(const Value: TTntColumnTitle); +begin + inherited Title := Value; +end; + +function TTntColumn.GetWidePickList: TTntStrings; +begin + if FWidePickList = nil then begin + FWidePickList := TTntStringList.Create; + TTntStringList(FWidePickList).OnChange := HandlePickListChange; + end; + Result := FWidePickList; +end; + +procedure TTntColumn.SetWidePickList(const Value: TTntStrings); +begin + if Value = nil then + begin + FWidePickList.Free; + FWidePickList := nil; + (inherited PickList{TNT-ALLOW PickList}).Clear; + Exit; + end; + WidePickList.Assign(Value); +end; + +procedure TTntColumn.HandlePickListChange(Sender: TObject); +begin + inherited PickList{TNT-ALLOW PickList}.Assign(WidePickList); +end; + +destructor TTntColumn.Destroy; +begin + inherited; + FWidePickList.Free; +end; + +{ TTntPopupListbox } +type + TTntPopupListbox = class(TTntCustomListbox) + private + FSearchText: WideString; + FSearchTickCount: Longint; + protected + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWnd; override; + procedure WMChar(var Message: TWMChar); message WM_CHAR; + procedure KeyPressW(var Key: WideChar); + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + end; + +procedure TTntPopupListbox.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + with Params do + begin + Style := Style or WS_BORDER; + ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST; + AddBiDiModeExStyle(ExStyle); + WindowClass.Style := CS_SAVEBITS; + end; +end; + +procedure TTntPopupListbox.CreateWnd; +begin + inherited CreateWnd; + Windows.SetParent(Handle, 0); + CallWindowProc(DefWndProc, Handle, wm_SetFocus, 0, 0); +end; + +procedure TTntPopupListbox.WMChar(var Message: TWMChar); +var + Key: WideChar; +begin + Key := GetWideCharFromWMCharMsg(Message); + KeyPressW(Key); + SetWideCharForWMCharMsg(Message, Key); + inherited; +end; + +procedure TTntPopupListbox.KeypressW(var Key: WideChar); +var + TickCount: Integer; +begin + case Key of + #8, #27: FSearchText := ''; + #32..High(WideChar): + begin + TickCount := GetTickCount; + if TickCount - FSearchTickCount > 2000 then FSearchText := ''; + FSearchTickCount := TickCount; + if Length(FSearchText) < 32 then FSearchText := FSearchText + Key; + if IsWindowUnicode(Handle) then + SendMessageW(Handle, LB_SelectString, WORD(-1), Longint(PWideChar(FSearchText))) + else + SendMessageA(Handle, LB_SelectString, WORD(-1), Longint(PAnsiChar(AnsiString(FSearchText)))); + Key := #0; + end; + end; +end; + +procedure TTntPopupListbox.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + inherited MouseUp(Button, Shift, X, Y); + (Owner as TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}).CloseUp((X >= 0) and (Y >= 0) and + (X < Width) and (Y < Height)); +end; + +{ TTntPopupDataList } +type + TTntPopupDataList = class(TPopupDataList) + protected + procedure Paint; override; + end; + +procedure TTntPopupDataList.Paint; +var + FRecordIndex: Integer; + FRecordCount: Integer; + FKeySelected: Boolean; + FKeyField: TField; + + procedure UpdateListVars; + begin + if ListActive then + begin + FRecordIndex := ListLink.ActiveRecord; + FRecordCount := ListLink.RecordCount; + FKeySelected := not VarIsNull(KeyValue) or + not ListLink.DataSet.BOF; + end else + begin + FRecordIndex := 0; + FRecordCount := 0; + FKeySelected := False; + end; + + FKeyField := nil; + if ListLink.Active and (KeyField <> '') then + FKeyField := GetFieldProperty(ListLink.DataSet, Self, KeyField); + end; + + function VarEquals(const V1, V2: Variant): Boolean; + begin + Result := False; + try + Result := V1 = V2; + except + end; + end; + +var + I, J, W, X, TxtWidth, TxtHeight, LastFieldIndex: Integer; + S: WideString; + R: TRect; + Selected: Boolean; + Field: TField; + AAlignment: TAlignment; +begin + UpdateListVars; + Canvas.Font := Font; + TxtWidth := WideCanvasTextWidth(Canvas, '0'); + TxtHeight := WideCanvasTextHeight(Canvas, '0'); + LastFieldIndex := ListFields.Count - 1; + if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then + Canvas.Pen.Color := clBtnFace else + Canvas.Pen.Color := clBtnShadow; + for I := 0 to RowCount - 1 do + begin + if Enabled then + Canvas.Font.Color := Font.Color else + Canvas.Font.Color := clGrayText; + Canvas.Brush.Color := Color; + Selected := not FKeySelected and (I = 0); + R.Top := I * TxtHeight; + R.Bottom := R.Top + TxtHeight; + if I < FRecordCount then + begin + ListLink.ActiveRecord := I; + if not VarIsNull(KeyValue) and + VarEquals(FKeyField.Value, KeyValue) then + begin + Canvas.Font.Color := clHighlightText; + Canvas.Brush.Color := clHighlight; + Selected := True; + end; + R.Right := 0; + for J := 0 to LastFieldIndex do + begin + Field := ListFields[J]; + if J < LastFieldIndex then + W := Field.DisplayWidth * TxtWidth + 4 else + W := ClientWidth - R.Right; + S := GetWideDisplayText(Field); + X := 2; + AAlignment := Field.Alignment; + if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment); + case AAlignment of + taRightJustify: X := W - WideCanvasTextWidth(Canvas, S) - 3; + taCenter: X := (W - WideCanvasTextWidth(Canvas, S)) div 2; + end; + R.Left := R.Right; + R.Right := R.Right + W; + if SysLocale.MiddleEast then TControlCanvas(Canvas).UpdateTextFlags; + WideCanvasTextRect(Canvas, R, R.Left + X, R.Top, S); + if J < LastFieldIndex then + begin + Canvas.MoveTo(R.Right, R.Top); + Canvas.LineTo(R.Right, R.Bottom); + Inc(R.Right); + if R.Right >= ClientWidth then Break; + end; + end; + end; + R.Left := 0; + R.Right := ClientWidth; + if I >= FRecordCount then Canvas.FillRect(R); + if Selected then + Canvas.DrawFocusRect(R); + end; + if FRecordCount <> 0 then ListLink.ActiveRecord := FRecordIndex; +end; + +//----------------------------------------------------------------------------------------- +// TDBGridInplaceEdit - Delphi 6 and higher +//----------------------------------------------------------------------------------------- + +constructor TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.Create(Owner: TComponent); +begin + inherited Create(Owner); + FLookupSource := TDataSource.Create(Self); +end; + +function TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.GetWidePickListBox: TTntCustomListBox; +var + PopupListbox: TTntPopupListbox; +begin + if not Assigned(FWidePickListBox) then + begin + PopupListbox := TTntPopupListbox.Create(Self); + PopupListbox.Visible := False; + PopupListbox.Parent := Self; + PopupListbox.OnMouseUp := ListMouseUp; + PopupListbox.IntegralHeight := True; + PopupListbox.ItemHeight := 11; + FWidePickListBox := PopupListBox; + end; + Result := FWidePickListBox; +end; + +procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.CloseUp(Accept: Boolean); +var + MasterField: TField; + ListValue: Variant; +begin + if ListVisible then + begin + if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0); + if ActiveList = DataList then + ListValue := DataList.KeyValue + else + if WidePickListBox.ItemIndex <> -1 then + ListValue := WidePickListBox.Items[WidePickListBox.ItemIndex]; + SetWindowPos(ActiveList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or + SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW); + ListVisible := False; + if Assigned(FDataList) then + FDataList.ListSource := nil; + FLookupSource.Dataset := nil; + Invalidate; + if Accept then + if ActiveList = DataList then + with Grid as TTntCustomDBGrid, Columns[SelectedIndex].Field do + begin + MasterField := DataSet.FieldByName(KeyFields); + if MasterField.CanModify and DataLink.Edit then + MasterField.Value := ListValue; + end + else + if (not VarIsNull(ListValue)) and EditCanModify then + with Grid as TTntCustomDBGrid do + SetWideText(Columns[SelectedIndex].Field, ListValue) + end; +end; + +procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.DoEditButtonClick; +begin + (Grid as TTntCustomDBGrid).EditButtonClick; +end; + +type TAccessTntCustomListbox = class(TTntCustomListbox); + +procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.DropDown; +var + Column: TTntColumn; + I, J, Y: Integer; +begin + if not ListVisible then + begin + with (Grid as TTntCustomDBGrid) do + Column := Columns[SelectedIndex] as TTntColumn; + if ActiveList = FDataList then + with Column.Field do + begin + FDataList.Color := Color; + FDataList.Font := Font; + FDataList.RowCount := Column.DropDownRows; + FLookupSource.DataSet := LookupDataSet; + FDataList.KeyField := LookupKeyFields; + FDataList.ListField := LookupResultField; + FDataList.ListSource := FLookupSource; + FDataList.KeyValue := DataSet.FieldByName(KeyFields).Value; + end + else if ActiveList = WidePickListBox then + begin + WidePickListBox.Items.Assign(Column.WidePickList); + DropDownRows := Column.DropDownRows; + // this is needed as inherited doesn't know about our WidePickListBox + if (DropDownRows > 0) and (WidePickListBox.Items.Count >= DropDownRows) then + WidePickListBox.Height := DropDownRows * TAccessTntCustomListbox(WidePickListBox as TTntCustomListbox).ItemHeight + 4 + else + WidePickListBox.Height := WidePickListBox.Items.Count * TAccessTntCustomListbox(WidePickListBox as TTntCustomListbox).ItemHeight + 4; + if Text = '' then + WidePickListBox.ItemIndex := -1 + else + WidePickListBox.ItemIndex := WidePickListBox.Items.IndexOf(Text); + J := WidePickListBox.ClientWidth; + for I := 0 to WidePickListBox.Items.Count - 1 do + begin + Y := WideCanvasTextWidth(WidePickListBox.Canvas, WidePickListBox.Items[I]); + if Y > J then J := Y; + end; + WidePickListBox.ClientWidth := J; + end; + end; + inherited DropDown; +end; + +procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.UpdateContents; +var + Column: TTntColumn; +begin + inherited UpdateContents; + if EditStyle = esPickList then + ActiveList := WidePickListBox; + if FUseDataList then + begin + if FDataList = nil then + begin + FDataList := TTntPopupDataList.Create(Self); + FDataList.Visible := False; + FDataList.Parent := Self; + FDataList.OnMouseUp := ListMouseUp; + end; + ActiveList := FDataList; + end; + with (Grid as TTntCustomDBGrid) do + Column := Columns[SelectedIndex] as TTntColumn; + Self.ReadOnly := Column.ReadOnly; + Font.Assign(Column.Font); + ImeMode := Column.ImeMode; + ImeName := Column.ImeName; +end; + +//----------------------------------------------------------------------------------------- + +{ TTntDBGridInplaceEdit } + +procedure TTntDBGridInplaceEdit.CreateWindowHandle(const Params: TCreateParams); +begin + TntCustomEdit_CreateWindowHandle(Self, Params); +end; + +function TTntDBGridInplaceEdit.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntDBGridInplaceEdit.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntDBGridInplaceEdit.WMSetText(var Message: TWMSetText); +begin + if (not FBlockSetText) then + inherited; +end; + +procedure TTntDBGridInplaceEdit.UpdateContents; +var + Grid: TTntCustomDBGrid; +begin + Grid := Self.Grid as TTntCustomDBGrid; + EditMask := Grid.GetEditMask(Grid.Col, Grid.Row); + Text := Grid.GetEditText(Grid.Col, Grid.Row); + MaxLength := Grid.GetEditLimit; + + FBlockSetText := True; + try + inherited; + finally + FBlockSetText := False; + end; +end; + +procedure TTntDBGridInplaceEdit.DblClick; +begin + FInDblClick := True; + try + inherited; + finally + FInDblClick := False; + end; +end; + +{ TTntGridDataLink } + +procedure TTntGridDataLink.GridUpdateFieldText(Sender: TField; const Text: AnsiString); +begin + Sender.OnSetText := OriginalSetText; + if Assigned(Sender) then + SetWideText(Sender, (Grid as TTntCustomDBGrid).FEditText); +end; + +procedure TTntGridDataLink.RecordChanged(Field: TField); +var + CField: TField; +begin + inherited; + if Grid.HandleAllocated then begin + CField := Grid.SelectedField; + if ((Field = nil) or (CField = Field)) and + (Assigned(CField) and (GetWideText(CField) <> (Grid as TTntCustomDBGrid).FEditText)) then + begin + with (Grid as TTntCustomDBGrid) do begin + InvalidateEditor; + if InplaceEditor <> nil then InplaceEditor.Deselect; + end; + end; + end; +end; + +procedure TTntGridDataLink.UpdateData; +var + Field: TField; +begin + Field := (Grid as TTntCustomDBGrid).SelectedField; + // remember "set text" + if Field <> nil then + OriginalSetText := Field.OnSetText; + try + // redirect "set text" to self + if Field <> nil then + Field.OnSetText := GridUpdateFieldText; + inherited; // clear modified ! + finally + // redirect "set text" to field + if Field <> nil then + Field.OnSetText := OriginalSetText; + // forget original "set text" + OriginalSetText := nil; + end; +end; + +{ TTntDBGridColumns } + +function TTntDBGridColumns.Add: TTntColumn; +begin + Result := inherited Add as TTntColumn; +end; + +function TTntDBGridColumns.GetColumn(Index: Integer): TTntColumn; +begin + Result := inherited Items[Index] as TTntColumn; +end; + +procedure TTntDBGridColumns.SetColumn(Index: Integer; const Value: TTntColumn); +begin + inherited Items[Index] := Value; +end; + +{ TTntCustomDBGrid } + +procedure TTntCustomDBGrid.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +type TAccessCustomGrid = class(TCustomGrid); + +procedure TTntCustomDBGrid.WMChar(var Msg: TWMChar); +begin + if (goEditing in TAccessCustomGrid(Self).Options) + and (AnsiChar(Msg.CharCode) in [^H, #32..#255]) then begin + RestoreWMCharMsg(TMessage(Msg)); + ShowEditorChar(WideChar(Msg.CharCode)); + end else + inherited; +end; + +procedure TTntCustomDBGrid.ShowEditorChar(Ch: WideChar); +begin + ShowEditor; + if InplaceEditor <> nil then begin + if Win32PlatformIsUnicode then + PostMessageW(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0) + else + PostMessageA(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0); + end; +end; + +procedure TTntCustomDBGrid.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomDBGrid.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomDBGrid.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomDBGrid.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntCustomDBGrid.CreateColumns: TDBGridColumns{TNT-ALLOW TDBGridColumns}; +begin + Result := TTntDBGridColumns.Create(Self, TTntColumn); +end; + +function TTntCustomDBGrid.GetColumns: TTntDBGridColumns; +begin + Result := inherited Columns as TTntDBGridColumns; +end; + +procedure TTntCustomDBGrid.SetColumns(const Value: TTntDBGridColumns); +begin + inherited Columns := Value; +end; + +function TTntCustomDBGrid.CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; +begin + Result := TTntDBGridInplaceEdit.Create(Self); +end; + +function TTntCustomDBGrid.CreateDataLink: TGridDataLink; +begin + Result := TTntGridDataLink.Create(Self); +end; + +function TTntCustomDBGrid.GetEditText(ACol, ARow: Integer): WideString; +var + Field: TField; +begin + Field := GetColField(RawToDataColumn(ACol)); + if Field = nil then + Result := '' + else + Result := GetWideText(Field); + FEditText := Result; +end; + +procedure TTntCustomDBGrid.SetEditText(ACol, ARow: Integer; const Value: AnsiString); +begin + if (InplaceEditor as TTntDBGridInplaceEdit).FInDblClick then + FEditText := Value + else + FEditText := (InplaceEditor as TTntDBGridInplaceEdit).Text; + inherited; +end; + +//----------------- DRAW CELL PROCS -------------------------------------------------- +var + DrawBitmap: TBitmap = nil; + +procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; + const Text: WideString; Alignment: TAlignment; ARightToLeft: Boolean); +const + AlignFlags : array [TAlignment] of Integer = + ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, + DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, + DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX ); + RTL: array [Boolean] of Integer = (0, DT_RTLREADING); +var + B, R: TRect; + Hold, Left: Integer; + I: TColorRef; +begin + I := ColorToRGB(ACanvas.Brush.Color); + if GetNearestColor(ACanvas.Handle, I) = I then + begin { Use ExtTextOutW for solid colors } + { In BiDi, because we changed the window origin, the text that does not + change alignment, actually gets its alignment changed. } + if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then + ChangeBiDiModeAlignment(Alignment); + case Alignment of + taLeftJustify: + Left := ARect.Left + DX; + taRightJustify: + Left := ARect.Right - WideCanvasTextWidth(ACanvas, Text) - 3; + else { taCenter } + Left := ARect.Left + (ARect.Right - ARect.Left) div 2 + - (WideCanvasTextWidth(ACanvas, Text) div 2); + end; + WideCanvasTextRect(ACanvas, ARect, Left, ARect.Top + DY, Text); + end + else begin { Use FillRect and Drawtext for dithered colors } + DrawBitmap.Canvas.Lock; + try + with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and } + begin { brush origin tics in painting / scrolling. } + Width := Max(Width, Right - Left); + Height := Max(Height, Bottom - Top); + R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1); + B := Rect(0, 0, Right - Left, Bottom - Top); + end; + with DrawBitmap.Canvas do + begin + Font := ACanvas.Font; + Font.Color := ACanvas.Font.Color; + Brush := ACanvas.Brush; + Brush.Style := bsSolid; + FillRect(B); + SetBkMode(Handle, TRANSPARENT); + if (ACanvas.CanvasOrientation = coRightToLeft) then + ChangeBiDiModeAlignment(Alignment); + Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), R, + AlignFlags[Alignment] or RTL[ARightToLeft]); + end; + if (ACanvas.CanvasOrientation = coRightToLeft) then + begin + Hold := ARect.Left; + ARect.Left := ARect.Right; + ARect.Right := Hold; + end; + ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B); + finally + DrawBitmap.Canvas.Unlock; + end; + end; +end; + +procedure TTntCustomDBGrid.DefaultDrawDataCell(const Rect: TRect; Field: TField; + State: TGridDrawState); +var + Alignment: TAlignment; + Value: WideString; +begin + Alignment := taLeftJustify; + Value := ''; + if Assigned(Field) then + begin + Alignment := Field.Alignment; + Value := GetWideDisplayText(Field); + end; + WriteText(Canvas, Rect, 2, 2, Value, Alignment, + UseRightToLeftAlignmentForField(Field, Alignment)); +end; + +procedure TTntCustomDBGrid.DefaultDrawColumnCell(const Rect: TRect; + DataCol: Integer; Column: TTntColumn; State: TGridDrawState); +var + Value: WideString; +begin + Value := ''; + if Assigned(Column.Field) then + Value := GetWideDisplayText(Column.Field); + WriteText(Canvas, Rect, 2, 2, Value, Column.Alignment, + UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)); +end; + +procedure TTntCustomDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); +var + FrameOffs: Byte; + + procedure DrawTitleCell(ACol, ARow: Integer; Column: TTntColumn; var AState: TGridDrawState); + const + ScrollArrows: array [Boolean, Boolean] of Integer = + ((DFCS_SCROLLRIGHT, DFCS_SCROLLLEFT), (DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT)); + var + MasterCol: TColumn{TNT-ALLOW TColumn}; + TitleRect, TxtRect, ButtonRect: TRect; + I: Integer; + InBiDiMode: Boolean; + begin + TitleRect := CalcTitleRect(Column, ARow, MasterCol); + + if MasterCol = nil then + begin + Canvas.FillRect(ARect); + Exit; + end; + + Canvas.Font := MasterCol.Title.Font; + Canvas.Brush.Color := MasterCol.Title.Color; + if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then + InflateRect(TitleRect, -1, -1); + TxtRect := TitleRect; + I := GetSystemMetrics(SM_CXHSCROLL); + if ((TxtRect.Right - TxtRect.Left) > I) and MasterCol.Expandable then + begin + Dec(TxtRect.Right, I); + ButtonRect := TitleRect; + ButtonRect.Left := TxtRect.Right; + I := SaveDC(Canvas.Handle); + try + Canvas.FillRect(ButtonRect); + InflateRect(ButtonRect, -1, -1); + IntersectClipRect(Canvas.Handle, ButtonRect.Left, + ButtonRect.Top, ButtonRect.Right, ButtonRect.Bottom); + InflateRect(ButtonRect, 1, 1); + { DrawFrameControl doesn't draw properly when orienatation has changed. + It draws as ExtTextOutW does. } + InBiDiMode := Canvas.CanvasOrientation = coRightToLeft; + if InBiDiMode then { stretch the arrows box } + Inc(ButtonRect.Right, GetSystemMetrics(SM_CXHSCROLL) + 4); + DrawFrameControl(Canvas.Handle, ButtonRect, DFC_SCROLL, + ScrollArrows[InBiDiMode, MasterCol.Expanded] or DFCS_FLAT); + finally + RestoreDC(Canvas.Handle, I); + end; + end; + with (MasterCol.Title as TTntColumnTitle) do + WriteText(Canvas, TxtRect, FrameOffs, FrameOffs, Caption, Alignment, IsRightToLeft); + if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then + begin + InflateRect(TitleRect, 1, 1); + DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_BOTTOMRIGHT); + DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_TOPLEFT); + end; + AState := AState - [gdFixed]; // prevent box drawing later + end; + +var + OldActive: Integer; + Highlight: Boolean; + Value: WideString; + DrawColumn: TTntColumn; +begin + if csLoading in ComponentState then + begin + Canvas.Brush.Color := Color; + Canvas.FillRect(ARect); + Exit; + end; + + if (gdFixed in AState) and (RawToDataColumn(ACol) < 0) then + begin + inherited; + exit; + end; + + Dec(ARow, FixedRows); + ACol := RawToDataColumn(ACol); + + if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = + [dgRowLines, dgColLines]) then + begin + InflateRect(ARect, -1, -1); + FrameOffs := 1; + end + else + FrameOffs := 2; + + with Canvas do + begin + DrawColumn := Columns[ACol] as TTntColumn; + if not DrawColumn.Showing then Exit; + if not (gdFixed in AState) then + begin + Font := DrawColumn.Font; + Brush.Color := DrawColumn.Color; + end; + if ARow < 0 then + DrawTitleCell(ACol, ARow + FixedRows, DrawColumn, AState) + else if (DataLink = nil) or not DataLink.Active then + FillRect(ARect) + else + begin + Value := ''; + OldActive := DataLink.ActiveRecord; + try + DataLink.ActiveRecord := ARow; + if Assigned(DrawColumn.Field) then + Value := GetWideDisplayText(DrawColumn.Field); + Highlight := HighlightCell(ACol, ARow, Value, AState); + if Highlight then + begin + Brush.Color := clHighlight; + Font.Color := clHighlightText; + end; + if not Enabled then + Font.Color := clGrayText; + if DefaultDrawing then + DefaultDrawColumnCell(ARect, ACol, DrawColumn, AState); + if Columns.State = csDefault then + DrawDataCell(ARect, DrawColumn.Field, AState); + DrawColumnCell(ARect, ACol, DrawColumn, AState); + finally + DataLink.ActiveRecord := OldActive; + end; + if DefaultDrawing and (gdSelected in AState) + and ((dgAlwaysShowSelection in Options) or Focused) + and not (csDesigning in ComponentState) + and not (dgRowSelect in Options) + and (UpdateLock = 0) + and (ValidParentForm(Self).ActiveControl = Self) then + Windows.DrawFocusRect(Handle, ARect); + end; + end; + if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = + [dgRowLines, dgColLines]) then + begin + InflateRect(ARect, 1, 1); + DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMRIGHT); + DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPLEFT); + end; +end; + +procedure TTntCustomDBGrid.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomDBGrid.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +initialization + DrawBitmap := TBitmap.Create; + +finalization + DrawBitmap.Free; + +end. diff --git a/Source/TntDBLogDlg.dfm b/Source/TntDBLogDlg.dfm new file mode 100644 index 0000000..fd0a071 --- /dev/null +++ b/Source/TntDBLogDlg.dfm @@ -0,0 +1,108 @@ +object TntLoginDialog: TTntLoginDialog + Left = 307 + Top = 131 + ActiveControl = Password + BorderStyle = bsDialog + Caption = 'Database Login' + ClientHeight = 147 + ClientWidth = 273 + Color = clBtnFace + ParentFont = True + + Position = poScreenCenter + OnShow = FormShow + PixelsPerInch = 96 + TextHeight = 13 + object OKButton: TTntButton + Left = 109 + Top = 114 + Width = 75 + Height = 25 + Caption = '&OK' + Default = True + ModalResult = 1 + TabOrder = 0 + end + object CancelButton: TTntButton + Left = 190 + Top = 114 + Width = 75 + Height = 25 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 1 + end + object Panel: TTntPanel + Left = 8 + Top = 7 + Width = 257 + Height = 98 + BevelInner = bvRaised + BevelOuter = bvLowered + TabOrder = 2 + object Label3: TTntLabel + Left = 10 + Top = 6 + Width = 50 + Height = 13 + Caption = 'Database:' + end + object DatabaseName: TTntLabel + Left = 91 + Top = 6 + Width = 3 + Height = 13 + end + object Bevel: TTntBevel + Left = 1 + Top = 24 + Width = 254 + Height = 9 + Shape = bsTopLine + end + object Panel1: TTntPanel + Left = 2 + Top = 31 + Width = 253 + Height = 65 + Align = alBottom + BevelOuter = bvNone + TabOrder = 0 + object Label1: TTntLabel + Left = 8 + Top = 8 + Width = 56 + Height = 13 + Caption = '&User Name:' + FocusControl = UserName + end + object Label2: TTntLabel + Left = 8 + Top = 36 + Width = 50 + Height = 13 + Caption = '&Password:' + FocusControl = Password + end + object UserName: TTntEdit + Left = 86 + Top = 5 + Width = 153 + Height = 21 + MaxLength = 31 + TabOrder = 0 + end + object Password: TTntEdit + Left = 86 + Top = 33 + Width = 153 + Height = 21 + MaxLength = 31 + PasswordCharW = #9679 + TabOrder = 1 + PasswordChar_UTF7 = '+Jc8' + end + end + end +end diff --git a/Source/TntDBLogDlg.pas b/Source/TntDBLogDlg.pas new file mode 100644 index 0000000..c8747e2 --- /dev/null +++ b/Source/TntDBLogDlg.pas @@ -0,0 +1,133 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDBLogDlg; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + SysUtils, Windows, Messages, Classes, Graphics, + TntForms, TntStdCtrls, TntExtCtrls, StdCtrls, ExtCtrls, Controls; + +type + TTntLoginDialog = class(TTntForm) + Panel: TTntPanel; + Bevel: TTntBevel; + DatabaseName: TTntLabel; + OKButton: TTntButton; + CancelButton: TTntButton; + Panel1: TTntPanel; + Label1: TTntLabel; + Label2: TTntLabel; + Label3: TTntLabel; + Password: TTntEdit; + UserName: TTntEdit; + procedure FormShow(Sender: TObject); + end; + +{TNT-WARN LoginDialog} +function TntLoginDialog(const ADatabaseName: WideString; + var AUserName, APassword: WideString): Boolean; + +{TNT-WARN LoginDialogEx} +function TntLoginDialogEx(const ADatabaseName: WideString; + var AUserName, APassword: WideString; NameReadOnly: Boolean): Boolean; + +{TNT-WARN RemoteLoginDialog} +function TntRemoteLoginDialog(var AUserName, APassword: WideString): Boolean; + +implementation + +{$R *.dfm} + +uses + Forms, VDBConsts; + +function TntLoginDialog(const ADatabaseName: WideString; + var AUserName, APassword: WideString): Boolean; +begin + with TTntLoginDialog.Create(Application) do + try + DatabaseName.Caption := ADatabaseName; + UserName.Text := AUserName; + Result := False; + if AUserName = '' then ActiveControl := UserName; + if ShowModal = mrOk then + begin + AUserName := UserName.Text; + APassword := Password.Text; + Result := True; + end; + finally + Free; + end; +end; + +function TntLoginDialogEx(const ADatabaseName: WideString; + var AUserName, APassword: WideString; NameReadOnly: Boolean): Boolean; +begin + with TTntLoginDialog.Create(Application) do + try + DatabaseName.Caption := ADatabaseName; + UserName.Text := AUserName; + Result := False; + if NameReadOnly then + UserName.Enabled := False + else + if AUserName = '' then ActiveControl := UserName; + if ShowModal = mrOk then + begin + AUserName := UserName.Text; + APassword := Password.Text; + Result := True; + end; + finally + Free; + end; +end; + +function TntRemoteLoginDialog(var AUserName, APassword: WideString): Boolean; +begin + with TTntLoginDialog.Create(Application) do + try + Caption := SRemoteLogin; + Bevel.Visible := False; + DatabaseName.Visible := False; + Label3.Visible := False; + Panel.Height := Panel.Height - Bevel.Top; + OKButton.Top := OKButton.Top - Bevel.Top; + CancelButton.Top := CancelButton.Top - Bevel.Top; + Height := Height - Bevel.Top; + UserName.Text := AUserName; + Result := False; + if AUserName = '' then ActiveControl := UserName; + if ShowModal = mrOk then + begin + AUserName := UserName.Text; + APassword := Password.Text; + Result := True; + end; + finally + Free; + end; +end; + +{ TTntLoginDialog } + +procedure TTntLoginDialog.FormShow(Sender: TObject); +begin + if (DatabaseName.Width + DatabaseName.Left) >= Panel.ClientWidth then + DatabaseName.Width := (Panel.ClientWidth - DatabaseName.Left) - 5; +end; + +end. diff --git a/Source/TntDialogs.pas b/Source/TntDialogs.pas new file mode 100644 index 0000000..0c06d07 --- /dev/null +++ b/Source/TntDialogs.pas @@ -0,0 +1,981 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntDialogs; + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: TFindDialog and TReplaceDialog. } +{ TODO: Property editor for TTntOpenDialog.Filter } + +uses + Classes, Messages, CommDlg, Windows, Dialogs, + TntClasses, TntForms, TntSysUtils; + +type +{TNT-WARN TIncludeItemEvent} + TIncludeItemEventW = procedure (const OFN: TOFNotifyExW; var Include: Boolean) of object; + +{TNT-WARN TOpenDialog} + TTntOpenDialog = class(TOpenDialog{TNT-ALLOW TOpenDialog}) + private + FDefaultExt: WideString; + FFileName: TWideFileName; + FFilter: WideString; + FInitialDir: WideString; + FTitle: WideString; + FFiles: TTntStrings; + FOnIncludeItem: TIncludeItemEventW; + function GetDefaultExt: WideString; + procedure SetInheritedDefaultExt(const Value: AnsiString); + procedure SetDefaultExt(const Value: WideString); + function GetFileName: TWideFileName; + procedure SetFileName(const Value: TWideFileName); + function GetFilter: WideString; + procedure SetInheritedFilter(const Value: AnsiString); + procedure SetFilter(const Value: WideString); + function GetInitialDir: WideString; + procedure SetInheritedInitialDir(const Value: AnsiString); + procedure SetInitialDir(const Value: WideString); + function GetTitle: WideString; + procedure SetInheritedTitle(const Value: AnsiString); + procedure SetTitle(const Value: WideString); + function GetFiles: TTntStrings; + private + FProxiedOpenFilenameA: TOpenFilenameA; + protected + FAllowDoCanClose: Boolean; + procedure DefineProperties(Filer: TFiler); override; + function CanCloseW(var OpenFileName: TOpenFileNameW): Boolean; + function DoCanClose: Boolean; override; + procedure GetFileNamesW(var OpenFileName: TOpenFileNameW); + procedure DoIncludeItem(const OFN: TOFNotifyEx; var Include: Boolean); override; + procedure WndProc(var Message: TMessage); override; + function DoExecuteW(Func: Pointer; ParentWnd: HWND): Bool; overload; + function DoExecuteW(Func: Pointer): Bool; overload; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function Execute: Boolean; override; + {$IFDEF COMPILER_9_UP} + function Execute(ParentWnd: HWND): Boolean; override; + {$ENDIF} + property Files: TTntStrings read GetFiles; + published + property DefaultExt: WideString read GetDefaultExt write SetDefaultExt; + property FileName: TWideFileName read GetFileName write SetFileName; + property Filter: WideString read GetFilter write SetFilter; + property InitialDir: WideString read GetInitialDir write SetInitialDir; + property Title: WideString read GetTitle write SetTitle; + property OnIncludeItem: TIncludeItemEventW read FOnIncludeItem write FOnIncludeItem; + end; + +{TNT-WARN TSaveDialog} + TTntSaveDialog = class(TTntOpenDialog) + public + function Execute: Boolean; override; + {$IFDEF COMPILER_9_UP} + function Execute(ParentWnd: HWND): Boolean; override; + {$ENDIF} + end; + +{ Message dialog } + +{TNT-WARN CreateMessageDialog} +function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons): TTntForm;overload; +function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn): TTntForm; overload; + +{TNT-WARN MessageDlg} +function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; overload; +function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): Integer; overload; + +{TNT-WARN MessageDlgPos} +function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer; overload; +function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; DefaultButton: TMsgDlgBtn): Integer; overload; + +{TNT-WARN MessageDlgPosHelp} +function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString): Integer; overload; +function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString; DefaultButton: TMsgDlgBtn): Integer; overload; + +{TNT-WARN ShowMessage} +procedure WideShowMessage(const Msg: WideString); +{TNT-WARN ShowMessageFmt} +procedure WideShowMessageFmt(const Msg: WideString; Params: array of const); +{TNT-WARN ShowMessagePos} +procedure WideShowMessagePos(const Msg: WideString; X, Y: Integer); + +{ Input dialog } + +{TNT-WARN InputQuery} +function WideInputQuery(const ACaption, APrompt: WideString; + var Value: WideString): Boolean; +{TNT-WARN InputBox} +function WideInputBox(const ACaption, APrompt, ADefault: WideString): WideString; + +{TNT-WARN PromptForFileName} +function WidePromptForFileName(var AFileName: WideString; const AFilter: WideString = ''; + const ADefaultExt: WideString = ''; const ATitle: WideString = ''; + const AInitialDir: WideString = ''; SaveDialog: Boolean = False): Boolean; + +function GetModalParentWnd: HWND; + +implementation + +uses + Controls, Forms, Types, SysUtils, Graphics, Consts, Math, + TntWindows, TntStdCtrls, TntClipBrd, TntExtCtrls, + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; + +function GetModalParentWnd: HWND; +begin + {$IFDEF COMPILER_9} + Result := Application.ActiveFormHandle; + {$ELSE} + Result := 0; + {$ENDIF} + {$IFDEF COMPILER_10_UP} + if Application.ModalPopupMode <> pmNone then + begin + Result := Application.ActiveFormHandle; + end; + {$ENDIF} + if Result = 0 then begin + Result := Application.Handle; + end; +end; + +var + ProxyExecuteDialog: TTntOpenDialog; + +function ProxyGetOpenFileNameA(var OpenFile: TOpenFilename): Bool; stdcall; +begin + ProxyExecuteDialog.FProxiedOpenFilenameA := OpenFile; + Result := False; { as if user hit "Cancel". } +end; + +{ TTntOpenDialog } + +constructor TTntOpenDialog.Create(AOwner: TComponent); +begin + inherited; + FFiles := TTntStringList.Create; +end; + +destructor TTntOpenDialog.Destroy; +begin + FreeAndNil(FFiles); + inherited; +end; + +procedure TTntOpenDialog.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntOpenDialog.GetDefaultExt: WideString; +begin + Result := GetSyncedWideString(FDefaultExt, inherited DefaultExt); +end; + +procedure TTntOpenDialog.SetInheritedDefaultExt(const Value: AnsiString); +begin + inherited DefaultExt := Value; +end; + +procedure TTntOpenDialog.SetDefaultExt(const Value: WideString); +begin + SetSyncedWideString(Value, FDefaultExt, inherited DefaultExt, SetInheritedDefaultExt); +end; + +function TTntOpenDialog.GetFileName: TWideFileName; +var + Path: array[0..MAX_PATH] of WideChar; +begin + if Win32PlatformIsUnicode and NewStyleControls and (Handle <> 0) then begin + // get filename from handle + SendMessageW(GetParent(Handle), CDM_GETFILEPATH, SizeOf(Path), Integer(@Path)); + Result := Path; + end else + Result := GetSyncedWideString(WideString(FFileName), inherited FileName); +end; + +procedure TTntOpenDialog.SetFileName(const Value: TWideFileName); +begin + FFileName := Value; + inherited FileName := Value; +end; + +function TTntOpenDialog.GetFilter: WideString; +begin + Result := GetSyncedWideString(FFilter, inherited Filter); +end; + +procedure TTntOpenDialog.SetInheritedFilter(const Value: AnsiString); +begin + inherited Filter := Value; +end; + +procedure TTntOpenDialog.SetFilter(const Value: WideString); +begin + SetSyncedWideString(Value, FFilter, inherited Filter, SetInheritedFilter); +end; + +function TTntOpenDialog.GetInitialDir: WideString; +begin + Result := GetSyncedWideString(FInitialDir, inherited InitialDir); +end; + +procedure TTntOpenDialog.SetInheritedInitialDir(const Value: AnsiString); +begin + inherited InitialDir := Value; +end; + +procedure TTntOpenDialog.SetInitialDir(const Value: WideString); + + function RemoveTrailingPathDelimiter(const Value: WideString): WideString; + var + L: Integer; + begin + // remove trailing path delimiter (except 'C:\') + L := Length(Value); + if (L > 1) and WideIsPathDelimiter(Value, L) and not WideIsDelimiter(':', Value, L - 1) then + Dec(L); + Result := Copy(Value, 1, L); + end; + +begin + SetSyncedWideString(RemoveTrailingPathDelimiter(Value), FInitialDir, + inherited InitialDir, SetInheritedInitialDir); +end; + +function TTntOpenDialog.GetTitle: WideString; +begin + Result := GetSyncedWideString(FTitle, inherited Title) +end; + +procedure TTntOpenDialog.SetInheritedTitle(const Value: AnsiString); +begin + inherited Title := Value; +end; + +procedure TTntOpenDialog.SetTitle(const Value: WideString); +begin + SetSyncedWideString(Value, FTitle, inherited Title, SetInheritedTitle); +end; + +function TTntOpenDialog.GetFiles: TTntStrings; +begin + if (not Win32PlatformIsUnicode) then + FFiles.Assign(inherited Files); + Result := FFiles; +end; + +function TTntOpenDialog.DoCanClose: Boolean; +begin + if FAllowDoCanClose then + Result := inherited DoCanClose + else + Result := True; +end; + +function TTntOpenDialog.CanCloseW(var OpenFileName: TOpenFileNameW): Boolean; +begin + GetFileNamesW(OpenFileName); + FAllowDoCanClose := True; + try + Result := DoCanClose; + finally + FAllowDoCanClose := False; + end; + FFiles.Clear; + inherited Files.Clear; +end; + +procedure TTntOpenDialog.DoIncludeItem(const OFN: TOFNotifyEx; var Include: Boolean); +begin + // CDN_INCLUDEITEM -> DoIncludeItem() is only be available on Windows 2000 + + // Therefore, just cast OFN as a TOFNotifyExW, since that's what it really is. + if Win32PlatformIsUnicode and Assigned(FOnIncludeItem) then + FOnIncludeItem(TOFNotifyExW(OFN), Include) +end; + +procedure TTntOpenDialog.WndProc(var Message: TMessage); +begin + Message.Result := 0; + if (Message.Msg = WM_INITDIALOG) and not (ofOldStyleDialog in Options) then begin + { If not ofOldStyleDialog then DoShow on CDN_INITDONE, not WM_INITDIALOG } + Exit; + end; + if Win32PlatformIsUnicode + and (Message.Msg = WM_NOTIFY) then begin + case (POFNotify(Message.LParam)^.hdr.code) of + CDN_FILEOK: + if not CanCloseW(POFNotifyW(Message.LParam)^.lpOFN^) then + begin + Message.Result := 1; + SetWindowLong(Handle, DWL_MSGRESULT, Message.Result); + Exit; + end; + end; + end; + inherited WndProc(Message); +end; + +function TTntOpenDialog.DoExecuteW(Func: Pointer): Bool; +begin + Result := DoExecuteW(Func, GetModalParentWnd); +end; + +function TTntOpenDialog.DoExecuteW(Func: Pointer; ParentWnd: HWND): Bool; +var + OpenFilename: TOpenFilenameW; + + function GetResNamePtr(var ScopedStringStorage: WideString; lpszName: PAnsiChar): PWideChar; + // duplicated from TntTrxResourceUtils.pas + begin + if Tnt_Is_IntResource(PWideChar(lpszName)) then + Result := PWideChar(lpszName) + else begin + ScopedStringStorage := lpszName; + Result := PWideChar(ScopedStringStorage); + end; + end; + + function AllocFilterStr(const S: WideString): WideString; + var + P: PWideChar; + begin + Result := ''; + if S <> '' then + begin + Result := S + #0#0; // double null terminators (an additional zero added in case Description/Filter pair not even.) + P := WStrScan(PWideChar(Result), '|'); + while P <> nil do + begin + P^ := #0; + Inc(P); + P := WStrScan(P, '|'); + end; + end; + end; + +var + TempTemplate, TempFilter, TempFilename, TempExt: WideString; +begin + FFiles.Clear; + + // 1. Init inherited dialog defaults. + // 2. Populate OpenFileName record with ansi defaults + ProxyExecuteDialog := Self; + try + DoExecute(@ProxyGetOpenFileNameA); + finally + ProxyExecuteDialog := nil; + end; + OpenFileName := TOpenFilenameW(FProxiedOpenFilenameA); + + with OpenFilename do + begin + if not IsWindow(hWndOwner) then begin + hWndOwner := ParentWnd; + end; + // Filter (PChar -> PWideChar) + TempFilter := AllocFilterStr(Filter); + lpstrFilter := PWideChar(TempFilter); + // FileName (PChar -> PWideChar) + SetLength(TempFilename, nMaxFile + 2); + lpstrFile := PWideChar(TempFilename); + FillChar(lpstrFile^, (nMaxFile + 2) * SizeOf(WideChar), 0); + WStrLCopy(lpstrFile, PWideChar(FileName), nMaxFile); + // InitialDir (PChar -> PWideChar) + if (InitialDir = '') and ForceCurrentDirectory then + lpstrInitialDir := '.' + else + lpstrInitialDir := PWideChar(InitialDir); + // Title (PChar -> PWideChar) + lpstrTitle := PWideChar(Title); + // DefaultExt (PChar -> PWideChar) + TempExt := DefaultExt; + if (TempExt = '') and (Flags and OFN_EXPLORER = 0) then + begin + TempExt := WideExtractFileExt(Filename); + Delete(TempExt, 1, 1); + end; + if TempExt <> '' then + lpstrDefExt := PWideChar(TempExt); + // resource template (PChar -> PWideChar) + lpTemplateName := GetResNamePtr(TempTemplate, Template); + // start modal dialog + Result := TaskModalDialog(Func, OpenFileName); + if Result then + begin + GetFileNamesW(OpenFilename); + if (Flags and OFN_EXTENSIONDIFFERENT) <> 0 then + Options := Options + [ofExtensionDifferent] + else + Options := Options - [ofExtensionDifferent]; + if (Flags and OFN_READONLY) <> 0 then + Options := Options + [ofReadOnly] + else + Options := Options - [ofReadOnly]; + FilterIndex := nFilterIndex; + end; + end; +end; + +procedure TTntOpenDialog.GetFileNamesW(var OpenFileName: TOpenFileNameW); +var + Separator: WideChar; + + procedure ExtractFileNamesW(P: PWideChar); + var + DirName, FileName: TWideFileName; + FileList: TWideStringDynArray; + i: integer; + begin + FileList := ExtractStringsFromStringArray(P, Separator); + if Length(FileList) = 0 then + FFiles.Add('') + else begin + DirName := FileList[0]; + if Length(FileList) = 1 then + FFiles.Add(DirName) + else begin + // prepare DirName + if WideLastChar(DirName) <> WideString(PathDelim) then + DirName := DirName + PathDelim; + // add files + for i := 1 {second item} to High(FileList) do begin + FileName := FileList[i]; + // prepare FileName + if (FileName[1] <> PathDelim) + and ((Length(FileName) <= 3) or (FileName[2] <> DriveDelim) or (FileName[3] <> PathDelim)) + then + FileName := DirName + FileName; + // add to list + FFiles.Add(FileName); + end; + end; + end; + end; + +var + P: PWideChar; +begin + Separator := #0; + if (ofAllowMultiSelect in Options) and + ((ofOldStyleDialog in Options) or not NewStyleControls) then + Separator := ' '; + with OpenFileName do + begin + if ofAllowMultiSelect in Options then + begin + ExtractFileNamesW(lpstrFile); + FileName := FFiles[0]; + end else + begin + P := lpstrFile; + FileName := ExtractStringFromStringArray(P, Separator); + FFiles.Add(FileName); + end; + end; + + // Sync inherited Files + inherited Files.Assign(FFiles); +end; + +function TTntOpenDialog.Execute: Boolean; +begin + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetOpenFileNameA) + else + Result := DoExecuteW(@GetOpenFileNameW); +end; + +{$IFDEF COMPILER_9_UP} +function TTntOpenDialog.Execute(ParentWnd: HWND): Boolean; +begin + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetOpenFileNameA, ParentWnd) + else + Result := DoExecuteW(@GetOpenFileNameW, ParentWnd); +end; +{$ENDIF} + +{ TTntSaveDialog } + +function TTntSaveDialog.Execute: Boolean; +begin + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetSaveFileNameA) + else + Result := DoExecuteW(@GetSaveFileNameW); +end; + +{$IFDEF COMPILER_9_UP} +function TTntSaveDialog.Execute(ParentWnd: HWND): Boolean; +begin + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetSaveFileNameA, ParentWnd) + else + Result := DoExecuteW(@GetSaveFileNameW, ParentWnd); +end; +{$ENDIF} + +{ Message dialog } + +function GetAveCharSize(Canvas: TCanvas): TPoint; +var + I: Integer; + Buffer: array[0..51] of WideChar; + tm: TTextMetric; +begin + for I := 0 to 25 do Buffer[I] := WideChar(I + Ord('A')); + for I := 0 to 25 do Buffer[I + 26] := WideChar(I + Ord('a')); + GetTextMetrics(Canvas.Handle, tm); + GetTextExtentPointW(Canvas.Handle, Buffer, 52, TSize(Result)); + Result.X := (Result.X div 26 + 1) div 2; + Result.Y := tm.tmHeight; +end; + +type + TTntMessageForm = class(TTntForm) + private + Message: TTntLabel; + procedure HelpButtonClick(Sender: TObject); + protected + procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + function GetFormText: WideString; + public + constructor CreateNew(AOwner: TComponent); reintroduce; + end; + +constructor TTntMessageForm.CreateNew(AOwner: TComponent); +var + NonClientMetrics: TNonClientMetrics; +begin + inherited CreateNew(AOwner); + NonClientMetrics.cbSize := sizeof(NonClientMetrics); + if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then + Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont); +end; + +procedure TTntMessageForm.HelpButtonClick(Sender: TObject); +begin + Application.HelpContext(HelpContext); +end; + +procedure TTntMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if (Shift = [ssCtrl]) and (Key = Word('C')) then + begin + Beep; + TntClipboard.AsWideText := GetFormText; + end; +end; + +function TTntMessageForm.GetFormText: WideString; +var + DividerLine, ButtonCaptions: WideString; + I: integer; +begin + DividerLine := StringOfChar('-', 27) + sLineBreak; + for I := 0 to ComponentCount - 1 do + if Components[I] is TTntButton then + ButtonCaptions := ButtonCaptions + TTntButton(Components[I]).Caption + + StringOfChar(' ', 3); + ButtonCaptions := Tnt_WideStringReplace(ButtonCaptions,'&','', [rfReplaceAll]); + Result := DividerLine + Caption + sLineBreak + DividerLine + Message.Caption + sLineBreak + + DividerLine + ButtonCaptions + sLineBreak + DividerLine; +end; + +function GetMessageCaption(MsgType: TMsgDlgType): WideString; +begin + case MsgType of + mtWarning: Result := SMsgDlgWarning; + mtError: Result := SMsgDlgError; + mtInformation: Result := SMsgDlgInformation; + mtConfirmation: Result := SMsgDlgConfirm; + mtCustom: Result := ''; + else + raise ETntInternalError.Create('Unexpected MsgType in GetMessageCaption.'); + end; +end; + +function GetButtonCaption(MsgDlgBtn: TMsgDlgBtn): WideString; +begin + case MsgDlgBtn of + mbYes: Result := SMsgDlgYes; + mbNo: Result := SMsgDlgNo; + mbOK: Result := SMsgDlgOK; + mbCancel: Result := SMsgDlgCancel; + mbAbort: Result := SMsgDlgAbort; + mbRetry: Result := SMsgDlgRetry; + mbIgnore: Result := SMsgDlgIgnore; + mbAll: Result := SMsgDlgAll; + mbNoToAll: Result := SMsgDlgNoToAll; + mbYesToAll: Result := SMsgDlgYesToAll; + mbHelp: Result := SMsgDlgHelp; + else + raise ETntInternalError.Create('Unexpected MsgDlgBtn in GetButtonCaption.'); + end; +end; + +var + IconIDs: array[TMsgDlgType] of PAnsiChar = (IDI_EXCLAMATION, IDI_HAND, + IDI_ASTERISK, IDI_QUESTION, nil); + ButtonNames: array[TMsgDlgBtn] of WideString = ( + 'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll', + 'YesToAll', 'Help'); + ModalResults: array[TMsgDlgBtn] of Integer = ( + mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll, + mrYesToAll, 0); + +function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn): TTntForm; +const + mcHorzMargin = 8; + mcVertMargin = 8; + mcHorzSpacing = 10; + mcVertSpacing = 10; + mcButtonWidth = 50; + mcButtonHeight = 14; + mcButtonSpacing = 4; +var + DialogUnits: TPoint; + HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth, + ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth, + IconTextWidth, IconTextHeight, X, ALeft: Integer; + B, CancelButton: TMsgDlgBtn; + IconID: PAnsiChar; + ATextRect: TRect; + ThisButtonWidth: integer; + LButton: TTntButton; +begin + Result := TTntMessageForm.CreateNew(Application); + with Result do + begin + BorderStyle := bsDialog; // By doing this first, it will work on WINE. + BiDiMode := Application.BiDiMode; + Canvas.Font := Font; + KeyPreview := True; + Position := poDesigned; + OnKeyDown := TTntMessageForm(Result).CustomKeyDown; + DialogUnits := GetAveCharSize(Canvas); + HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4); + VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8); + HorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4); + VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8); + ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4); + for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do + begin + if B in Buttons then + begin + ATextRect := Rect(0,0,0,0); + Tnt_DrawTextW(Canvas.Handle, + PWideChar(GetButtonCaption(B)), -1, + ATextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or + DrawTextBiDiModeFlagsReadingOnly); + with ATextRect do ThisButtonWidth := Right - Left + 8; + if ThisButtonWidth > ButtonWidth then + ButtonWidth := ThisButtonWidth; + end; + end; + ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8); + ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4); + SetRect(ATextRect, 0, 0, Screen.Width div 2, 0); + Tnt_DrawTextW(Canvas.Handle, PWideChar(Msg), Length(Msg) + 1, ATextRect, + DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or + DrawTextBiDiModeFlagsReadingOnly); + IconID := IconIDs[DlgType]; + IconTextWidth := ATextRect.Right; + IconTextHeight := ATextRect.Bottom; + if IconID <> nil then + begin + Inc(IconTextWidth, 32 + HorzSpacing); + if IconTextHeight < 32 then IconTextHeight := 32; + end; + ButtonCount := 0; + for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do + if B in Buttons then Inc(ButtonCount); + ButtonGroupWidth := 0; + if ButtonCount <> 0 then + ButtonGroupWidth := ButtonWidth * ButtonCount + + ButtonSpacing * (ButtonCount - 1); + ClientWidth := Max(IconTextWidth, ButtonGroupWidth) + HorzMargin * 2; + ClientHeight := IconTextHeight + ButtonHeight + VertSpacing + + VertMargin * 2; + Left := (Screen.Width div 2) - (Width div 2); + Top := (Screen.Height div 2) - (Height div 2); + if DlgType <> mtCustom then + Caption := GetMessageCaption(DlgType) + else + Caption := TntApplication.Title; + if IconID <> nil then + with TTntImage.Create(Result) do + begin + Name := 'Image'; + Parent := Result; + Picture.Icon.Handle := LoadIcon(0, IconID); + SetBounds(HorzMargin, VertMargin, 32, 32); + end; + TTntMessageForm(Result).Message := TTntLabel.Create(Result); + with TTntMessageForm(Result).Message do + begin + Name := 'Message'; + Parent := Result; + WordWrap := True; + Caption := Msg; + BoundsRect := ATextRect; + BiDiMode := Result.BiDiMode; + ALeft := IconTextWidth - ATextRect.Right + HorzMargin; + if UseRightToLeftAlignment then + ALeft := Result.ClientWidth - ALeft - Width; + SetBounds(ALeft, VertMargin, + ATextRect.Right, ATextRect.Bottom); + end; + if mbCancel in Buttons then CancelButton := mbCancel else + if mbNo in Buttons then CancelButton := mbNo else + CancelButton := mbOk; + X := (ClientWidth - ButtonGroupWidth) div 2; + for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do + if B in Buttons then + begin + LButton := TTntButton.Create(Result); + with LButton do + begin + Name := ButtonNames[B]; + Parent := Result; + Caption := GetButtonCaption(B); + ModalResult := ModalResults[B]; + if B = DefaultButton then + begin + Default := True; + ActiveControl := LButton; + end; + if B = CancelButton then + Cancel := True; + SetBounds(X, IconTextHeight + VertMargin + VertSpacing, + ButtonWidth, ButtonHeight); + Inc(X, ButtonWidth + ButtonSpacing); + if B = mbHelp then + OnClick := TTntMessageForm(Result).HelpButtonClick; + end; + end; + end; +end; + +function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons): TTntForm; +var + DefaultButton: TMsgDlgBtn; +begin + if mbOk in Buttons then DefaultButton := mbOk else + if mbYes in Buttons then DefaultButton := mbYes else + DefaultButton := mbRetry; + Result := WideCreateMessageDialog(Msg, DlgType, Buttons, DefaultButton); +end; + +function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): Integer; +begin + Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, -1, -1, '', DefaultButton); +end; + +function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; +begin + Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, -1, -1, ''); +end; + +function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; DefaultButton: TMsgDlgBtn): Integer; +begin + Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, X, Y, '', DefaultButton); +end; + +function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer; +begin + Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, X, Y, ''); +end; + +function _Internal_WideMessageDlgPosHelp(Dlg: TTntForm; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString): Integer; +begin + with Dlg do + try + HelpContext := HelpCtx; + HelpFile := HelpFileName; + if X >= 0 then Left := X; + if Y >= 0 then Top := Y; + if (Y < 0) and (X < 0) then Position := poScreenCenter; + Result := ShowModal; + finally + Free; + end; +end; + +function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString; DefaultButton: TMsgDlgBtn): Integer; +begin + Result := _Internal_WideMessageDlgPosHelp( + WideCreateMessageDialog(Msg, DlgType, Buttons, DefaultButton), HelpCtx, X, Y, HelpFileName); +end; + +function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; + const HelpFileName: WideString): Integer; +begin + Result := _Internal_WideMessageDlgPosHelp( + WideCreateMessageDialog(Msg, DlgType, Buttons), HelpCtx, X, Y, HelpFileName); +end; + +procedure WideShowMessage(const Msg: WideString); +begin + WideShowMessagePos(Msg, -1, -1); +end; + +procedure WideShowMessageFmt(const Msg: WideString; Params: array of const); +begin + WideShowMessage(WideFormat(Msg, Params)); +end; + +procedure WideShowMessagePos(const Msg: WideString; X, Y: Integer); +begin + WideMessageDlgPos(Msg, mtCustom, [mbOK], 0, X, Y); +end; + +{ Input dialog } + +function WideInputQuery(const ACaption, APrompt: WideString; var Value: WideString): Boolean; +var + Form: TTntForm; + Prompt: TTntLabel; + Edit: TTntEdit; + DialogUnits: TPoint; + ButtonTop, ButtonWidth, ButtonHeight: Integer; +begin + Result := False; + Form := TTntForm.Create(Application); + with Form do begin + try + BorderStyle := bsDialog; // By doing this first, it will work on WINE. + Canvas.Font := Font; + DialogUnits := GetAveCharSize(Canvas); + Caption := ACaption; + ClientWidth := MulDiv(180, DialogUnits.X, 4); + Position := poScreenCenter; + Prompt := TTntLabel.Create(Form); + with Prompt do + begin + Parent := Form; + Caption := APrompt; + Left := MulDiv(8, DialogUnits.X, 4); + Top := MulDiv(8, DialogUnits.Y, 8); + Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4); + WordWrap := True; + end; + Edit := TTntEdit.Create(Form); + with Edit do + begin + Parent := Form; + Left := Prompt.Left; + Top := Prompt.Top + Prompt.Height + 5; + Width := MulDiv(164, DialogUnits.X, 4); + MaxLength := 255; + Text := Value; + SelectAll; + end; + ButtonTop := Edit.Top + Edit.Height + 15; + ButtonWidth := MulDiv(50, DialogUnits.X, 4); + ButtonHeight := MulDiv(14, DialogUnits.Y, 8); + with TTntButton.Create(Form) do + begin + Parent := Form; + Caption := SMsgDlgOK; + ModalResult := mrOk; + Default := True; + SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth, + ButtonHeight); + end; + with TTntButton.Create(Form) do + begin + Parent := Form; + Caption := SMsgDlgCancel; + ModalResult := mrCancel; + Cancel := True; + SetBounds(MulDiv(92, DialogUnits.X, 4), Edit.Top + Edit.Height + 15, ButtonWidth, + ButtonHeight); + Form.ClientHeight := Top + Height + 13; + end; + if ShowModal = mrOk then + begin + Value := Edit.Text; + Result := True; + end; + finally + Form.Free; + end; + end; +end; + +function WideInputBox(const ACaption, APrompt, ADefault: WideString): WideString; +begin + Result := ADefault; + WideInputQuery(ACaption, APrompt, Result); +end; + +function WidePromptForFileName(var AFileName: WideString; const AFilter: WideString = ''; + const ADefaultExt: WideString = ''; const ATitle: WideString = ''; + const AInitialDir: WideString = ''; SaveDialog: Boolean = False): Boolean; +var + Dialog: TTntOpenDialog; +begin + if SaveDialog then + begin + Dialog := TTntSaveDialog.Create(nil); + Dialog.Options := Dialog.Options + [ofOverwritePrompt]; + end + else + Dialog := TTntOpenDialog.Create(nil); + with Dialog do + try + Title := ATitle; + DefaultExt := ADefaultExt; + if AFilter = '' then + Filter := SDefaultFilter else + Filter := AFilter; + InitialDir := AInitialDir; + FileName := AFileName; + Result := Execute; + if Result then + AFileName := FileName; + finally + Free; + end; +end; + +end. diff --git a/Source/TntExtActns.pas b/Source/TntExtActns.pas new file mode 100644 index 0000000..cf1f342 --- /dev/null +++ b/Source/TntExtActns.pas @@ -0,0 +1,1400 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntExtActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, TntActnList, ExtActns; + +type +{TNT-WARN TCustomFileRun} + TTntCustomFileRun = class(TCustomFileRun{TNT-ALLOW TCustomFileRun}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileRun} + TTntFileRun = class(TFileRun{TNT-ALLOW TFileRun}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditAction} + TTntRichEditAction = class(TRichEditAction{TNT-ALLOW TRichEditAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditBold} + TTntRichEditBold = class(TRichEditBold{TNT-ALLOW TRichEditBold}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditItalic} + TTntRichEditItalic = class(TRichEditItalic{TNT-ALLOW TRichEditItalic}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditUnderline} + TTntRichEditUnderline = class(TRichEditUnderline{TNT-ALLOW TRichEditUnderline}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditStrikeOut} + TTntRichEditStrikeOut = class(TRichEditStrikeOut{TNT-ALLOW TRichEditStrikeOut}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditBullets} + TTntRichEditBullets = class(TRichEditBullets{TNT-ALLOW TRichEditBullets}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditAlignLeft} + TTntRichEditAlignLeft = class(TRichEditAlignLeft{TNT-ALLOW TRichEditAlignLeft}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditAlignRight} + TTntRichEditAlignRight = class(TRichEditAlignRight{TNT-ALLOW TRichEditAlignRight}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TRichEditAlignCenter} + TTntRichEditAlignCenter = class(TRichEditAlignCenter{TNT-ALLOW TRichEditAlignCenter}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TTabAction} + TTntTabAction = class(TTabAction{TNT-ALLOW TTabAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TPreviousTab} + TTntPreviousTab = class(TPreviousTab{TNT-ALLOW TPreviousTab}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TNextTab} + TTntNextTab = class(TNextTab{TNT-ALLOW TNextTab}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TOpenPicture} + TTntOpenPicture = class(TOpenPicture{TNT-ALLOW TOpenPicture}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSavePicture} + TTntSavePicture = class(TSavePicture{TNT-ALLOW TSavePicture}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TURLAction} + TTntURLAction = class(TURLAction{TNT-ALLOW TURLAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TBrowseURL} + TTntBrowseURL = class(TBrowseURL{TNT-ALLOW TBrowseURL}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TDownLoadURL} + TTntDownLoadURL = class(TDownLoadURL{TNT-ALLOW TDownLoadURL}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSendMail} + TTntSendMail = class(TSendMail{TNT-ALLOW TSendMail}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlAction} + TTntListControlAction = class(TListControlAction{TNT-ALLOW TListControlAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlCopySelection} + TTntListControlCopySelection = class(TListControlCopySelection{TNT-ALLOW TListControlCopySelection}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlDeleteSelection} + TTntListControlDeleteSelection = class(TListControlDeleteSelection{TNT-ALLOW TListControlDeleteSelection}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlSelectAll} + TTntListControlSelectAll = class(TListControlSelectAll{TNT-ALLOW TListControlSelectAll}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlClearSelection} + TTntListControlClearSelection = class(TListControlClearSelection{TNT-ALLOW TListControlClearSelection}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TListControlMoveSelection} + TTntListControlMoveSelection = class(TListControlMoveSelection{TNT-ALLOW TListControlMoveSelection}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +implementation + +uses + ActnList, TntStdActns, TntClasses; + +{TNT-IGNORE-UNIT} + +procedure TntExtActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntStdActn_AfterInherited_Assign(Action, Source); + // TCustomFileRun + if (Action is TCustomFileRun) and (Source is TCustomFileRun) then begin + TCustomFileRun(Action).Browse := TCustomFileRun(Source).Browse; + if TCustomFileRun(Source).BrowseDlg.Owner <> Source then + TCustomFileRun(Action).BrowseDlg := TCustomFileRun(Source).BrowseDlg + else begin + { Carry over dialog properties. Currently TOpenDialog doesn't support Assign. } + { TCustomFileRun(Action).BrowseDlg.Assign(TCustomFileRun(Source).BrowseDlg); } + end; + TCustomFileRun(Action).Directory := TCustomFileRun(Source).Directory; + TCustomFileRun(Action).FileName := TCustomFileRun(Source).FileName; + TCustomFileRun(Action).Operation := TCustomFileRun(Source).Operation; + TCustomFileRun(Action).ParentControl := TCustomFileRun(Source).ParentControl; + TCustomFileRun(Action).Parameters := TCustomFileRun(Source).Parameters; + TCustomFileRun(Action).ShowCmd := TCustomFileRun(Source).ShowCmd; + end; + // TTabAction + if (Action is TTabAction) and (Source is TTabAction) then begin + TTabAction(Action).SkipHiddenTabs := TTabAction(Source).SkipHiddenTabs; + TTabAction(Action).TabControl := TTabAction(Source).TabControl; + TTabAction(Action).Wrap := TTabAction(Source).Wrap; + TTabAction(Action).BeforeTabChange := TTabAction(Source).BeforeTabChange; + TTabAction(Action).AfterTabChange := TTabAction(Source).AfterTabChange; + TTabAction(Action).OnValidateTab := TTabAction(Source).OnValidateTab; + end; + // TNextTab + if (Action is TNextTab) and (Source is TNextTab) then begin + TNextTab(Action).LastTabCaption := TNextTab(Source).LastTabCaption; + TNextTab(Action).OnFinish := TNextTab(Source).OnFinish; + end; + // TURLAction + if (Action is TURLAction) and (Source is TURLAction) then begin + TURLAction(Action).URL := TURLAction(Source).URL; + end; + // TBrowseURL + if (Action is TBrowseURL) and (Source is TBrowseURL) then begin + {$IFDEF COMPILER_7_UP} + TBrowseURL(Action).BeforeBrowse := TBrowseURL(Source).BeforeBrowse; + TBrowseURL(Action).AfterBrowse := TBrowseURL(Source).AfterBrowse; + {$ENDIF} + end; + // TDownloadURL + if (Action is TDownloadURL) and (Source is TDownloadURL) then begin + TDownloadURL(Action).FileName := TDownloadURL(Source).FileName; + {$IFDEF COMPILER_7_UP} + TDownloadURL(Action).BeforeDownload := TDownloadURL(Source).BeforeDownload; + TDownloadURL(Action).AfterDownload := TDownloadURL(Source).AfterDownload; + {$ENDIF} + TDownloadURL(Action).OnDownloadProgress := TDownloadURL(Source).OnDownloadProgress; + end; + // TSendMail + if (Action is TSendMail) and (Source is TSendMail) then begin + TSendMail(Action).Text := TSendMail(Source).Text; + end; + // TListControlAction + if (Action is TListControlAction) and (Source is TListControlAction) then begin + TListControlAction(Action).ListControl := TListControlAction(Source).ListControl; + end; + // TListControlCopySelection + if (Action is TListControlCopySelection) and (Source is TListControlCopySelection) then begin + TListControlCopySelection(Action).Destination := TListControlCopySelection(Source).Destination; + end; +end; + +//------------------------- +// TNT EXT ACTNS +//------------------------- + +{ TTntCustomFileRun } + +procedure TTntCustomFileRun.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCustomFileRun.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomFileRun.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCustomFileRun.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCustomFileRun.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCustomFileRun.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntFileRun } + +procedure TTntFileRun.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileRun.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileRun.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileRun.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileRun.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileRun.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditAction } + +procedure TTntRichEditAction.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditBold } + +procedure TTntRichEditBold.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditBold.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditBold.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditBold.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditBold.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditBold.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditItalic } + +procedure TTntRichEditItalic.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditItalic.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditItalic.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditItalic.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditItalic.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditItalic.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditUnderline } + +procedure TTntRichEditUnderline.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditUnderline.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditUnderline.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditUnderline.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditUnderline.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditUnderline.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditStrikeOut } + +procedure TTntRichEditStrikeOut.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditStrikeOut.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditStrikeOut.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditStrikeOut.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditStrikeOut.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditStrikeOut.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditBullets } + +procedure TTntRichEditBullets.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditBullets.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditBullets.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditBullets.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditBullets.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditBullets.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditAlignLeft } + +procedure TTntRichEditAlignLeft.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditAlignLeft.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditAlignLeft.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditAlignLeft.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditAlignLeft.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditAlignLeft.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditAlignRight } + +procedure TTntRichEditAlignRight.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditAlignRight.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditAlignRight.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditAlignRight.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditAlignRight.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditAlignRight.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntRichEditAlignCenter } + +procedure TTntRichEditAlignCenter.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntRichEditAlignCenter.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntRichEditAlignCenter.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntRichEditAlignCenter.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntRichEditAlignCenter.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntRichEditAlignCenter.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntTabAction } + +procedure TTntTabAction.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntTabAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntTabAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntTabAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntTabAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntTabAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntPreviousTab } + +procedure TTntPreviousTab.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntPreviousTab.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPreviousTab.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntPreviousTab.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntPreviousTab.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntPreviousTab.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntNextTab } + +procedure TTntNextTab.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntNextTab.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntNextTab.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntNextTab.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntNextTab.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntNextTab.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntOpenPicture } + +procedure TTntOpenPicture.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntOpenPicture.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntOpenPicture.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntOpenPicture.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntOpenPicture.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntOpenPicture.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSavePicture } + +procedure TTntSavePicture.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSavePicture.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSavePicture.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSavePicture.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSavePicture.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSavePicture.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntURLAction } + +procedure TTntURLAction.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntURLAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntURLAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntURLAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntURLAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntURLAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntBrowseURL } + +procedure TTntBrowseURL.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntBrowseURL.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntBrowseURL.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntBrowseURL.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntBrowseURL.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntBrowseURL.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntDownLoadURL } + +procedure TTntDownLoadURL.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntDownLoadURL.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntDownLoadURL.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntDownLoadURL.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntDownLoadURL.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntDownLoadURL.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSendMail } + +procedure TTntSendMail.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSendMail.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSendMail.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSendMail.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSendMail.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSendMail.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlAction } + +procedure TTntListControlAction.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlCopySelection } + +procedure TTntListControlCopySelection.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlCopySelection.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlCopySelection.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlCopySelection.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlCopySelection.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlCopySelection.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlDeleteSelection } + +procedure TTntListControlDeleteSelection.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlDeleteSelection.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlDeleteSelection.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlDeleteSelection.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlDeleteSelection.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlDeleteSelection.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlSelectAll } + +procedure TTntListControlSelectAll.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlSelectAll.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlSelectAll.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlSelectAll.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlSelectAll.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlSelectAll.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlClearSelection } + +procedure TTntListControlClearSelection.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlClearSelection.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlClearSelection.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlClearSelection.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlClearSelection.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlClearSelection.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntListControlMoveSelection } + +procedure TTntListControlMoveSelection.Assign(Source: TPersistent); +begin + inherited; + TntExtActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntListControlMoveSelection.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntListControlMoveSelection.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntListControlMoveSelection.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntListControlMoveSelection.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntListControlMoveSelection.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/Source/TntExtCtrls.pas b/Source/TntExtCtrls.pas new file mode 100644 index 0000000..4789fa7 --- /dev/null +++ b/Source/TntExtCtrls.pas @@ -0,0 +1,1062 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntExtCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Messages, Controls, ExtCtrls, TntClasses, TntControls, TntStdCtrls, TntGraphics; + +type +{TNT-WARN TShape} + TTntShape = class(TShape{TNT-ALLOW TShape}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TPaintBox} + TTntPaintBox = class(TPaintBox{TNT-ALLOW TPaintBox}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TImage} + TTntImage = class(TImage{TNT-ALLOW TImage}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + function GetPicture: TTntPicture; + procedure SetPicture(const Value: TTntPicture); + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property Picture: TTntPicture read GetPicture write SetPicture; + end; + +{TNT-WARN TBevel} + TTntBevel = class(TBevel{TNT-ALLOW TBevel}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomPanel} + TTntCustomPanel = class(TCustomPanel{TNT-ALLOW TCustomPanel}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + protected + procedure Paint; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TPanel} + TTntPanel = class(TTntCustomPanel) + public + property DockManager; + published + property Align; + property Alignment; + property Anchors; + property AutoSize; + property BevelEdges; + property BevelInner; + property BevelKind; + property BevelOuter; + property BevelWidth; + property BiDiMode; + property BorderWidth; + property BorderStyle; + property Caption; + property Color; + property Constraints; + property Ctl3D; + property UseDockManager default True; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property FullRepaint; + property Font; + property Locked; + {$IFDEF COMPILER_10_UP} + property Padding; + {$ENDIF} + property ParentBiDiMode; + {$IFDEF COMPILER_7_UP} + property ParentBackground; + {$ENDIF} + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + {$IFDEF COMPILER_9_UP} + property VerticalAlignment; + {$ENDIF} + property Visible; + {$IFDEF COMPILER_9_UP} + property OnAlignInsertBefore; + property OnAlignPosition; + {$ENDIF} + property OnCanResize; + property OnClick; + property OnConstrainedResize; + property OnContextPopup; + property OnDockDrop; + property OnDockOver; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnResize; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +{TNT-WARN TCustomControlBar} + TTntCustomControlBar = class(TCustomControlBar{TNT-ALLOW TCustomControlBar}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TControlBar} + TTntControlBar = class(TTntCustomControlBar) + public + property Canvas; + published + property Align; + property Anchors; + property AutoDock; + property AutoDrag; + property AutoSize; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; + property BorderWidth; + property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; + property Constraints; + {$IFDEF COMPILER_10_UP} + property CornerEdge; + {$ENDIF} + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + {$IFDEF COMPILER_10_UP} + property DrawingStyle; + {$ENDIF} + property Enabled; + {$IFDEF COMPILER_10_UP} + property GradientDirection; + property GradientEndColor; + property GradientStartColor; + {$ENDIF} + {$IFDEF COMPILER_7_UP} + property ParentBackground default True; + {$ENDIF} + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property Picture; + property PopupMenu; + property RowSize; + property RowSnap; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + {$IFDEF COMPILER_9_UP} + property OnAlignInsertBefore; + property OnAlignPosition; + {$ENDIF} + property OnBandDrag; + property OnBandInfo; + property OnBandMove; + property OnBandPaint; + {$IFDEF COMPILER_9_UP} + property OnBeginBandMove; + property OnEndBandMove; + {$ENDIF} + property OnCanResize; + property OnClick; + property OnConstrainedResize; + property OnContextPopup; + property OnDockDrop; + property OnDockOver; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnPaint; + property OnResize; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +{TNT-WARN TCustomRadioGroup} + TTntCustomRadioGroup = class(TTntCustomGroupBox) + private + FButtons: TList; + FItems: TTntStrings; + FItemIndex: Integer; + FColumns: Integer; + FReading: Boolean; + FUpdating: Boolean; + function GetButtons(Index: Integer): TTntRadioButton; + procedure ArrangeButtons; + procedure ButtonClick(Sender: TObject); + procedure ItemsChange(Sender: TObject); + procedure SetButtonCount(Value: Integer); + procedure SetColumns(Value: Integer); + procedure SetItemIndex(Value: Integer); + procedure SetItems(Value: TTntStrings); + procedure UpdateButtons; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + procedure WMSize(var Message: TWMSize); message WM_SIZE; + protected + procedure Loaded; override; + procedure ReadState(Reader: TReader); override; + function CanModify: Boolean; virtual; + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + property Columns: Integer read FColumns write SetColumns default 1; + property ItemIndex: Integer read FItemIndex write SetItemIndex default -1; + property Items: TTntStrings read FItems write SetItems; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure FlipChildren(AllLevels: Boolean); override; + property Buttons[Index: Integer]: TTntRadioButton read GetButtons; + end; + +{TNT-WARN TRadioGroup} + TTntRadioGroup = class(TTntCustomRadioGroup) + published + property Align; + property Anchors; + property BiDiMode; + property Caption; + property Color; + property Columns; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property ItemIndex; + property Items; + property Constraints; + property ParentBiDiMode; + {$IFDEF COMPILER_7_UP} + property ParentBackground default True; + {$ENDIF} + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnStartDock; + property OnStartDrag; + end; + +{TNT-WARN TSplitter} + TTntSplitter = class(TSplitter{TNT-ALLOW TSplitter}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +implementation + +uses + Windows, Graphics, Forms, {$IFDEF THEME_7_UP} Themes, {$ENDIF} + TntSysUtils, TntWindows, TntActnList; + +{ TTntShape } + +procedure TTntShape.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntShape.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntShape.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntShape.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntShape.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntShape.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntShape.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntPaintBox } + +procedure TTntPaintBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPaintBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntPaintBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntPaintBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntPaintBox.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntPaintBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntPaintBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +type +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 + THackImage = class(TGraphicControl) + protected + FPicture: TPicture{TNT-ALLOW TPicture}; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 + THackImage = class(TGraphicControl) + protected + FPicture: TPicture{TNT-ALLOW TPicture}; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 + THackImage = class(TGraphicControl) + private + FPicture: TPicture{TNT-ALLOW TPicture}; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 + THackImage = class(TGraphicControl) + private + FPicture: TPicture{TNT-ALLOW TPicture}; + end; +{$ENDIF} + +{ TTntImage } + +constructor TTntImage.Create(AOwner: TComponent); +var + OldPicture: TPicture{TNT-ALLOW TPicture}; +begin + inherited; + OldPicture := THackImage(Self).FPicture; + THackImage(Self).FPicture := TTntPicture.Create; + Picture.OnChange := OldPicture.OnChange; + Picture.OnProgress := OldPicture.OnProgress; + OldPicture.Free; +end; + +function TTntImage.GetPicture: TTntPicture; +begin + Result := inherited Picture as TTntPicture; +end; + +procedure TTntImage.SetPicture(const Value: TTntPicture); +begin + inherited Picture := Value; +end; + +procedure TTntImage.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntImage.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntImage.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntImage.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntImage.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntImage.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntImage.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntBevel } + +procedure TTntBevel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntBevel.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntBevel.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntBevel.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntBevel.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntBevel.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntBevel.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomPanel } + +procedure TTntCustomPanel.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomPanel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomPanel.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntCustomPanel.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomPanel.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomPanel.Paint; +const + Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER); +var + Rect: TRect; + TopColor, BottomColor: TColor; + FontHeight: Integer; + Flags: Longint; + + procedure AdjustColors(Bevel: TPanelBevel); + begin + TopColor := clBtnHighlight; + if Bevel = bvLowered then TopColor := clBtnShadow; + BottomColor := clBtnShadow; + if Bevel = bvLowered then BottomColor := clBtnHighlight; + end; + +begin + if (not Win32PlatformIsUnicode) then + inherited + else begin + Rect := GetClientRect; + if BevelOuter <> bvNone then + begin + AdjustColors(BevelOuter); + Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); + end; + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled {$IFDEF COMPILER_7_UP} and ParentBackground {$ENDIF} then + InflateRect(Rect, -BorderWidth, -BorderWidth) + else + {$ENDIF} + begin + Frame3D(Canvas, Rect, Color, Color, BorderWidth); + end; + if BevelInner <> bvNone then + begin + AdjustColors(BevelInner); + Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); + end; + with Canvas do + begin + {$IFDEF THEME_7_UP} + if not ThemeServices.ThemesEnabled {$IFDEF COMPILER_7_UP} or not ParentBackground {$ENDIF} then + {$ENDIF} + begin + Brush.Color := Color; + FillRect(Rect); + end; + Brush.Style := bsClear; + Font := Self.Font; + FontHeight := WideCanvasTextHeight(Canvas, 'W'); + with Rect do + begin + Top := ((Bottom + Top) - FontHeight) div 2; + Bottom := Top + FontHeight; + end; + Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[Alignment]; + Flags := DrawTextBiDiModeFlags(Flags); + Tnt_DrawTextW(Handle, PWideChar(Caption), -1, Rect, Flags); + end; + end; +end; + +function TTntCustomPanel.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomPanel.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomPanel.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomPanel.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomPanel.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomControlBar } + +procedure TTntCustomControlBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomControlBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomControlBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomControlBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomControlBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomControlBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomControlBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntGroupButton } + +type + TTntGroupButton = class(TTntRadioButton) + private + FInClick: Boolean; + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + protected + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; + public + constructor InternalCreate(RadioGroup: TTntCustomRadioGroup); + destructor Destroy; override; + end; + +constructor TTntGroupButton.InternalCreate(RadioGroup: TTntCustomRadioGroup); +begin + inherited Create(RadioGroup); + RadioGroup.FButtons.Add(Self); + Visible := False; + Enabled := RadioGroup.Enabled; + ParentShowHint := False; + OnClick := RadioGroup.ButtonClick; + Parent := RadioGroup; +end; + +destructor TTntGroupButton.Destroy; +begin + TTntCustomRadioGroup(Owner).FButtons.Remove(Self); + inherited Destroy; +end; + +procedure TTntGroupButton.CNCommand(var Message: TWMCommand); +begin + if not FInClick then + begin + FInClick := True; + try + if ((Message.NotifyCode = BN_CLICKED) or + (Message.NotifyCode = BN_DOUBLECLICKED)) and + TTntCustomRadioGroup(Parent).CanModify then + inherited; + except + Application.HandleException(Self); + end; + FInClick := False; + end; +end; + +procedure TTntGroupButton.KeyPress(var Key: Char{TNT-ALLOW Char}); +begin + inherited KeyPress(Key); + TTntCustomRadioGroup(Parent).KeyPress(Key); + if (Key = #8) or (Key = ' ') then + begin + if not TTntCustomRadioGroup(Parent).CanModify then Key := #0; + end; +end; + +procedure TTntGroupButton.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited KeyDown(Key, Shift); + TTntCustomRadioGroup(Parent).KeyDown(Key, Shift); +end; + +{ TTntCustomRadioGroup } + +constructor TTntCustomRadioGroup.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := [csSetCaption, csDoubleClicks {$IFDEF COMPILER_7_UP}, csParentBackground {$ENDIF}]; + FButtons := TList.Create; + FItems := TTntStringList.Create; + TTntStringList(FItems).OnChange := ItemsChange; + FItemIndex := -1; + FColumns := 1; +end; + +destructor TTntCustomRadioGroup.Destroy; +begin + SetButtonCount(0); + TTntStringList(FItems).OnChange := nil; + FItems.Free; + FButtons.Free; + inherited Destroy; +end; + +procedure TTntCustomRadioGroup.FlipChildren(AllLevels: Boolean); +begin + { The radio buttons are flipped using BiDiMode } +end; + +procedure TTntCustomRadioGroup.ArrangeButtons; +var + ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer; + DC: HDC; + SaveFont: HFont; + Metrics: TTextMetric; + DeferHandle: THandle; + ALeft: Integer; +begin + if (FButtons.Count <> 0) and not FReading then + begin + DC := GetDC(0); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns; + ButtonWidth := (Width - 10) div FColumns; + I := Height - Metrics.tmHeight - 5; + ButtonHeight := I div ButtonsPerCol; + TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2; + DeferHandle := BeginDeferWindowPos(FButtons.Count); + try + for I := 0 to FButtons.Count - 1 do + with TTntGroupButton(FButtons[I]) do + begin + BiDiMode := Self.BiDiMode; + ALeft := (I div ButtonsPerCol) * ButtonWidth + 8; + if UseRightToLeftAlignment then + ALeft := Self.ClientWidth - ALeft - ButtonWidth; + DeferHandle := DeferWindowPos(DeferHandle, Handle, 0, + ALeft, + (I mod ButtonsPerCol) * ButtonHeight + TopMargin, + ButtonWidth, ButtonHeight, + SWP_NOZORDER or SWP_NOACTIVATE); + Visible := True; + end; + finally + EndDeferWindowPos(DeferHandle); + end; + end; +end; + +procedure TTntCustomRadioGroup.ButtonClick(Sender: TObject); +begin + if not FUpdating then + begin + FItemIndex := FButtons.IndexOf(Sender); + Changed; + Click; + end; +end; + +procedure TTntCustomRadioGroup.ItemsChange(Sender: TObject); +begin + if not FReading then + begin + if FItemIndex >= FItems.Count then FItemIndex := FItems.Count - 1; + UpdateButtons; + end; +end; + +procedure TTntCustomRadioGroup.Loaded; +begin + inherited Loaded; + ArrangeButtons; +end; + +procedure TTntCustomRadioGroup.ReadState(Reader: TReader); +begin + FReading := True; + inherited ReadState(Reader); + FReading := False; + UpdateButtons; +end; + +procedure TTntCustomRadioGroup.SetButtonCount(Value: Integer); +begin + while FButtons.Count < Value do TTntGroupButton.InternalCreate(Self); + while FButtons.Count > Value do TTntGroupButton(FButtons.Last).Free; +end; + +procedure TTntCustomRadioGroup.SetColumns(Value: Integer); +begin + if Value < 1 then Value := 1; + if Value > 16 then Value := 16; + if FColumns <> Value then + begin + FColumns := Value; + ArrangeButtons; + Invalidate; + end; +end; + +procedure TTntCustomRadioGroup.SetItemIndex(Value: Integer); +begin + if FReading then FItemIndex := Value else + begin + if Value < -1 then Value := -1; + if Value >= FButtons.Count then Value := FButtons.Count - 1; + if FItemIndex <> Value then + begin + if FItemIndex >= 0 then + TTntGroupButton(FButtons[FItemIndex]).Checked := False; + FItemIndex := Value; + if FItemIndex >= 0 then + TTntGroupButton(FButtons[FItemIndex]).Checked := True; + end; + end; +end; + +procedure TTntCustomRadioGroup.SetItems(Value: TTntStrings); +begin + FItems.Assign(Value); +end; + +procedure TTntCustomRadioGroup.UpdateButtons; +var + I: Integer; +begin + SetButtonCount(FItems.Count); + for I := 0 to FButtons.Count - 1 do + TTntGroupButton(FButtons[I]).Caption := FItems[I]; + if FItemIndex >= 0 then + begin + FUpdating := True; + TTntGroupButton(FButtons[FItemIndex]).Checked := True; + FUpdating := False; + end; + ArrangeButtons; + Invalidate; +end; + +procedure TTntCustomRadioGroup.CMEnabledChanged(var Message: TMessage); +var + I: Integer; +begin + inherited; + for I := 0 to FButtons.Count - 1 do + TTntGroupButton(FButtons[I]).Enabled := Enabled; +end; + +procedure TTntCustomRadioGroup.CMFontChanged(var Message: TMessage); +begin + inherited; + ArrangeButtons; +end; + +procedure TTntCustomRadioGroup.WMSize(var Message: TWMSize); +begin + inherited; + ArrangeButtons; +end; + +function TTntCustomRadioGroup.CanModify: Boolean; +begin + Result := True; +end; + +procedure TTntCustomRadioGroup.GetChildren(Proc: TGetChildProc; Root: TComponent); +begin +end; + +function TTntCustomRadioGroup.GetButtons(Index: Integer): TTntRadioButton; +begin + Result := TTntRadioButton(FButtons[Index]); +end; + +{ TTntSplitter } + +procedure TTntSplitter.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSplitter.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntSplitter.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntSplitter.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntSplitter.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntSplitter.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntSplitter.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +end. diff --git a/Source/TntExtDlgs.pas b/Source/TntExtDlgs.pas new file mode 100644 index 0000000..528c4f9 --- /dev/null +++ b/Source/TntExtDlgs.pas @@ -0,0 +1,317 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntExtDlgs; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Windows, TntDialogs, TntExtCtrls, TntStdCtrls, TntButtons; + +type +{TNT-WARN TOpenPictureDialog} + TTntOpenPictureDialog = class(TTntOpenDialog) + private + FPicturePanel: TTntPanel; + FPictureLabel: TTntLabel; + FPreviewButton: TTntSpeedButton; + FPaintPanel: TTntPanel; + FImageCtrl: TTntImage; + FSavedFilename: WideString; + function IsFilterStored: Boolean; + procedure PreviewKeyPress(Sender: TObject; var Key: Char{TNT-ALLOW Char}); + protected + procedure PreviewClick(Sender: TObject); virtual; + procedure DoClose; override; + procedure DoSelectionChange; override; + procedure DoShow; override; + property ImageCtrl: TTntImage read FImageCtrl; + property PictureLabel: TTntLabel read FPictureLabel; + published + property Filter stored IsFilterStored; + public + constructor Create(AOwner: TComponent); override; + function Execute: Boolean; override; + {$IFDEF COMPILER_9_UP} + function Execute(ParentWnd: HWND): Boolean; override; + {$ENDIF} + end; + +{TNT-WARN TSavePictureDialog} + TTntSavePictureDialog = class(TTntOpenPictureDialog) + public + function Execute: Boolean; override; + {$IFDEF COMPILER_9_UP} + function Execute(ParentWnd: HWND): Boolean; override; + {$ENDIF} + end; + +implementation + +uses + ExtDlgs, {ExtDlgs is needed for a linked resource} Dialogs, Consts, Messages, + Graphics, Math, Controls, Forms, SysUtils, CommDlg, TntSysUtils, TntForms; + +{ TTntSilentPaintPanel } + +type + TTntSilentPaintPanel = class(TTntPanel) + protected + procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; + end; + +procedure TTntSilentPaintPanel.WMPaint(var Msg: TWMPaint); +begin + try + inherited; + except + Caption := SInvalidImage; + end; +end; + +{ TTntOpenPictureDialog } + +constructor TTntOpenPictureDialog.Create(AOwner: TComponent); +begin + inherited; + Filter := GraphicFilter(TGraphic); + FPicturePanel := TTntPanel.Create(Self); + with FPicturePanel do + begin + Name := 'PicturePanel'; + Caption := ''; + SetBounds(204, 5, 169, 200); + BevelOuter := bvNone; + BorderWidth := 6; + TabOrder := 1; + FPictureLabel := TTntLabel.Create(Self); + with FPictureLabel do + begin + Name := 'PictureLabel'; + Caption := ''; + SetBounds(6, 6, 157, 23); + Align := alTop; + AutoSize := False; + Parent := FPicturePanel; + end; + FPreviewButton := TTntSpeedButton.Create(Self); + with FPreviewButton do + begin + Name := 'PreviewButton'; + SetBounds(77, 1, 23, 22); + Enabled := False; + Glyph.LoadFromResourceName(FindClassHInstance(TOpenPictureDialog{TNT-ALLOW TOpenPictureDialog}), 'PREVIEWGLYPH'); + Hint := SPreviewLabel; + ParentShowHint := False; + ShowHint := True; + OnClick := PreviewClick; + Parent := FPicturePanel; + end; + FPaintPanel := TTntSilentPaintPanel.Create(Self); + with FPaintPanel do + begin + Name := 'PaintPanel'; + Caption := ''; + SetBounds(6, 29, 157, 145); + Align := alClient; + BevelInner := bvRaised; + BevelOuter := bvLowered; + TabOrder := 0; + FImageCtrl := TTntImage.Create(Self); + Parent := FPicturePanel; + with FImageCtrl do + begin + Name := 'PaintBox'; + Align := alClient; + OnDblClick := PreviewClick; + Parent := FPaintPanel; + Proportional := True; + Stretch := True; + Center := True; + IncrementalDisplay := True; + end; + end; + end; +end; + +procedure TTntOpenPictureDialog.DoClose; +begin + inherited; + { Hide any hint windows left behind } + Application.HideHint; +end; + +procedure TTntOpenPictureDialog.DoSelectionChange; +var + FullName: WideString; + ValidPicture: Boolean; + + function ValidFile(const FileName: WideString): Boolean; + begin + Result := WideFileGetAttr(FileName) <> $FFFFFFFF; + end; + +begin + FullName := FileName; + if FullName <> FSavedFilename then + begin + FSavedFilename := FullName; + ValidPicture := WideFileExists(FullName) and ValidFile(FullName); + if ValidPicture then + try + FImageCtrl.Picture.LoadFromFile(FullName); + FPictureLabel.Caption := WideFormat(SPictureDesc, + [FImageCtrl.Picture.Width, FImageCtrl.Picture.Height]); + FPreviewButton.Enabled := True; + FPaintPanel.Caption := ''; + except + ValidPicture := False; + end; + if not ValidPicture then + begin + FPictureLabel.Caption := SPictureLabel; + FPreviewButton.Enabled := False; + FImageCtrl.Picture := nil; + FPaintPanel.Caption := srNone; + end; + end; + inherited; +end; + +procedure TTntOpenPictureDialog.DoShow; +var + PreviewRect, StaticRect: TRect; +begin + { Set preview area to entire dialog } + GetClientRect(Handle, PreviewRect); + StaticRect := GetStaticRect; + { Move preview area to right of static area } + PreviewRect.Left := StaticRect.Left + (StaticRect.Right - StaticRect.Left); + Inc(PreviewRect.Top, 4); + FPicturePanel.BoundsRect := PreviewRect; + FPreviewButton.Left := FPaintPanel.BoundsRect.Right - FPreviewButton.Width - 2; + FImageCtrl.Picture := nil; + FSavedFilename := ''; + FPaintPanel.Caption := srNone; + FPicturePanel.ParentWindow := Handle; + inherited; +end; + +function TTntOpenPictureDialog.Execute: Boolean; +begin + if NewStyleControls and not (ofOldStyleDialog in Options) then + Template := 'DLGTEMPLATE' else + Template := nil; + Result := inherited Execute; +end; + +{$IFDEF COMPILER_9_UP} +function TTntOpenPictureDialog.Execute(ParentWnd: HWND): Boolean; +begin + if NewStyleControls and not (ofOldStyleDialog in Options) then + Template := 'DLGTEMPLATE' else + Template := nil; + Result := inherited Execute(ParentWnd); +end; +{$ENDIF} + +function TTntOpenPictureDialog.IsFilterStored: Boolean; +begin + Result := not (Filter = GraphicFilter(TGraphic)); +end; + +procedure TTntOpenPictureDialog.PreviewClick(Sender: TObject); +var + PreviewForm: TTntForm; + Panel: TTntPanel; +begin + PreviewForm := TTntForm.Create(Self); + with PreviewForm do + try + Name := 'PreviewForm'; + BorderStyle := bsSizeToolWin; // By doing this first, it will work on WINE. + Visible := False; + Caption := SPreviewLabel; + KeyPreview := True; + Position := poScreenCenter; + OnKeyPress := PreviewKeyPress; + Panel := TTntPanel.Create(PreviewForm); + with Panel do + begin + Name := 'Panel'; + Caption := ''; + Align := alClient; + BevelOuter := bvNone; + BorderStyle := bsSingle; + BorderWidth := 5; + Color := clWindow; + Parent := PreviewForm; + DoubleBuffered := True; + with TTntImage.Create(PreviewForm) do + begin + Name := 'Image'; + Align := alClient; + Stretch := True; + Proportional := True; + Center := True; + Picture.Assign(FImageCtrl.Picture); + Parent := Panel; + end; + end; + if FImageCtrl.Picture.Width > 0 then + begin + ClientWidth := Min(Monitor.Width * 3 div 4, + FImageCtrl.Picture.Width + (ClientWidth - Panel.ClientWidth)+ 10); + ClientHeight := Min(Monitor.Height * 3 div 4, + FImageCtrl.Picture.Height + (ClientHeight - Panel.ClientHeight) + 10); + end; + ShowModal; + finally + Free; + end; +end; + +procedure TTntOpenPictureDialog.PreviewKeyPress(Sender: TObject; var Key: Char{TNT-ALLOW Char}); +begin + if Key = Char{TNT-ALLOW Char}(VK_ESCAPE) then + (Sender as TTntForm).Close; +end; + +{ TSavePictureDialog } +function TTntSavePictureDialog.Execute: Boolean; +begin + if NewStyleControls and not (ofOldStyleDialog in Options) then + Template := 'DLGTEMPLATE' else + Template := nil; + + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetSaveFileNameA) + else + Result := DoExecuteW(@GetSaveFileNameW); +end; + +{$IFDEF COMPILER_9_UP} +function TTntSavePictureDialog.Execute(ParentWnd: HWND): Boolean; +begin + if NewStyleControls and not (ofOldStyleDialog in Options) then + Template := 'DLGTEMPLATE' else + Template := nil; + + if (not Win32PlatformIsUnicode) then + Result := DoExecute(@GetSaveFileNameA, ParentWnd) + else + Result := DoExecuteW(@GetSaveFileNameW, ParentWnd); +end; +{$ENDIF} + +end. diff --git a/Source/TntFileCtrl.pas b/Source/TntFileCtrl.pas new file mode 100644 index 0000000..892bd80 --- /dev/null +++ b/Source/TntFileCtrl.pas @@ -0,0 +1,118 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntFileCtrl; + +{$INCLUDE TntCompilers.inc} + +interface + +{$WARN UNIT_PLATFORM OFF} + +uses + Classes, Windows, FileCtrl; + +{TNT-WARN SelectDirectory} +function WideSelectDirectory(const Caption: WideString; const Root: WideString; + var Directory: WideString): Boolean; + +implementation + +uses + SysUtils, Forms, ActiveX, ShlObj, ShellApi, TntSysUtils, TntWindows; + +function SelectDirCB_W(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall; +begin + if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then + SendMessageW(Wnd, BFFM_SETSELECTIONW, Integer(True), lpdata); + result := 0; +end; + +function WideSelectDirectory(const Caption: WideString; const Root: WideString; + var Directory: WideString): Boolean; +{$IFNDEF COMPILER_7_UP} +const + BIF_NEWDIALOGSTYLE = $0040; + BIF_USENEWUI = BIF_NEWDIALOGSTYLE or BIF_EDITBOX; +{$ENDIF} +var + WindowList: Pointer; + BrowseInfo: TBrowseInfoW; + Buffer: PWideChar; + OldErrorMode: Cardinal; + RootItemIDList, ItemIDList: PItemIDList; + ShellMalloc: IMalloc; + IDesktopFolder: IShellFolder; + Eaten, Flags: LongWord; + AnsiDirectory: AnsiString; +begin + if (not Win32PlatformIsUnicode) then begin + AnsiDirectory := Directory; + Result := SelectDirectory{TNT-ALLOW SelectDirectory}(Caption, Root, AnsiDirectory); + Directory := AnsiDirectory; + end else begin + Result := False; + if not WideDirectoryExists(Directory) then + Directory := ''; + FillChar(BrowseInfo, SizeOf(BrowseInfo), 0); + if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then + begin + Buffer := ShellMalloc.Alloc(MAX_PATH * SizeOf(WideChar)); + try + RootItemIDList := nil; + if Root <> '' then + begin + SHGetDesktopFolder(IDesktopFolder); + IDesktopFolder.ParseDisplayName(Application.Handle, nil, + POleStr(Root), Eaten, RootItemIDList, Flags); + end; + with BrowseInfo do + begin + {$IFDEF COMPILER_9_UP} + hWndOwner := Application.ActiveFormHandle; + {$ELSE} + hWndOwner := Application.Handle; + {$ENDIF} + pidlRoot := RootItemIDList; + pszDisplayName := Buffer; + lpszTitle := PWideChar(Caption); + ulFlags := BIF_RETURNONLYFSDIRS; + if Win32MajorVersion >= 5 then + ulFlags := ulFlags or BIF_USENEWUI; + if Directory <> '' then + begin + lpfn := SelectDirCB_W; + lParam := Integer(PWideChar(Directory)); + end; + end; + WindowList := DisableTaskWindows(0); + OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS); + try + ItemIDList := Tnt_ShBrowseForFolderW(BrowseInfo); + finally + SetErrorMode(OldErrorMode); + EnableTaskWindows(WindowList); + end; + Result := ItemIDList <> nil; + if Result then + begin + Tnt_ShGetPathFromIDListW(ItemIDList, Buffer); + ShellMalloc.Free(ItemIDList); + Directory := Buffer; + end; + finally + ShellMalloc.Free(Buffer); + end; + end; + end; +end; + +end. diff --git a/Source/TntFormatStrUtils.pas b/Source/TntFormatStrUtils.pas new file mode 100644 index 0000000..1149ec8 --- /dev/null +++ b/Source/TntFormatStrUtils.pas @@ -0,0 +1,503 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntFormatStrUtils; + +{$INCLUDE TntCompilers.inc} + +interface + +// this unit provides functions to work with format strings + +uses + TntSysUtils; + +function GetCanonicalFormatStr(const _FormatString: WideString): WideString; +{$IFNDEF COMPILER_9_UP} +function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; + const Args: array of const + {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; +{$ENDIF} +procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); +function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; + +type + EFormatSpecError = class(ETntGeneralError); + +implementation + +uses + SysUtils, Math, TntClasses; + +resourcestring + SInvalidFormatSpecifier = 'Invalid Format Specifier: %s'; + SMismatchedArgumentTypes = 'Argument types for index %d do not match. (%s <> %s)'; + SMismatchedArgumentCounts = 'Number of format specifiers do not match.'; + +type + TFormatSpecifierType = (fstInteger, fstFloating, fstPointer, fstString); + +function GetFormatSpecifierType(const FormatSpecifier: WideString): TFormatSpecifierType; +var + LastChar: WideChar; +begin + LastChar := TntWideLastChar(FormatSpecifier); + case LastChar of + 'd', 'D', 'u', 'U', 'x', 'X': + result := fstInteger; + 'e', 'E', 'f', 'F', 'g', 'G', 'n', 'N', 'm', 'M': + result := fstFloating; + 'p', 'P': + result := fstPointer; + 's', 'S': + result := fstString + else + raise ETntInternalError.CreateFmt('Internal Error: Unexpected format type (%s)', [LastChar]); + end; +end; + +type + TFormatStrParser = class(TObject) + private + ParsedString: TBufferedWideString; + PFormatString: PWideChar; + LastIndex: Integer; + ExplicitCount: Integer; + ImplicitCount: Integer; + procedure RaiseInvalidFormatSpecifier; + function ParseChar(c: WideChar): Boolean; + procedure ForceParseChar(c: WideChar); + function ParseDigit: Boolean; + function ParseInteger: Boolean; + procedure ForceParseType; + function PeekDigit: Boolean; + function PeekIndexSpecifier(out Index: Integer): Boolean; + public + constructor Create(const _FormatString: WideString); + destructor Destroy; override; + function ParseFormatSpecifier: Boolean; + end; + +constructor TFormatStrParser.Create(const _FormatString: WideString); +begin + inherited Create; + PFormatString := PWideChar(_FormatString); + ExplicitCount := 0; + ImplicitCount := 0; + LastIndex := -1; + ParsedString := TBufferedWideString.Create; +end; + +destructor TFormatStrParser.Destroy; +begin + FreeAndNil(ParsedString); + inherited; +end; + +procedure TFormatStrParser.RaiseInvalidFormatSpecifier; +begin + raise EFormatSpecError.CreateFmt(SInvalidFormatSpecifier, [ParsedString.Value + PFormatString]); +end; + +function TFormatStrParser.ParseChar(c: WideChar): Boolean; +begin + result := False; + if PFormatString^ = c then begin + result := True; + ParsedString.AddChar(c); + Inc(PFormatString); + end; +end; + +procedure TFormatStrParser.ForceParseChar(c: WideChar); +begin + if not ParseChar(c) then + RaiseInvalidFormatSpecifier; +end; + +function TFormatStrParser.PeekDigit: Boolean; +begin + result := False; + if (PFormatString^ <> #0) + and (PFormatString^ >= '0') + and (PFormatString^ <= '9') then + result := True; +end; + +function TFormatStrParser.ParseDigit: Boolean; +begin + result := False; + if PeekDigit then begin + result := True; + ForceParseChar(PFormatString^); + end; +end; + +function TFormatStrParser.ParseInteger: Boolean; +const + MAX_INT_DIGITS = 6; +var + digitcount: integer; +begin + digitcount := 0; + While ParseDigit do begin + inc(digitcount); + end; + result := (digitcount > 0); + if digitcount > MAX_INT_DIGITS then + RaiseInvalidFormatSpecifier; +end; + +procedure TFormatStrParser.ForceParseType; +begin + if PFormatString^ = #0 then + RaiseInvalidFormatSpecifier; + + case PFormatString^ of + 'd', 'u', 'x', 'e', 'f', 'g', 'n', 'm', 'p', 's', + 'D', 'U', 'X', 'E', 'F', 'G', 'N', 'M', 'P', 'S': + begin + // do nothing + end + else + RaiseInvalidFormatSpecifier; + end; + ForceParseChar(PFormatString^); +end; + +function TFormatStrParser.PeekIndexSpecifier(out Index: Integer): Boolean; +var + SaveParsedString: WideString; + SaveFormatString: PWideChar; +begin + SaveParsedString := ParsedString.Value; + SaveFormatString := PFormatString; + try + ParsedString.Clear; + Result := False; + Index := -1; + if ParseInteger then begin + Index := StrToInt(ParsedString.Value); + if ParseChar(':') then + Result := True; + end; + finally + ParsedString.Clear; + ParsedString.AddString(SaveParsedString); + PFormatString := SaveFormatString; + end; +end; + +function TFormatStrParser.ParseFormatSpecifier: Boolean; +var + ExplicitIndex: Integer; +begin + Result := False; + // Parse entire format specifier + ForceParseChar('%'); + if (PFormatString^ <> #0) + and (not ParseChar(' ')) + and (not ParseChar('%')) then begin + if PeekIndexSpecifier(ExplicitIndex) then begin + Inc(ExplicitCount); + LastIndex := Max(LastIndex, ExplicitIndex); + end else begin + Inc(ImplicitCount); + Inc(LastIndex); + ParsedString.AddString(IntToStr(LastIndex)); + ParsedString.AddChar(':'); + end; + if ParseChar('*') then + begin + Inc(ImplicitCount); + Inc(LastIndex); + ParseChar(':'); + end else if ParseInteger then + ParseChar(':'); + ParseChar('-'); + if ParseChar('*') then begin + Inc(ImplicitCount); + Inc(LastIndex); + end else + ParseInteger; + if ParseChar('.') then begin + if not ParseChar('*') then + ParseInteger; + end; + ForceParseType; + Result := True; + end; +end; + +//----------------------------------- + +function GetCanonicalFormatStr(const _FormatString: WideString): WideString; +var + PosSpec: Integer; +begin + with TFormatStrParser.Create(_FormatString) do + try + // loop until no more '%' + PosSpec := Pos('%', PFormatString); + While PosSpec <> 0 do begin + try + // delete everything up until '%' + ParsedString.AddBuffer(PFormatString, PosSpec - 1); + Inc(PFormatString, PosSpec - 1); + // parse format specifier + ParseFormatSpecifier; + finally + PosSpec := Pos('%', PFormatString); + end; + end; + if ((ExplicitCount = 0) and (ImplicitCount = 1)) {simple expression} + or ((ExplicitCount > 0) and (ImplicitCount = 0)) {nothing converted} then + result := _FormatString {original} + else + result := ParsedString.Value + PFormatString; + finally + Free; + end; +end; + +{$IFNDEF COMPILER_9_UP} +function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; + const Args: array of const + {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; +{ This function replaces floating point format specifiers with their actual formatted values. + It also adds index specifiers so that the other format specifiers don't lose their place. + The reason for this is that WideFormat doesn't correctly format floating point specifiers. + See QC#4254. } +var + Parser: TFormatStrParser; + PosSpec: Integer; + Output: TBufferedWideString; +begin + Output := TBufferedWideString.Create; + try + Parser := TFormatStrParser.Create(_FormatString); + with Parser do + try + // loop until no more '%' + PosSpec := Pos('%', PFormatString); + While PosSpec <> 0 do begin + try + // delete everything up until '%' + Output.AddBuffer(PFormatString, PosSpec - 1); + Inc(PFormatString, PosSpec - 1); + // parse format specifier + ParsedString.Clear; + if (not ParseFormatSpecifier) + or (GetFormatSpecifierType(ParsedString.Value) <> fstFloating) then + Output.AddBuffer(ParsedString.BuffPtr, MaxInt) + {$IFDEF COMPILER_7_UP} + else if Assigned(FormatSettings) then + Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args, FormatSettings^)) + {$ENDIF} + else + Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args)); + finally + PosSpec := Pos('%', PFormatString); + end; + end; + Output.AddString(PFormatString); + finally + Free; + end; + Result := Output.Value; + finally + Output.Free; + end; +end; +{$ENDIF} + +procedure GetFormatArgs(const _FormatString: WideString; FormatArgs: TTntStrings); +var + PosSpec: Integer; +begin + with TFormatStrParser.Create(_FormatString) do + try + FormatArgs.Clear; + // loop until no more '%' + PosSpec := Pos('%', PFormatString); + While PosSpec <> 0 do begin + try + // delete everything up until '%' + Inc(PFormatString, PosSpec - 1); + // add format specifier to list + ParsedString.Clear; + if ParseFormatSpecifier then + FormatArgs.Add(ParsedString.Value); + finally + PosSpec := Pos('%', PFormatString); + end; + end; + finally + Free; + end; +end; + +function GetExplicitIndex(const FormatSpecifier: WideString): Integer; +var + IndexStr: WideString; + PosColon: Integer; +begin + result := -1; + PosColon := Pos(':', FormatSpecifier); + if PosColon <> 0 then begin + IndexStr := Copy(FormatSpecifier, 2, PosColon - 2); + result := StrToInt(IndexStr); + end; +end; + +function GetMaxIndex(FormatArgs: TTntStrings): Integer; +var + i: integer; + RunningIndex: Integer; + ExplicitIndex: Integer; +begin + result := -1; + RunningIndex := -1; + for i := 0 to FormatArgs.Count - 1 do begin + ExplicitIndex := GetExplicitIndex(FormatArgs[i]); + if ExplicitIndex <> -1 then + RunningIndex := ExplicitIndex + else + inc(RunningIndex); + result := Max(result, RunningIndex); + end; +end; + +procedure UpdateTypeList(FormatArgs, TypeList: TTntStrings); +var + i: integer; + f: WideString; + SpecType: TFormatSpecifierType; + ExplicitIndex: Integer; + MaxIndex: Integer; + RunningIndex: Integer; +begin + // set count of TypeList to accomodate maximum index + MaxIndex := GetMaxIndex(FormatArgs); + TypeList.Clear; + for i := 0 to MaxIndex do + TypeList.Add(''); + + // for each arg... + RunningIndex := -1; + for i := 0 to FormatArgs.Count - 1 do begin + f := FormatArgs[i]; + ExplicitIndex := GetExplicitIndex(f); + SpecType := GetFormatSpecifierType(f); + + // determine running arg index + if ExplicitIndex <> -1 then + RunningIndex := ExplicitIndex + else + inc(RunningIndex); + + if TypeList[RunningIndex] <> '' then begin + // already exists in list, check for compatibility + if TypeList.Objects[RunningIndex] <> TObject(SpecType) then + raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, + [RunningIndex, TypeList[RunningIndex], f]); + end else begin + // not in list so update it + TypeList[RunningIndex] := f; + TypeList.Objects[RunningIndex] := TObject(SpecType); + end; + end; +end; + +procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); +var + ArgList1: TTntStringList; + ArgList2: TTntStringList; + TypeList1: TTntStringList; + TypeList2: TTntStringList; + i: integer; +begin + ArgList1 := nil; + ArgList2 := nil; + TypeList1 := nil; + TypeList2 := nil; + try + ArgList1 := TTntStringList.Create; + ArgList2 := TTntStringList.Create; + TypeList1 := TTntStringList.Create; + TypeList2 := TTntStringList.Create; + + GetFormatArgs(FormatStr1, ArgList1); + UpdateTypeList(ArgList1, TypeList1); + + GetFormatArgs(FormatStr2, ArgList2); + UpdateTypeList(ArgList2, TypeList2); + + if TypeList1.Count <> TypeList2.Count then + raise EFormatSpecError.Create(SMismatchedArgumentCounts + CRLF + CRLF + '> ' + FormatStr1 + CRLF + '> ' + FormatStr2); + + for i := 0 to TypeList1.Count - 1 do begin + if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin + raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, + [i, TypeList1[i], TypeList2[i]]); + end; + end; + + finally + ArgList1.Free; + ArgList2.Free; + TypeList1.Free; + TypeList2.Free; + end; +end; + +function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; +var + ArgList1: TTntStringList; + ArgList2: TTntStringList; + TypeList1: TTntStringList; + TypeList2: TTntStringList; + i: integer; +begin + ArgList1 := nil; + ArgList2 := nil; + TypeList1 := nil; + TypeList2 := nil; + try + ArgList1 := TTntStringList.Create; + ArgList2 := TTntStringList.Create; + TypeList1 := TTntStringList.Create; + TypeList2 := TTntStringList.Create; + + GetFormatArgs(FormatStr1, ArgList1); + UpdateTypeList(ArgList1, TypeList1); + + GetFormatArgs(FormatStr2, ArgList2); + UpdateTypeList(ArgList2, TypeList2); + + Result := (TypeList1.Count = TypeList2.Count); + if Result then begin + for i := 0 to TypeList1.Count - 1 do begin + if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin + Result := False; + break; + end; + end; + end; + finally + ArgList1.Free; + ArgList2.Free; + TypeList1.Free; + TypeList2.Free; + end; +end; + +end. diff --git a/Source/TntForms.pas b/Source/TntForms.pas new file mode 100644 index 0000000..06cd09b --- /dev/null +++ b/Source/TntForms.pas @@ -0,0 +1,954 @@ + +{*****************************************************************************} +{ } +{ 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 + Windows, Messages, SysUtils, Classes, 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; + function MessageBox(const Text, Caption: PWideChar; Flags: Longint): Integer; + procedure ShowException(E: Exception); + 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 + Consts, RTLConsts, Menus, FlatSB, StdActns, Graphics, MultiMon, + 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; + +function TTntApplication.MessageBox(const Text, Caption: PWideChar; + Flags: Integer): Integer; +var + ActiveWindow, TaskActiveWindow: HWnd; + WindowList: Pointer; + MBMonitor, AppMonitor: HMonitor; + MonInfo: TMonitorInfo; + Rect: TRect; + FocusState: TFocusState; +begin + with Application do + begin +{$IFDEF DELPHI_9_UP} + ActiveWindow := ActiveFormHandle; +{$ELSE} + ActiveWindow := GetActiveWindow; + if ActiveWindow = 0 then + ActiveWindow := GetLastActivePopup(Handle); +{$ENDIF} + if ActiveWindow = 0 then + TaskActiveWindow := Handle + else + TaskActiveWindow := ActiveWindow; + MBMonitor := MonitorFromWindow(ActiveWindow, MONITOR_DEFAULTTONEAREST); + AppMonitor := MonitorFromWindow(Handle, MONITOR_DEFAULTTONEAREST); + if MBMonitor <> AppMonitor then + begin + MonInfo.cbSize := Sizeof(TMonitorInfo); + GetMonitorInfo(MBMonitor, @MonInfo); + GetWindowRect(Handle, Rect); + SetWindowPos(Handle, 0, + MonInfo.rcMonitor.Left + ((MonInfo.rcMonitor.Right - MonInfo.rcMonitor.Left) div 2), + MonInfo.rcMonitor.Top + ((MonInfo.rcMonitor.Bottom - MonInfo.rcMonitor.Top) div 2), + 0, 0, SWP_NOACTIVATE or SWP_NOREDRAW or SWP_NOSIZE or SWP_NOZORDER); + end; + WindowList := DisableTaskWindows(ActiveWindow); + FocusState := SaveFocusState; + if UseRightToLeftReading then Flags := Flags or MB_RTLREADING; + try + Result := Windows.MessageBoxW(TaskActiveWindow, Text, Caption, Flags); + finally + if MBMonitor <> AppMonitor then + SetWindowPos(Handle, 0, + Rect.Left + ((Rect.Right - Rect.Left) div 2), + Rect.Top + ((Rect.Bottom - Rect.Top) div 2), + 0, 0, SWP_NOACTIVATE or SWP_NOREDRAW or SWP_NOSIZE or SWP_NOZORDER); + EnableTaskWindows(WindowList); + SetActiveWindow(ActiveWindow); + RestoreFocusState(FocusState); + end; + end; +end; + +procedure TTntApplication.ShowException(E: Exception); +var + Msg: WideString; +begin + // Because of OverwriteProcedure call in TntSystem-unit, Self could point + // to a TApplication instance instead of a TTntApplication instance, thus + // causing access violations. Therefore frame the whole code with a + // "with TntApplication do"-statement. + + with TntApplication do + begin + if E is WideException then + begin + Msg := WideException(E).Message; + if (Msg <> '') and (TntWideLastChar(Msg) > '.') then Msg := Msg + '.'; + MessageBox(PWideChar(Msg), PWideChar(Title), MB_OK + MB_ICONSTOP); + end + else + begin + Msg := Exception(E).Message; + if (Msg <> '') and (TntWideLastChar(Msg) > '.') then Msg := Msg + '.'; + MessageBox(PWideChar(Msg), PWideChar(Title), MB_OK + MB_ICONSTOP); + 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/Source/TntGraphics.pas b/Source/TntGraphics.pas new file mode 100644 index 0000000..617b901 --- /dev/null +++ b/Source/TntGraphics.pas @@ -0,0 +1,142 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntGraphics; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Graphics, Windows; + +{TNT-WARN TextRect} +procedure WideCanvasTextRect(Canvas: TCanvas; Rect: TRect; X, Y: Integer; const Text: WideString); +{TNT-WARN TextOut} +procedure WideCanvasTextOut(Canvas: TCanvas; X, Y: Integer; const Text: WideString); +{TNT-WARN TextExtent} +function WideCanvasTextExtent(Canvas: TCanvas; const Text: WideString): TSize; +function WideDCTextExtent(hDC: THandle; const Text: WideString): TSize; +{TNT-WARN TextWidth} +function WideCanvasTextWidth(Canvas: TCanvas; const Text: WideString): Integer; +{TNT-WARN TextHeight} +function WideCanvasTextHeight(Canvas: TCanvas; const Text: WideString): Integer; + +type +{TNT-WARN TPicture} + TTntPicture = class(TPicture{TNT-ALLOW TPicture}) + public + procedure LoadFromFile(const Filename: WideString); + procedure SaveToFile(const Filename: WideString); + end; + +implementation + +uses + SysUtils, TntSysUtils; + +type + TAccessCanvas = class(TCanvas); + +procedure WideCanvasTextRect(Canvas: TCanvas; Rect: TRect; X, Y: Integer; const Text: WideString); +var + Options: Longint; +begin + with TAccessCanvas(Canvas) do begin + Changing; + RequiredState([csHandleValid, csFontValid, csBrushValid]); + Options := ETO_CLIPPED or TextFlags; + if Brush.Style <> bsClear then + Options := Options or ETO_OPAQUE; + if ((TextFlags and ETO_RTLREADING) <> 0) and + (CanvasOrientation = coRightToLeft) then Inc(X, WideCanvasTextWidth(Canvas, Text) + 1); + Windows.ExtTextOutW(Handle, X, Y, Options, @Rect, PWideChar(Text), + Length(Text), nil); + Changed; + end; +end; + +procedure WideCanvasTextOut(Canvas: TCanvas; X, Y: Integer; const Text: WideString); +begin + with TAccessCanvas(Canvas) do begin + Changing; + RequiredState([csHandleValid, csFontValid, csBrushValid]); + if CanvasOrientation = coRightToLeft then Inc(X, WideCanvasTextWidth(Canvas, Text) + 1); + Windows.ExtTextOutW(Handle, X, Y, TextFlags, nil, PWideChar(Text), + Length(Text), nil); + MoveTo(X + WideCanvasTextWidth(Canvas, Text), Y); + Changed; + end; +end; + +function WideDCTextExtent(hDC: THandle; const Text: WideString): TSize; +begin + Result.cx := 0; + Result.cy := 0; + Windows.GetTextExtentPoint32W(hDC, PWideChar(Text), Length(Text), Result); +end; + +function WideCanvasTextExtent(Canvas: TCanvas; const Text: WideString): TSize; +begin + with TAccessCanvas(Canvas) do begin + RequiredState([csHandleValid, csFontValid]); + Result := WideDCTextExtent(Handle, Text); + end; +end; + +function WideCanvasTextWidth(Canvas: TCanvas; const Text: WideString): Integer; +begin + Result := WideCanvasTextExtent(Canvas, Text).cX; +end; + +function WideCanvasTextHeight(Canvas: TCanvas; const Text: WideString): Integer; +begin + Result := WideCanvasTextExtent(Canvas, Text).cY; +end; + +{ TTntPicture } + +procedure TTntPicture.LoadFromFile(const Filename: WideString); +var + ShortName: WideString; +begin + ShortName := WideExtractShortPathName(Filename); + if WideSameText(WideExtractFileExt(FileName), '.jpeg') // the short name ends with ".JPE"! + or (ShortName = '') then // GetShortPathName failed + inherited LoadFromFile(FileName) + else + inherited LoadFromFile(WideExtractShortPathName(Filename)); +end; + +procedure TTntPicture.SaveToFile(const Filename: WideString); +var + TempFile: WideString; +begin + if Graphic <> nil then begin + // create to temp file (ansi safe file name) + repeat + TempFile := WideExtractFilePath(Filename) + IntToStr(Random(MaxInt)) + WideExtractFileExt(Filename); + until not WideFileExists(TempFile); + CloseHandle(WideFileCreate(TempFile)); // make it a real file so that it has a temp + try + // save + Graphic.SaveToFile(WideExtractShortPathName(TempFile)); + // rename + WideDeleteFile(Filename); + if not WideRenameFile(TempFile, FileName) then + RaiseLastOSError; + finally + WideDeleteFile(TempFile); + end; + end; +end; + +end. diff --git a/Source/TntGrids.pas b/Source/TntGrids.pas new file mode 100644 index 0000000..8096cd4 --- /dev/null +++ b/Source/TntGrids.pas @@ -0,0 +1,675 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntGrids; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, TntClasses, Grids, Windows, Controls, Messages; + +type +{TNT-WARN TInplaceEdit} + TTntInplaceEdit = class(TInplaceEdit{TNT-ALLOW TInplaceEdit}) + private + function GetText: WideString; + procedure SetText(const Value: WideString); + protected + procedure UpdateContents; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + public + property Text: WideString read GetText write SetText; + end; + + TTntGetEditEvent = procedure (Sender: TObject; ACol, ARow: Longint; var Value: WideString) of object; + TTntSetEditEvent = procedure (Sender: TObject; ACol, ARow: Longint; const Value: WideString) of object; + +{TNT-WARN TCustomDrawGrid} + _TTntInternalCustomDrawGrid = class(TCustomDrawGrid{TNT-ALLOW TCustomDrawGrid}) + private + FSettingEditText: Boolean; + procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); dynamic; abstract; + protected + procedure SetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; + end; + + TTntCustomDrawGrid = class(_TTntInternalCustomDrawGrid) + private + FOnGetEditText: TTntGetEditEvent; + FOnSetEditText: TTntSetEditEvent; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Msg: TWMChar); message WM_CHAR; + protected + function CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; override; + procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; + function GetEditText(ACol, ARow: Longint): WideString; reintroduce; virtual; + procedure SetEditText(ACol, ARow: Longint; const Value: WideString); reintroduce; virtual; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure ShowEditorChar(Ch: WideChar); dynamic; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + property OnGetEditText: TTntGetEditEvent read FOnGetEditText write FOnGetEditText; + property OnSetEditText: TTntSetEditEvent read FOnSetEditText write FOnSetEditText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TDrawGrid} + TTntDrawGrid = class(TTntCustomDrawGrid) + published + property Align; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelKind; + property BevelOuter; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property Color; + property ColCount; + property Constraints; + property Ctl3D; + property DefaultColWidth; + property DefaultRowHeight; + property DefaultDrawing; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property FixedColor; + property FixedCols; + property RowCount; + property FixedRows; + property Font; + property GridLineWidth; + property Options; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ScrollBars; + property ShowHint; + property TabOrder; + property Visible; + property VisibleColCount; + property VisibleRowCount; + property OnClick; + property OnColumnMoved; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawCell; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetEditMask; + property OnGetEditText; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnRowMoved; + property OnSelectCell; + property OnSetEditText; + property OnStartDock; + property OnStartDrag; + property OnTopLeftChanged; + end; + + TTntStringGrid = class; + +{TNT-WARN TStringGridStrings} + TTntStringGridStrings = class(TTntStrings) + private + FIsCol: Boolean; + FColRowIndex: Integer; + FGrid: TTntStringGrid; + function GridAnsiStrings: TStrings{TNT-ALLOW TStrings}; + protected + function Get(Index: Integer): WideString; override; + procedure Put(Index: Integer; const S: WideString); override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + constructor Create(AGrid: TTntStringGrid; AIndex: Longint); + function Add(const S: WideString): Integer; override; + procedure Assign(Source: TPersistent); override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: WideString); override; + end; + +{TNT-WARN TStringGrid} + _TTntInternalStringGrid = class(TStringGrid{TNT-ALLOW TStringGrid}) + private + FSettingEditText: Boolean; + procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); dynamic; abstract; + protected + procedure SetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; + end; + + TTntStringGrid = class(_TTntInternalStringGrid) + private + FCreatedRowStrings: TStringList{TNT-ALLOW TStringList}; + FCreatedColStrings: TStringList{TNT-ALLOW TStringList}; + FOnGetEditText: TTntGetEditEvent; + FOnSetEditText: TTntSetEditEvent; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Msg: TWMChar); message WM_CHAR; + function GetCells(ACol, ARow: Integer): WideString; + procedure SetCells(ACol, ARow: Integer; const Value: WideString); + function FindGridStrings(const IsCol: Boolean; const ListIndex: Integer): TTntStrings; + function GetCols(Index: Integer): TTntStrings; + function GetRows(Index: Integer): TTntStrings; + procedure SetCols(Index: Integer; const Value: TTntStrings); + procedure SetRows(Index: Integer; const Value: TTntStrings); + protected + function CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; override; + procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override; + procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; + function GetEditText(ACol, ARow: Longint): WideString; reintroduce; virtual; + procedure SetEditText(ACol, ARow: Longint; const Value: WideString); reintroduce; virtual; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure ShowEditorChar(Ch: WideChar); dynamic; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Cells[ACol, ARow: Integer]: WideString read GetCells write SetCells; + property Cols[Index: Integer]: TTntStrings read GetCols write SetCols; + property Rows[Index: Integer]: TTntStrings read GetRows write SetRows; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + property OnGetEditText: TTntGetEditEvent read FOnGetEditText write FOnGetEditText; + property OnSetEditText: TTntSetEditEvent read FOnSetEditText write FOnSetEditText; + end; + +implementation + +uses + SysUtils, TntSystem, TntGraphics, TntControls, TntStdCtrls, TntActnList, TntSysUtils; + +{ TBinaryCompareAnsiStringList } +type + TBinaryCompareAnsiStringList = class(TStringList{TNT-ALLOW TStringList}) + protected + function CompareStrings(const S1, S2: string{TNT-ALLOW string}): Integer; override; + end; + +function TBinaryCompareAnsiStringList.CompareStrings(const S1, S2: string{TNT-ALLOW string}): Integer; +begin + // must compare strings via binary for speed + if S1 = S2 then + result := 0 + else if S1 < S2 then + result := -1 + else + result := 1; +end; + +{ TTntInplaceEdit } + +procedure TTntInplaceEdit.CreateWindowHandle(const Params: TCreateParams); +begin + TntCustomEdit_CreateWindowHandle(Self, Params); +end; + +function TTntInplaceEdit.GetText: WideString; +begin + if IsMasked then + Result := inherited Text + else + Result := TntControl_GetText(Self); +end; + +procedure TTntInplaceEdit.SetText(const Value: WideString); +begin + if IsMasked then + inherited Text := Value + else + TntControl_SetText(Self, Value); +end; + +type TAccessCustomGrid = class(TCustomGrid); + +procedure TTntInplaceEdit.UpdateContents; +begin + Text := ''; + with TAccessCustomGrid(Grid) do + Self.EditMask := GetEditMask(Col, Row); + if (Grid is TTntStringGrid) then + with (Grid as TTntStringGrid) do + Self.Text := GetEditText(Col, Row) + else if (Grid is TTntCustomDrawGrid) then + with (Grid as TTntCustomDrawGrid) do + Self.Text := GetEditText(Col, Row) + else + with TAccessCustomGrid(Grid) do + Self.Text := GetEditText(Col, Row); + with TAccessCustomGrid(Grid) do + Self.MaxLength := GetEditLimit; +end; + +{ _TTntInternalCustomDrawGrid } + +procedure _TTntInternalCustomDrawGrid.SetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); +begin + if FSettingEditText then + inherited + else + InternalSetEditText(ACol, ARow, Value); +end; + + +{ TTntCustomDrawGrid } + +function TTntCustomDrawGrid.CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; +begin + Result := TTntInplaceEdit.Create(Self); +end; + +procedure TTntCustomDrawGrid.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomDrawGrid.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomDrawGrid.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomDrawGrid.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomDrawGrid.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntCustomDrawGrid.GetEditText(ACol, ARow: Integer): WideString; +begin + Result := ''; + if Assigned(FOnGetEditText) then FOnGetEditText(Self, ACol, ARow, Result); +end; + +procedure TTntCustomDrawGrid.InternalSetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); +begin + if not FSettingEditText then + SetEditText(ACol, ARow, TntControl_GetText(InplaceEditor)); +end; + +procedure TTntCustomDrawGrid.SetEditText(ACol, ARow: Integer; const Value: WideString); +begin + if Assigned(FOnSetEditText) then FOnSetEditText(Self, ACol, ARow, Value); +end; + +procedure TTntCustomDrawGrid.WMChar(var Msg: TWMChar); +begin + if (goEditing in Options) + and (AnsiChar(Msg.CharCode) in [^H, #32..#255]) then begin + RestoreWMCharMsg(TMessage(Msg)); + ShowEditorChar(WideChar(Msg.CharCode)); + end else + inherited; +end; + +procedure TTntCustomDrawGrid.ShowEditorChar(Ch: WideChar); +begin + ShowEditor; + if InplaceEditor <> nil then begin + if Win32PlatformIsUnicode then + PostMessageW(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0) + else + PostMessageA(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0); + end; +end; + +procedure TTntCustomDrawGrid.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomDrawGrid.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntStringGridStrings } + +procedure TTntStringGridStrings.Assign(Source: TPersistent); +var + UTF8Strings: TStringList{TNT-ALLOW TStringList}; + i: integer; +begin + UTF8Strings := TStringList{TNT-ALLOW TStringList}.Create; + try + if Source is TStrings{TNT-ALLOW TStrings} then begin + for i := 0 to TStrings{TNT-ALLOW TStrings}(Source).Count - 1 do + UTF8Strings.AddObject(WideStringToUTF8(WideString(TStrings{TNT-ALLOW TStrings}(Source).Strings[i])), + TStrings{TNT-ALLOW TStrings}(Source).Objects[i]); + GridAnsiStrings.Assign(UTF8Strings); + end else if Source is TTntStrings then begin + for i := 0 to TTntStrings(Source).Count - 1 do + UTF8Strings.AddObject(WideStringToUTF8(TTntStrings(Source).Strings[i]), + TTntStrings(Source).Objects[i]); + GridAnsiStrings.Assign(UTF8Strings); + end else + GridAnsiStrings.Assign(Source); + finally + UTF8Strings.Free; + end; +end; + +function TTntStringGridStrings.GridAnsiStrings: TStrings{TNT-ALLOW TStrings}; +begin + Assert(Assigned(FGrid)); + if FIsCol then + Result := TStringGrid{TNT-ALLOW TStringGrid}(FGrid).Cols[FColRowIndex] + else + Result := TStringGrid{TNT-ALLOW TStringGrid}(FGrid).Rows[FColRowIndex]; +end; + +procedure TTntStringGridStrings.Clear; +begin + GridAnsiStrings.Clear; +end; + +procedure TTntStringGridStrings.Delete(Index: Integer); +begin + GridAnsiStrings.Delete(Index); +end; + +function TTntStringGridStrings.GetCount: Integer; +begin + Result := GridAnsiStrings.Count; +end; + +function TTntStringGridStrings.Get(Index: Integer): WideString; +begin + Result := UTF8ToWideString(GridAnsiStrings[Index]); +end; + +procedure TTntStringGridStrings.Put(Index: Integer; const S: WideString); +begin + GridAnsiStrings[Index] := WideStringToUTF8(S); +end; + +procedure TTntStringGridStrings.Insert(Index: Integer; const S: WideString); +begin + GridAnsiStrings.Insert(Index, WideStringToUTF8(S)); +end; + +function TTntStringGridStrings.Add(const S: WideString): Integer; +begin + Result := GridAnsiStrings.Add(WideStringToUTF8(S)); +end; + +function TTntStringGridStrings.GetObject(Index: Integer): TObject; +begin + Result := GridAnsiStrings.Objects[Index]; +end; + +procedure TTntStringGridStrings.PutObject(Index: Integer; AObject: TObject); +begin + GridAnsiStrings.Objects[Index] := AObject; +end; + +type TAccessStrings = class(TStrings{TNT-ALLOW TStrings}); + +procedure TTntStringGridStrings.SetUpdateState(Updating: Boolean); +begin + TAccessStrings(GridAnsiStrings).SetUpdateState(Updating); +end; + +constructor TTntStringGridStrings.Create(AGrid: TTntStringGrid; AIndex: Integer); +begin + inherited Create; + FGrid := AGrid; + if AIndex > 0 then begin + FIsCol := False; + FColRowIndex := AIndex - 1; + end else begin + FIsCol := True; + FColRowIndex := -AIndex - 1; + end; +end; + +{ _TTntInternalStringGrid } + +procedure _TTntInternalStringGrid.SetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); +begin + if FSettingEditText then + inherited + else + InternalSetEditText(ACol, ARow, Value); +end; + +{ TTntStringGrid } + +constructor TTntStringGrid.Create(AOwner: TComponent); +begin + inherited; + FCreatedRowStrings := TBinaryCompareAnsiStringList.Create; + FCreatedRowStrings.Sorted := True; + FCreatedRowStrings.Duplicates := dupError; + FCreatedColStrings := TBinaryCompareAnsiStringList.Create; + FCreatedColStrings.Sorted := True; + FCreatedColStrings.Duplicates := dupError; +end; + +destructor TTntStringGrid.Destroy; +var + i: integer; +begin + for i := FCreatedColStrings.Count - 1 downto 0 do + FCreatedColStrings.Objects[i].Free; + for i := FCreatedRowStrings.Count - 1 downto 0 do + FCreatedRowStrings.Objects[i].Free; + FreeAndNil(FCreatedColStrings); + FreeAndNil(FCreatedRowStrings); + inherited; +end; + +function TTntStringGrid.CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; +begin + Result := TTntInplaceEdit.Create(Self); +end; + +procedure TTntStringGrid.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntStringGrid.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntStringGrid.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntStringGrid.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntStringGrid.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +function TTntStringGrid.GetCells(ACol, ARow: Integer): WideString; +begin + Result := UTF8ToWideString(inherited Cells[ACol, ARow]) +end; + +procedure TTntStringGrid.SetCells(ACol, ARow: Integer; const Value: WideString); +var + UTF8Str: AnsiString; +begin + UTF8Str := WideStringToUTF8(Value); + if inherited Cells[ACol, ARow] <> UTF8Str then + inherited Cells[ACol, ARow] := UTF8Str; +end; + +function TTntStringGrid.FindGridStrings(const IsCol: Boolean; const ListIndex: Integer): TTntStrings; +var + idx: integer; + SrcStrings: TStrings{TNT-ALLOW TStrings}; + RCIndex: Integer; +begin + if IsCol then + SrcStrings := FCreatedColStrings + else + SrcStrings := FCreatedRowStrings; + Assert(Assigned(SrcStrings)); + idx := SrcStrings.IndexOf(IntToStr(ListIndex)); + if idx <> -1 then + Result := SrcStrings.Objects[idx] as TTntStrings + else begin + if IsCol then RCIndex := -ListIndex - 1 else RCIndex := ListIndex + 1; + Result := TTntStringGridStrings.Create(Self, RCIndex); + SrcStrings.AddObject(IntToStr(ListIndex), Result); + end; +end; + +function TTntStringGrid.GetCols(Index: Integer): TTntStrings; +begin + Result := FindGridStrings(True, Index); +end; + +function TTntStringGrid.GetRows(Index: Integer): TTntStrings; +begin + Result := FindGridStrings(False, Index); +end; + +procedure TTntStringGrid.SetCols(Index: Integer; const Value: TTntStrings); +begin + FindGridStrings(True, Index).Assign(Value); +end; + +procedure TTntStringGrid.SetRows(Index: Integer; const Value: TTntStrings); +begin + FindGridStrings(False, Index).Assign(Value); +end; + +procedure TTntStringGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState); +var + SaveDefaultDrawing: Boolean; +begin + if DefaultDrawing then + WideCanvasTextRect(Canvas, ARect, ARect.Left+2, ARect.Top+2, Cells[ACol, ARow]); + SaveDefaultDrawing := DefaultDrawing; + try + DefaultDrawing := False; + inherited DrawCell(ACol, ARow, ARect, AState); + finally + DefaultDrawing := SaveDefaultDrawing; + end; +end; + +function TTntStringGrid.GetEditText(ACol, ARow: Integer): WideString; +begin + Result := Cells[ACol, ARow]; + if Assigned(FOnGetEditText) then FOnGetEditText(Self, ACol, ARow, Result); +end; + +procedure TTntStringGrid.InternalSetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); +begin + if not FSettingEditText then + SetEditText(ACol, ARow, TntControl_GetText(InplaceEditor)); +end; + +procedure TTntStringGrid.SetEditText(ACol, ARow: Integer; const Value: WideString); +begin + FSettingEditText := True; + try + inherited SetEditText(ACol, ARow, WideStringToUTF8(Value)); + finally + FSettingEditText := False; + end; + if Assigned(FOnSetEditText) then FOnSetEditText(Self, ACol, ARow, Value); +end; + +procedure TTntStringGrid.WMChar(var Msg: TWMChar); +begin + if (goEditing in Options) + and (AnsiChar(Msg.CharCode) in [^H, #32..#255]) then begin + RestoreWMCharMsg(TMessage(Msg)); + ShowEditorChar(WideChar(Msg.CharCode)); + end else + inherited; +end; + +procedure TTntStringGrid.ShowEditorChar(Ch: WideChar); +begin + ShowEditor; + if InplaceEditor <> nil then begin + if Win32PlatformIsUnicode then + PostMessageW(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0) + else + PostMessageA(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0); + end; +end; + +procedure TTntStringGrid.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntStringGrid.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +end. diff --git a/Source/TntListActns.pas b/Source/TntListActns.pas new file mode 100644 index 0000000..00601c0 --- /dev/null +++ b/Source/TntListActns.pas @@ -0,0 +1,207 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntListActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, TntActnList, ListActns; + +type +{TNT-WARN TCustomListAction} + TTntCustomListAction = class(TCustomListAction{TNT-ALLOW TCustomListAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TStaticListAction} + TTntStaticListAction = class(TStaticListAction{TNT-ALLOW TStaticListAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TVirtualListAction} + TTntVirtualListAction = class(TVirtualListAction{TNT-ALLOW TVirtualListAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +implementation + +uses + ActnList, TntClasses; + +{TNT-IGNORE-UNIT} + +type TAccessCustomListAction = class(TCustomListAction); + +procedure TntListActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntAction_AfterInherited_Assign(Action, Source); + // TCustomListAction + if (Action is TCustomListAction) and (Source is TCustomListAction) then begin + TAccessCustomListAction(Action).Images := TAccessCustomListAction(Source).Images; + TAccessCustomListAction(Action).OnGetItemCount := TAccessCustomListAction(Source).OnGetItemCount; + TAccessCustomListAction(Action).OnItemSelected := TAccessCustomListAction(Source).OnItemSelected; + TAccessCustomListAction(Action).Active := TAccessCustomListAction(Source).Active; + TAccessCustomListAction(Action).ItemIndex := TAccessCustomListAction(Source).ItemIndex; + end; + // TStaticListAction + if (Action is TStaticListAction) and (Source is TStaticListAction) then begin + TStaticListAction(Action).Items := TStaticListAction(Source).Items; + TStaticListAction(Action).OnGetItem := TStaticListAction(Source).OnGetItem; + end; + // TVirtualListAction + if (Action is TVirtualListAction) and (Source is TVirtualListAction) then begin + TVirtualListAction(Action).OnGetItem := TVirtualListAction(Source).OnGetItem; + end; +end; + +//------------------------- +// TNT LIST ACTNS +//------------------------- + +{ TTntCustomListAction } + +procedure TTntCustomListAction.Assign(Source: TPersistent); +begin + inherited; + TntListActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCustomListAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomListAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCustomListAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCustomListAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCustomListAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntStaticListAction } + +procedure TTntStaticListAction.Assign(Source: TPersistent); +begin + inherited; + TntListActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntStaticListAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntStaticListAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntStaticListAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntStaticListAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntStaticListAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntVirtualListAction } + +procedure TTntVirtualListAction.Assign(Source: TPersistent); +begin + inherited; + TntListActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntVirtualListAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntVirtualListAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntVirtualListAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntVirtualListAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntVirtualListAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/Source/TntMenus.pas b/Source/TntMenus.pas new file mode 100644 index 0000000..5777646 --- /dev/null +++ b/Source/TntMenus.pas @@ -0,0 +1,1146 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntMenus; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Windows, Classes, Menus, Graphics, Messages; + +type +{TNT-WARN TMenuItem} + TTntMenuItem = class(TMenuItem{TNT-ALLOW TMenuItem}) + private + FIgnoreMenuChanged: Boolean; + FCaption: WideString; + FHint: WideString; + FKeyboardLayout: HKL; + function GetCaption: WideString; + procedure SetInheritedCaption(const Value: AnsiString); + procedure SetCaption(const Value: WideString); + function IsCaptionStored: Boolean; + procedure UpdateMenuString(ParentMenu: TMenu); + function GetAlignmentDrawStyle: Word; + function MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer; + function GetHint: WideString; + procedure SetInheritedHint(const Value: AnsiString); + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TMenuActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure MenuChanged(Rebuild: Boolean); override; + procedure AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; + State: TOwnerDrawState; TopLevel: Boolean); override; + procedure DoDrawText(ACanvas: TCanvas; const ACaption: WideString; + var Rect: TRect; Selected: Boolean; Flags: Integer); + procedure MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); override; + public + procedure InitiateAction; override; + procedure Loaded; override; + function Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem}; + published + property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TMainMenu} + TTntMainMenu = class(TMainMenu{TNT-ALLOW TMainMenu}) + protected + procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override; + public + {$IFDEF COMPILER_9_UP} + function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override; + {$ENDIF} + end; + +{TNT-WARN TPopupMenu} + TTntPopupMenu = class(TPopupMenu{TNT-ALLOW TPopupMenu}) + protected + procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + {$IFDEF COMPILER_9_UP} + function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override; + {$ENDIF} + destructor Destroy; override; + procedure Popup(X, Y: Integer); override; + end; + +{TNT-WARN NewSubMenu} +function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext; + const AName: TComponentName; const Items: array of TTntMenuItem; + AEnabled: Boolean): TTntMenuItem; +{TNT-WARN NewItem} +function WideNewItem(const ACaption: WideString; AShortCut: TShortCut; + AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext; + const AName: TComponentName): TTntMenuItem; + +function MessageToShortCut(Msg: TWMKeyDown): TShortCut; + +{TNT-WARN ShortCutToText} +function WideShortCutToText(WordShortCut: Word): WideString; +{TNT-WARN TextToShortCut} +function WideTextToShortCut(Text: WideString): TShortCut; +{TNT-WARN GetHotKey} +function WideGetHotkey(const Text: WideString): WideString; +{TNT-WARN StripHotkey} +function WideStripHotkey(const Text: WideString): WideString; +{TNT-WARN AnsiSameCaption} +function WideSameCaption(const Text1, Text2: WideString): Boolean; + +function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; +function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; + +procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu}); + +procedure FixMenuBiDiProblem(Menu: TMenu); + +function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean; + +type + TTntPopupList = class(TPopupList) + private + SavedPopupList: TPopupList; + protected + procedure WndProc(var Message: TMessage); override; + end; + +var + TntPopupList: TTntPopupList; + +implementation + +uses + Forms, SysUtils, Consts, ActnList, ImgList, TntControls, TntGraphics, + TntActnList, TntClasses, TntForms, TntSysUtils, TntWindows; + +function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext; + const AName: TComponentName; const Items: array of TTntMenuItem; + AEnabled: Boolean): TTntMenuItem; +var + I: Integer; +begin + Result := TTntMenuItem.Create(nil); + for I := Low(Items) to High(Items) do + Result.Add(Items[I]); + Result.Caption := ACaption; + Result.HelpContext := hCtx; + Result.Name := AName; + Result.Enabled := AEnabled; +end; + +function WideNewItem(const ACaption: WideString; AShortCut: TShortCut; + AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext; + const AName: TComponentName): TTntMenuItem; +begin + Result := TTntMenuItem.Create(nil); + with Result do + begin + Caption := ACaption; + ShortCut := AShortCut; + OnClick := AOnClick; + HelpContext := hCtx; + Checked := AChecked; + Enabled := AEnabled; + Name := AName; + end; +end; + +function MessageToShortCut(Msg: TWMKeyDown): TShortCut; +var + ShiftState: TShiftState; +begin + ShiftState := Forms.KeyDataToShiftState(TWMKeyDown(Msg).KeyData); + Result := Menus.ShortCut(TWMKeyDown(Msg).CharCode, ShiftState); +end; + +function WideGetSpecialName(WordShortCut: Word): WideString; +var + ScanCode: Integer; + KeyName: array[0..255] of WideChar; +begin + Assert(Win32PlatformIsUnicode); + Result := ''; + ScanCode := MapVirtualKeyW(WordRec(WordShortCut).Lo, 0) shl 16; + if ScanCode <> 0 then + begin + GetKeyNameTextW(ScanCode, KeyName, SizeOf(KeyName)); + Result := KeyName; + end; +end; + +function WideGetKeyboardChar(Key: Word): WideChar; +var + LatinNumChar: WideChar; +begin + Assert(Win32PlatformIsUnicode); + Result := WideChar(MapVirtualKeyW(Key, 2)); + if (Key in [$30..$39]) then + begin + // Check to see if "0" - "9" can be used if all that differs is shift state + LatinNumChar := WideChar(Key - $30 + Ord('0')); + if (Result <> LatinNumChar) + and (Byte(Key) = WordRec(VkKeyScanW(LatinNumChar)).Lo) then // .Hi would be the shift state + Result := LatinNumChar; + end; +end; + +function WideShortCutToText(WordShortCut: Word): WideString; +var + Name: WideString; +begin + if (not Win32PlatformIsUnicode) + or (WordRec(WordShortCut).Lo in [$08..$09 {BKSP, TAB}, $0D {ENTER}, $1B {ESC}, $20..$28 {Misc Nav}, + $2D..$2E {INS, DEL}, $70..$87 {F1 - F24}]) + then + Result := ShortCutToText{TNT-ALLOW ShortCutToText}(WordShortCut) + else begin + case WordRec(WordShortCut).Lo of + $30..$39: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {1-9,0} + $41..$5A: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {A-Z} + $60..$69: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {numpad 1-9,0} + else + Name := WideGetSpecialName(WordShortCut); + end; + if Name <> '' then + begin + Result := ''; + if WordShortCut and scShift <> 0 then Result := Result + SmkcShift; + if WordShortCut and scCtrl <> 0 then Result := Result + SmkcCtrl; + if WordShortCut and scAlt <> 0 then Result := Result + SmkcAlt; + Result := Result + Name; + end + else Result := ''; + end; +end; + +{ This function is *very* slow. Use sparingly. Return 0 if no VK code was + found for the text } + +function WideTextToShortCut(Text: WideString): TShortCut; + + { If the front of Text is equal to Front then remove the matching piece + from Text and return True, otherwise return False } + + function CompareFront(var Text: WideString; const Front: WideString): Boolean; + begin + Result := (Pos(Front, Text) = 1); + if Result then + Delete(Text, 1, Length(Front)); + end; + +var + Key: TShortCut; + Shift: TShortCut; +begin + Result := 0; + Shift := 0; + while True do + begin + if CompareFront(Text, SmkcShift) then Shift := Shift or scShift + else if CompareFront(Text, '^') then Shift := Shift or scCtrl + else if CompareFront(Text, SmkcCtrl) then Shift := Shift or scCtrl + else if CompareFront(Text, SmkcAlt) then Shift := Shift or scAlt + else Break; + end; + if Text = '' then Exit; + for Key := $08 to $255 do { Copy range from table in ShortCutToText } + if WideSameText(Text, WideShortCutToText(Key)) then + begin + Result := Key or Shift; + Exit; + end; +end; + +function WideGetHotkeyPos(const Text: WideString): Integer; +var + I, L: Integer; +begin + Result := 0; + I := 1; + L := Length(Text); + while I <= L do + begin + if (Text[I] = cHotkeyPrefix) and (L - I >= 1) then + begin + Inc(I); + if Text[I] <> cHotkeyPrefix then + Result := I; // this might not be the last + end; + Inc(I); + end; +end; + +function WideGetHotkey(const Text: WideString): WideString; +var + I: Integer; +begin + I := WideGetHotkeyPos(Text); + if I = 0 then + Result := '' + else + Result := Text[I]; +end; + +function WideStripHotkey(const Text: WideString): WideString; +var + I: Integer; +begin + Result := Text; + I := 1; + while I <= Length(Result) do + begin + if Result[I] = cHotkeyPrefix then + if SysLocale.FarEast + and ((I > 1) and (Length(Result) - I >= 2) + and (Result[I - 1] = '(') and (Result[I + 2] = ')')) then begin + Delete(Result, I - 1, 4); + Dec(I, 2); + end else + Delete(Result, I, 1); + Inc(I); + end; +end; + +function WideSameCaption(const Text1, Text2: WideString): Boolean; +begin + Result := WideSameText(WideStripHotkey(Text1), WideStripHotkey(Text2)); +end; + +function WideSameCaptionStr(const Text1, Text2: WideString): Boolean; +begin + Result := WideSameStr(WideStripHotkey(Text1), WideStripHotkey(Text2)); +end; + +function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; +begin + if MenuItem is TTntMenuItem then + Result := TTntMenuItem(MenuItem).Caption + else + Result := MenuItem.Caption; +end; + +function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; +begin + if MenuItem is TTntMenuItem then + Result := TTntMenuItem(MenuItem).Hint + else + Result := MenuItem.Hint; +end; + +procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu}); +{If top-level items are created as owner-drawn, they will not appear as raised +buttons when the mouse hovers over them. The VCL will often create top-level +items as owner-drawn even when they don't need to be (owner-drawn state can be +set on an item-by-item basis). This routine turns off the owner-drawn flag for +top-level items if it appears unnecessary} + + function ItemHasValidImage(Item: TMenuItem{TNT-ALLOW TMenuItem}): boolean; + var + Images: TCustomImageList; + begin + Assert(Item <> nil, 'TNT Internal Error: ItemHasValidImage: item = nil'); + Images := Item.GetImageList; + Result := (Assigned(Images) and (Item.ImageIndex >= 0) and (Item.ImageIndex < Images.Count)) + or (MenuItemHasBitmap(Item) and (not Item.Bitmap.Empty)) + end; + +var + HM: HMenu; + i: integer; + Info: TMenuItemInfoA; + Item: TMenuItem{TNT-ALLOW TMenuItem}; + Win98Plus: boolean; +begin + if Assigned(Menu) then begin + Win98Plus:= (Win32MajorVersion > 4) + or((Win32MajorVersion = 4) and (Win32MinorVersion > 0)); + if not Win98Plus then + Exit; {exit if Windows 95 or NT 4.0} + HM:= Menu.Handle; + Info.cbSize:= sizeof(Info); + for i := 0 to GetMenuItemCount(HM) - 1 do begin + Info.fMask:= MIIM_FTYPE or MIIM_ID; + if not GetMenuItemInfo(HM, i, true, Info) then + Break; + if Info.fType and MFT_OWNERDRAW <> 0 then begin + Item:= Menu.FindItem(Info.wID, fkCommand); + if not Assigned(Item) then + continue; + if Assigned(Item.OnDrawItem) + or Assigned(Item.OnAdvancedDrawItem) + or ItemHasValidImage(Item) then + Continue; + Info.fMask:= MIIM_FTYPE or MIIM_STRING; + Info.fType:= (Info.fType and not MFT_OWNERDRAW) or MFT_STRING; + if Win32PlatformIsUnicode and (Item is TTntMenuItem) then begin + // Unicode + TMenuItemInfoW(Info).dwTypeData:= PWideChar(TTntMenuItem(Item).Caption); + SetMenuItemInfoW(HM, i, true, TMenuItemInfoW(Info)); + end else begin + // Ansi + Info.dwTypeData:= PAnsiChar(Item.Caption); + SetMenuItemInfoA(HM, i, true, Info); + end; + end; + end; + end; +end; + +{ TTntMenuItem's utility procs } + +procedure SyncHotKeyPosition(const Source: WideString; var Dest: WideString); +var + I: Integer; + FarEastHotString: WideString; +begin + if (AnsiString(Source) <> AnsiString(Dest)) + and WideSameCaptionStr(AnsiString(Source), AnsiString(Dest)) then begin + // when reduced to ansi, the only difference is hot key positions + Dest := WideStripHotkey(Dest); + I := 1; + while I <= Length(Source) do + begin + if Source[I] = cHotkeyPrefix then begin + if SysLocale.FarEast + and ((I > 1) and (Length(Source) - I >= 2) + and (Source[I - 1] = '(') and (Source[I + 2] = ')')) then begin + FarEastHotString := Copy(Source, I - 1, 4); + Dec(I); + Insert(FarEastHotString, Dest, I); + Inc(I, 3); + end else begin + Insert(cHotkeyPrefix, Dest, I); + Inc(I); + end; + end; + Inc(I); + end; + // test work + if AnsiString(Source) <> AnsiString(Dest) then + raise ETntInternalError.CreateFmt('Internal Error: SyncHotKeyPosition Failed ("%s" <> "%s").', + [AnsiString(Source), AnsiString(Dest)]); + end; +end; + +procedure UpdateMenuItems(Items: TMenuItem{TNT-ALLOW TMenuItem}; ParentMenu: TMenu); +var + i: integer; +begin + if (Items.ComponentState * [csReading, csDestroying] = []) then begin + for i := Items.Count - 1 downto 0 do + UpdateMenuItems(Items[i], ParentMenu); + if Items is TTntMenuItem then + TTntMenuItem(Items).UpdateMenuString(ParentMenu); + end; +end; + +procedure FixMenuBiDiProblem(Menu: TMenu); +var + i: integer; +begin + // TMenu sometimes sets bidi on first visible item which can convert caption to ansi + if (SysLocale.MiddleEast) + and (Menu <> nil) + and (Menu.Items.Count > 0) then + begin + for i := 0 to Menu.Items.Count - 1 do begin + if Menu.Items[i].Visible then begin + if (Menu.Items[i] is TTntMenuItem) then + (Menu.Items[i] as TTntMenuItem).UpdateMenuString(Menu); + break; // found first visible menu item! + end; + end; + end; +end; + + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackMenuItem = class(TComponent) + protected + FxxxxCaption: Ansistring; + FxxxxHandle: HMENU; + FxxxxChecked: Boolean; + FxxxxEnabled: Boolean; + FxxxxDefault: Boolean; + FxxxxAutoHotkeys: TMenuItemAutoFlag; + FxxxxAutoLineReduction: TMenuItemAutoFlag; + FxxxxRadioItem: Boolean; + FxxxxVisible: Boolean; + FxxxxGroupIndex: Byte; + FxxxxImageIndex: TImageIndex; + FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; + FxxxxBreak: TMenuBreak; + FBitmap: TBitmap; + FxxxxCommand: Word; + FxxxxHelpContext: THelpContext; + FxxxxHint: AnsiString; + FxxxxItems: TList; + FxxxxShortCut: TShortCut; + FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; + FMerged: TMenuItem{TNT-ALLOW TMenuItem}; + FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackMenuItem = class(TComponent) + protected + FxxxxCaption: AnsiString; + FxxxxHandle: HMENU; + FxxxxChecked: Boolean; + FxxxxEnabled: Boolean; + FxxxxDefault: Boolean; + FxxxxAutoHotkeys: TMenuItemAutoFlag; + FxxxxAutoLineReduction: TMenuItemAutoFlag; + FxxxxRadioItem: Boolean; + FxxxxVisible: Boolean; + FxxxxGroupIndex: Byte; + FxxxxImageIndex: TImageIndex; + FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; + FxxxxBreak: TMenuBreak; + FBitmap: TBitmap; + FxxxxCommand: Word; + FxxxxHelpContext: THelpContext; + FxxxxHint: AnsiString; + FxxxxItems: TList; + FxxxxShortCut: TShortCut; + FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; + FMerged: TMenuItem{TNT-ALLOW TMenuItem}; + FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackMenuItem = class(TComponent) + protected + FxxxxCaption: AnsiString; + FxxxxHandle: HMENU; + FxxxxChecked: Boolean; + FxxxxEnabled: Boolean; + FxxxxDefault: Boolean; + FxxxxAutoHotkeys: TMenuItemAutoFlag; + FxxxxAutoLineReduction: TMenuItemAutoFlag; + FxxxxRadioItem: Boolean; + FxxxxVisible: Boolean; + FxxxxGroupIndex: Byte; + FxxxxImageIndex: TImageIndex; + FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; + FxxxxBreak: TMenuBreak; + FBitmap: TBitmap; + FxxxxCommand: Word; + FxxxxHelpContext: THelpContext; + FxxxxHint: AnsiString; + FxxxxItems: TList; + FxxxxShortCut: TShortCut; + FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; + FMerged: TMenuItem{TNT-ALLOW TMenuItem}; + FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackMenuItem = class(TComponent) + protected + FxxxxCaption: AnsiString; + FxxxxHandle: HMENU; + FxxxxChecked: Boolean; + FxxxxEnabled: Boolean; + FxxxxDefault: Boolean; + FxxxxAutoHotkeys: TMenuItemAutoFlag; + FxxxxAutoLineReduction: TMenuItemAutoFlag; + FxxxxRadioItem: Boolean; + FxxxxVisible: Boolean; + FxxxxGroupIndex: Byte; + FxxxxImageIndex: TImageIndex; + FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; + FxxxxBreak: TMenuBreak; + FBitmap: TBitmap; + FxxxxCommand: Word; + FxxxxHelpContext: THelpContext; + FxxxxHint: AnsiString; + FxxxxItems: TList; + FxxxxShortCut: TShortCut; + FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; + FMerged: TMenuItem{TNT-ALLOW TMenuItem}; + FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; + end; +{$ENDIF} + +function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean; +begin + Result := Assigned(THackMenuItem(MenuItem).FBitmap); +end; + +{ TTntMenuItem } + +procedure TTntMenuItem.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +type TAccessActionlink = class(TActionLink); + +procedure TTntMenuItem.InitiateAction; +begin + if GetKeyboardLayout(0) <> FKeyboardLayout then + MenuChanged(False); + inherited; +end; + +function TTntMenuItem.IsCaptionStored: Boolean; +begin + Result := (ActionLink = nil) or (not TAccessActionlink(ActionLink).IsCaptionLinked); +end; + +procedure TTntMenuItem.SetInheritedCaption(const Value: AnsiString); +begin + inherited Caption := Value; +end; + +function TTntMenuItem.GetCaption: WideString; +begin + if (AnsiString(FCaption) <> inherited Caption) + and WideSameCaptionStr(AnsiString(FCaption), inherited Caption) then + begin + // only difference is hotkey position, update caption with new hotkey position + SyncHotKeyPosition(inherited Caption, FCaption); + end; + Result := GetSyncedWideString(FCaption, (inherited Caption)); +end; + +procedure TTntMenuItem.SetCaption(const Value: WideString); +begin + GetCaption; // auto adjust for hot key changes + SetSyncedWideString(Value, FCaption, (inherited Caption), SetInheritedCaption); +end; + +function TTntMenuItem.GetHint: WideString; +begin + Result := GetSyncedWideString(FHint, inherited Hint); +end; + +procedure TTntMenuItem.SetInheritedHint(const Value: AnsiString); +begin + inherited Hint := Value; +end; + +procedure TTntMenuItem.SetHint(const Value: WideString); +begin + SetSyncedWideString(Value, FHint, inherited Hint, SetInheritedHint); +end; + +function TTntMenuItem.IsHintStored: Boolean; +begin + Result := (ActionLink = nil) or not TAccessActionlink(ActionLink).IsHintLinked; +end; + +procedure TTntMenuItem.Loaded; +begin + inherited; + UpdateMenuString(GetParentMenu); +end; + +procedure TTntMenuItem.MenuChanged(Rebuild: Boolean); +begin + if (not FIgnoreMenuChanged) then begin + inherited; + UpdateMenuItems(Self, GetParentMenu); + FixMenuBiDiProblem(GetParentMenu); + end; +end; + +procedure TTntMenuItem.UpdateMenuString(ParentMenu: TMenu); +var + ParentHandle: THandle; + + function NativeMenuTypeIsString: Boolean; + var + MenuItemInfo: TMenuItemInfoW; + Buffer: array[0..79] of WideChar; + begin + MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0 + MenuItemInfo.fMask := MIIM_TYPE; + MenuItemInfo.dwTypeData := Buffer; // ?? + MenuItemInfo.cch := Length(Buffer); // ?? + Result := GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo) + and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0) + end; + + function NativeMenuString: WideString; + var + Len: Integer; + begin + Assert(Win32PlatformIsUnicode); + Len := GetMenuStringW(ParentHandle, Command, nil, 0, MF_BYCOMMAND); + if Len = 0 then + Result := '' + else begin + SetLength(Result, Len + 1); + Len := GetMenuStringW(ParentHandle, Command, PWideChar(Result), Len + 1, MF_BYCOMMAND); + SetLength(Result, Len); + end; + end; + + procedure SetMenuString(const Value: WideString); + var + MenuItemInfo: TMenuItemInfoW; + Buffer: array[0..79] of WideChar; + begin + MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0 + MenuItemInfo.fMask := MIIM_TYPE; + MenuItemInfo.dwTypeData := Buffer; // ?? + MenuItemInfo.cch := Length(Buffer); // ?? + if GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo) + and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0) then + begin + MenuItemInfo.dwTypeData := PWideChar(Value); + MenuItemInfo.cch := Length(Value); + Win32Check(SetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo)); + end; + end; + + function SameEvent(A, B: TMenuMeasureItemEvent): Boolean; + begin + Result := @A = @B; + end; + +var + MenuCaption: WideString; +begin + FKeyboardLayout := GetKeyboardLayout(0); + if Parent = nil then + ParentHandle := 0 + else if (THackMenuItem(Self.Parent).FMergedWith <> nil) then + ParentHandle := THackMenuItem(Self.Parent).FMergedWith.Handle + else + ParentHandle := Parent.Handle; + + if (Win32PlatformIsUnicode) + and (Parent <> nil) and (ParentMenu <> nil) + and (ComponentState * [csReading, csDestroying] = []) + and (Visible) + and (NativeMenuTypeIsString) then begin + MenuCaption := Caption; + if (Count = 0) + and ((ShortCut <> scNone) + and ((Parent = nil) or (Parent.Parent <> nil) or not (Parent.Owner is TMainMenu{TNT-ALLOW TMainMenu}))) then + MenuCaption := MenuCaption + #9 + WideShortCutToText(ShortCut); + if (NativeMenuString <> MenuCaption) then + begin + SetMenuString(MenuCaption); + if ((Parent = ParentMenu.Items) or (THackMenuItem(Self.Parent).FMergedWith <> nil)) + and (ParentMenu is TMainMenu{TNT-ALLOW TMainMenu}) + and (ParentMenu.WindowHandle <> 0) then + DrawMenuBar(ParentMenu.WindowHandle) {top level menu bar items} + end; + end; +end; + +function TTntMenuItem.GetAlignmentDrawStyle: Word; +const + Alignments: array[TPopupAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER); +var + ParentMenu: TMenu; + Alignment: TPopupAlignment; +begin + ParentMenu := GetParentMenu; + if ParentMenu is TMenu then + Alignment := paLeft + else if ParentMenu is TPopupMenu{TNT-ALLOW TPopupMenu} then + Alignment := TPopupMenu{TNT-ALLOW TPopupMenu}(ParentMenu).Alignment + else + Alignment := paLeft; + Result := Alignments[Alignment]; +end; + +procedure TTntMenuItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; + State: TOwnerDrawState; TopLevel: Boolean); + + procedure DrawMenuText(BiDi: Boolean); + var + ImageList: TCustomImageList; + DrawImage, DrawGlyph: Boolean; + GlyphRect, SaveRect: TRect; + DrawStyle: Longint; + Selected: Boolean; + Win98Plus: Boolean; + Win2K: Boolean; + begin + ImageList := GetImageList; + Selected := odSelected in State; + Win98Plus := (Win32MajorVersion > 4) or + ((Win32MajorVersion = 4) and (Win32MinorVersion > 0)); + Win2K := (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT); + with ACanvas do + begin + GlyphRect.Left := ARect.Left + 1; + DrawImage := (ImageList <> nil) and ((ImageIndex > -1) and + (ImageIndex < ImageList.Count) or Checked and ((not MenuItemHasBitmap(Self)) or + Bitmap.Empty)); + if DrawImage or MenuItemHasBitmap(Self) and not Bitmap.Empty then + begin + DrawGlyph := True; + if DrawImage then + GlyphRect.Right := GlyphRect.Left + ImageList.Width + else begin + { Need to add BitmapWidth/Height properties for TMenuItem if we're to + support them. Right now let's hardcode them to 16x16. } + GlyphRect.Right := GlyphRect.Left + 16; + end; + { Draw background pattern brush if selected } + if Checked then + begin + Inc(GlyphRect.Right); + if not Selected then + Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight); + Inc(GlyphRect.Left); + end; + if Checked then + Dec(GlyphRect.Right); + end else begin + if (ImageList <> nil) and (not TopLevel) then + GlyphRect.Right := GlyphRect.Left + ImageList.Width + else + GlyphRect.Right := GlyphRect.Left; + DrawGlyph := False; + end; + if BiDi then begin + SaveRect := GlyphRect; + GlyphRect.Left := ARect.Right - (SaveRect.Right - ARect.Left); + GlyphRect.Right := ARect.Right - (SaveRect.Left - ARect.Left); + end; + with GlyphRect do begin + Dec(Left); + Inc(Right, 2); + end; + if Selected then begin + if DrawGlyph then begin + if BiDi then + ARect.Right := GlyphRect.Left - 1 + else + ARect.Left := GlyphRect.Right + 1; + end; + if not (Win98Plus and TopLevel) then + Brush.Color := clHighlight; + end; + if TopLevel and Win98Plus and (not Selected) + {$IFDEF COMPILER_7_UP} + and (not Win32PlatformIsXP) + {$ENDIF} + then + OffsetRect(ARect, 0, -1); + if not (Selected and DrawGlyph) then begin + if BiDi then + ARect.Right := GlyphRect.Left - 1 + else + ARect.Left := GlyphRect.Right + 1; + end; + Inc(ARect.Left, 2); + Dec(ARect.Right, 1); + DrawStyle := DT_EXPANDTABS or DT_SINGLELINE or GetAlignmentDrawStyle; + if Win2K and (odNoAccel in State) then + DrawStyle := DrawStyle or DT_HIDEPREFIX; + { Calculate vertical layout } + SaveRect := ARect; + if odDefault in State then + Font.Style := [fsBold]; + DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle or DT_CALCRECT or DT_NOCLIP); + if BiDi then begin + { the DT_CALCRECT does not take into account alignment } + ARect.Left := SaveRect.Left; + ARect.Right := SaveRect.Right; + end; + OffsetRect(ARect, 0, ((SaveRect.Bottom - SaveRect.Top) - (ARect.Bottom - ARect.Top)) div 2); + if TopLevel and Selected and Win98Plus + {$IFDEF COMPILER_7_UP} + and (not Win32PlatformIsXP) + {$ENDIF} + then + OffsetRect(ARect, 1, 0); + DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle); + if (ShortCut <> scNone) and not TopLevel then + begin + if BiDi then begin + ARect.Left := 10; + ARect.Right := ARect.Left + WideCanvasTextWidth(ACanvas, WideShortCutToText(ShortCut)); + end else begin + ARect.Left := ARect.Right; + ARect.Right := SaveRect.Right - 10; + end; + DoDrawText(ACanvas, WideShortCutToText(ShortCut), ARect, Selected, DT_RIGHT); + end; + end; + end; + +var + ParentMenu: TMenu; + SaveCaption: WideString; + SaveShortCut: TShortCut; +begin + ParentMenu := GetParentMenu; + if (not Win32PlatformIsUnicode) + or (Self.IsLine) + or ( (ParentMenu <> nil) and (ParentMenu.OwnerDraw or (GetImageList <> nil)) + and (Assigned(OnAdvancedDrawItem) or Assigned(OnDrawItem)) ) then + inherited + else begin + SaveCaption := Caption; + SaveShortCut := ShortCut; + try + FIgnoreMenuChanged := True; + try + Caption := ''; + ShortCut := scNone; + finally + FIgnoreMenuChanged := False; + end; + inherited; + finally + FIgnoreMenuChanged := True; + try + Caption := SaveCaption; + ShortCut := SaveShortcut; + finally + FIgnoreMenuChanged := False; + end; + end; + DrawMenuText((ParentMenu <> nil) and (ParentMenu.IsRightToLeft)) + end; +end; + +procedure TTntMenuItem.DoDrawText(ACanvas: TCanvas; const ACaption: WideString; + var Rect: TRect; Selected: Boolean; Flags: Longint); +var + Text: WideString; + ParentMenu: TMenu; +begin + if (not Win32PlatformIsUnicode) + or (IsLine) then + inherited DoDrawText(ACanvas, ACaption, Rect, Selected, Flags) + else begin + ParentMenu := GetParentMenu; + if (ParentMenu <> nil) and (ParentMenu.IsRightToLeft) then + begin + if Flags and DT_LEFT = DT_LEFT then + Flags := Flags and (not DT_LEFT) or DT_RIGHT + else if Flags and DT_RIGHT = DT_RIGHT then + Flags := Flags and (not DT_RIGHT) or DT_LEFT; + Flags := Flags or DT_RTLREADING; + end; + Text := ACaption; + if (Flags and DT_CALCRECT <> 0) and ((Text = '') or + (Text[1] = cHotkeyPrefix) and (Text[2] = #0)) then Text := Text + ' '; + with ACanvas do + begin + Brush.Style := bsClear; + if Default then + Font.Style := Font.Style + [fsBold]; + if not Enabled then + begin + if not Selected then + begin + OffsetRect(Rect, 1, 1); + Font.Color := clBtnHighlight; + Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags); + OffsetRect(Rect, -1, -1); + end; + if Selected and (ColorToRGB(clHighlight) = ColorToRGB(clBtnShadow)) then + Font.Color := clBtnHighlight else + Font.Color := clBtnShadow; + end; + Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags); + end; + end; +end; + +function TTntMenuItem.MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer; +var + R: TRect; +begin + FillChar(R, SizeOf(R), 0); + DoDrawText(ACanvas, Text, R, False, + GetAlignmentDrawStyle or DT_EXPANDTABS or DT_SINGLELINE or DT_NOCLIP or DT_CALCRECT); + Result := R.Right - R.Left; +end; + +procedure TTntMenuItem.MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); +var + SaveMeasureItemEvent: TMenuMeasureItemEvent; +begin + if (not Win32PlatformIsUnicode) + or (Self.IsLine) then + inherited + else begin + SaveMeasureItemEvent := inherited OnMeasureItem; + try + inherited OnMeasureItem := nil; + inherited; + Inc(Width, MeasureItemTextWidth(ACanvas, Caption)); + Dec(Width, MeasureItemTextWidth(ACanvas, inherited Caption)); + if ShortCut <> scNone then begin + Inc(Width, MeasureItemTextWidth(ACanvas, WideShortCutToText(ShortCut))); + Dec(Width, MeasureItemTextWidth(ACanvas, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut))); + end; + finally + inherited OnMeasureItem := SaveMeasureItemEvent; + end; + if Assigned(OnMeasureItem) then OnMeasureItem(Self, ACanvas, Width, Height); + end; +end; + +function TTntMenuItem.Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem}; +var + I: Integer; +begin + Result := nil; + ACaption := WideStripHotkey(ACaption); + for I := 0 to Count - 1 do + if WideSameText(ACaption, WideStripHotkey(WideGetMenuItemCaption(Items[I]))) then + begin + Result := Items[I]; + System.Break; + end; +end; + +function TTntMenuItem.GetActionLinkClass: TMenuActionLinkClass; +begin + Result := TTntMenuActionLink; +end; + +procedure TTntMenuItem.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + if (Sender is TCustomAction{TNT-ALLOW TCustomAction}) and Supports(Sender, ITntAction) then begin + if not CheckDefaults or (Caption = '') then + Caption := TntAction_GetCaption(TCustomAction{TNT-ALLOW TCustomAction}(Sender)); + if not CheckDefaults or (Hint = '') then + Hint := TntAction_GetHint(TCustomAction{TNT-ALLOW TCustomAction}(Sender)); + end; + inherited; +end; + +{ TTntMainMenu } + +{$IFDEF COMPILER_9_UP} +function TTntMainMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; +begin + Result := TTntMenuItem.Create(Self); +end; +{$ENDIF} + +procedure TTntMainMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); +begin + inherited; + UpdateMenuItems(Items, Self); + if (THackMenuItem(Items).FMerged <> nil) then begin + UpdateMenuItems(THackMenuItem(Items).FMerged, Self); + end; +end; + +{ TTntPopupMenu } + +constructor TTntPopupMenu.Create(AOwner: TComponent); +begin + inherited; + PopupList.Remove(Self); + if TntPopupList <> nil then + TntPopupList.Add(Self); +end; + +{$IFDEF COMPILER_9_UP} +function TTntPopupMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; +begin + Result := TTntMenuItem.Create(Self); +end; +{$ENDIF} + +destructor TTntPopupMenu.Destroy; +begin + if TntPopupList <> nil then + TntPopupList.Remove(Self); + PopupList.Add(Self); + inherited; +end; + +procedure TTntPopupMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); +begin + inherited; + UpdateMenuItems(Items, Self); +end; + +procedure TTntPopupMenu.Popup(X, Y: Integer); +begin + Menus.PopupList := TntPopupList; + try + inherited; + finally + Menus.PopupList := TntPopupList.SavedPopupList; + end; +end; + +{ TTntPopupList } + +procedure TTntPopupList.WndProc(var Message: TMessage); +var + I, Item: Integer; + MenuItem: TMenuItem{TNT-ALLOW TMenuItem}; + FindKind: TFindItemKind; +begin + case Message.Msg of + WM_ENTERMENULOOP: + begin + Menus.PopupList := SavedPopupList; + for i := 0 to Count - 1 do + FixMenuBiDiProblem(Items[i]); + end; + WM_MENUSELECT: + with TWMMenuSelect(Message) do + begin + FindKind := fkCommand; + if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle; + for I := 0 to Count - 1 do + begin + if FindKind = fkHandle then + begin + if Menu <> 0 then + Item := Integer(GetSubMenu(Menu, IDItem)) else + Item := -1; + end + else + Item := IDItem; + MenuItem := TPopupMenu{TNT-ALLOW TPopupMenu}(Items[I]).FindItem(Item, FindKind); + if MenuItem <> nil then + begin + TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem)); + Exit; + end; + end; + TntApplication.Hint := ''; + end; + end; + inherited; +end; + +initialization + TntPopupList := TTntPopupList.Create; + TntPopupList.SavedPopupList := Menus.PopupList; + +finalization + FreeAndNil(TntPopupList); + +end. diff --git a/Source/TntRegistry.pas b/Source/TntRegistry.pas new file mode 100644 index 0000000..e3f445f --- /dev/null +++ b/Source/TntRegistry.pas @@ -0,0 +1,148 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntRegistry; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Registry, Windows, TntClasses; + +{TNT-WARN TRegistry} +type + TTntRegistry = class(TRegistry{TNT-ALLOW TRegistry}) + private + procedure WriteStringEx(dwType: DWORD; const Name, Value: WideString); + public + procedure GetKeyNames(Strings: TTntStrings); + procedure GetValueNames(Strings: TTntStrings); + function ReadString(const Name: WideString): WideString; + procedure WriteString(const Name, Value: WideString); + procedure WriteExpandString(const Name, Value: WideString); + end; + +implementation + +uses + RTLConsts, SysUtils, TntSysUtils; + +{ TTntRegistry } + +procedure TTntRegistry.GetKeyNames(Strings: TTntStrings); +var + Len: DWORD; + I: Integer; + Info: TRegKeyInfo; + S: WideString; +begin + if (not Win32PlatformIsUnicode) then + inherited GetKeyNames(Strings.AnsiStrings) + else begin + Strings.Clear; + if GetKeyInfo(Info) then + begin + SetLength(S, (Info.MaxSubKeyLen + 1) * 2); + for I := 0 to Info.NumSubKeys - 1 do + begin + Len := (Info.MaxSubKeyLen + 1) * 2; + if RegEnumKeyExW(CurrentKey, I, PWideChar(S), Len, nil, nil, nil, nil) = ERROR_SUCCESS then + Strings.Add(PWideChar(S)); + end; + end; + end; +end; + +{$IFNDEF COMPILER_9_UP} // fix declaration for RegEnumValueW (lpValueName is a PWideChar) +function RegEnumValueW(hKey: HKEY; dwIndex: DWORD; lpValueName: PWideChar; + var lpcbValueName: DWORD; lpReserved: Pointer; lpType: PDWORD; + lpData: PByte; lpcbData: PDWORD): Longint; stdcall; external advapi32 name 'RegEnumValueW'; +{$ENDIF} + +procedure TTntRegistry.GetValueNames(Strings: TTntStrings); +var + Len: DWORD; + I: Integer; + Info: TRegKeyInfo; + S: WideString; +begin + if (not Win32PlatformIsUnicode) then + inherited GetValueNames(Strings.AnsiStrings) + else begin + Strings.Clear; + if GetKeyInfo(Info) then + begin + SetLength(S, Info.MaxValueLen + 1); + for I := 0 to Info.NumValues - 1 do + begin + Len := Info.MaxValueLen + 1; + RegEnumValueW(CurrentKey, I, PWideChar(S), Len, nil, nil, nil, nil); + Strings.Add(PWideChar(S)); + end; + end; + end; +end; + +function TTntRegistry.ReadString(const Name: WideString): WideString; +var + DataType: Cardinal; + BufSize: Cardinal; +begin + if (not Win32PlatformIsUnicode) then + result := inherited ReadString(Name) + else begin + // get length and type + DataType := REG_NONE; + if RegQueryValueExW(CurrentKey, PWideChar(Name), nil, + @DataType, nil, @BufSize) <> ERROR_SUCCESS then + Result := '' + else begin + // check type + if not (DataType in [REG_SZ, REG_EXPAND_SZ]) then + raise ERegistryException.CreateFmt(SInvalidRegType, [Name]); + if BufSize = 1 then + BufSize := SizeOf(WideChar); // sometimes this occurs for single character values! + SetLength(Result, BufSize div SizeOf(WideChar)); + if RegQueryValueExW(CurrentKey, PWideChar(Name), nil, + @DataType, PByte(PWideChar(Result)), @BufSize) <> ERROR_SUCCESS then + raise ERegistryException.CreateFmt(SRegGetDataFailed, [Name]); + Result := PWideChar(Result); + end + end +end; + +procedure TTntRegistry.WriteStringEx(dwType: DWORD; const Name, Value: WideString); +begin + Assert(dwType in [REG_SZ, REG_EXPAND_SZ]); + if (not Win32PlatformIsUnicode) then begin + if dwType = REG_SZ then + inherited WriteString(Name, Value) + else + inherited WriteExpandString(Name, Value); + end else begin + if RegSetValueExW(CurrentKey, PWideChar(Name), 0, dwType, + PWideChar(Value), (Length(Value) + 1) * SizeOf(WideChar)) <> ERROR_SUCCESS then + raise ERegistryException.CreateFmt(SRegSetDataFailed, [Name]); + end; +end; + +procedure TTntRegistry.WriteString(const Name, Value: WideString); +begin + WriteStringEx(REG_SZ, Name, Value); +end; + +procedure TTntRegistry.WriteExpandString(const Name, Value: WideString); +begin + WriteStringEx(REG_EXPAND_SZ, Name, Value); +end; + +end. diff --git a/Source/TntStdActns.pas b/Source/TntStdActns.pas new file mode 100644 index 0000000..118e806 --- /dev/null +++ b/Source/TntStdActns.pas @@ -0,0 +1,1922 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntStdActns; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, ActnList, TntActnList, StdActns, TntDialogs; + +type +{TNT-WARN THintAction} + TTntHintAction = class(THintAction{TNT-ALLOW THintAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + published + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditAction} + TTntEditAction = class(TEditAction{TNT-ALLOW TEditAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditCut} + TTntEditCut = class(TEditCut{TNT-ALLOW TEditCut}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditCopy} + TTntEditCopy = class(TEditCopy{TNT-ALLOW TEditCopy}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditPaste} + TTntEditPaste = class(TEditPaste{TNT-ALLOW TEditPaste}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditSelectAll} + TTntEditSelectAll = class(TEditSelectAll{TNT-ALLOW TEditSelectAll}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditUndo} + TTntEditUndo = class(TEditUndo{TNT-ALLOW TEditUndo}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TEditDelete} + TTntEditDelete = class(TEditDelete{TNT-ALLOW TEditDelete}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + procedure UpdateTarget(Target: TObject); override; + procedure ExecuteTarget(Target: TObject); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowAction} + TTntWindowAction = class(TWindowAction{TNT-ALLOW TWindowAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowClose} + TTntWindowClose = class(TWindowClose{TNT-ALLOW TWindowClose}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowCascade} + TTntWindowCascade = class(TWindowCascade{TNT-ALLOW TWindowCascade}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowTileHorizontal} + TTntWindowTileHorizontal = class(TWindowTileHorizontal{TNT-ALLOW TWindowTileHorizontal}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowTileVertical} + TTntWindowTileVertical = class(TWindowTileVertical{TNT-ALLOW TWindowTileVertical}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowMinimizeAll} + TTntWindowMinimizeAll = class(TWindowMinimizeAll{TNT-ALLOW TWindowMinimizeAll}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TWindowArrange} + TTntWindowArrange = class(TWindowArrange{TNT-ALLOW TWindowArrange}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpAction} + TTntHelpAction = class(THelpAction{TNT-ALLOW THelpAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpContents} + TTntHelpContents = class(THelpContents{TNT-ALLOW THelpContents}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpTopicSearch} + TTntHelpTopicSearch = class(THelpTopicSearch{TNT-ALLOW THelpTopicSearch}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpOnHelp} + TTntHelpOnHelp = class(THelpOnHelp{TNT-ALLOW THelpOnHelp}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN THelpContextAction} + TTntHelpContextAction = class(THelpContextAction{TNT-ALLOW THelpContextAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TCommonDialogAction} + TTntCommonDialogAction = class(TCommonDialogAction{TNT-ALLOW TCommonDialogAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileAction} + TTntFileAction = class(TFileAction{TNT-ALLOW TFileAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileOpen} + TTntFileOpen = class(TFileOpen{TNT-ALLOW TFileOpen}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function GetDialog: TTntOpenDialog; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetDialogClass: TCommonDialogClass; override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Dialog: TTntOpenDialog read GetDialog; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileOpenWith} + TTntFileOpenWith = class(TFileOpenWith{TNT-ALLOW TFileOpenWith}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function GetDialog: TTntOpenDialog; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetDialogClass: TCommonDialogClass; override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Dialog: TTntOpenDialog read GetDialog; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFileSaveAs} + TTntFileSaveAs = class(TFileSaveAs{TNT-ALLOW TFileSaveAs}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function GetDialog: TTntSaveDialog; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetDialogClass: TCommonDialogClass; override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Dialog: TTntSaveDialog read GetDialog; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFilePrintSetup} + TTntFilePrintSetup = class(TFilePrintSetup{TNT-ALLOW TFilePrintSetup}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + + {$IFDEF COMPILER_7_UP} +{TNT-WARN TFilePageSetup} + TTntFilePageSetup = class(TFilePageSetup{TNT-ALLOW TFilePageSetup}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + {$ENDIF} + +{TNT-WARN TFileExit} + TTntFileExit = class(TFileExit{TNT-ALLOW TFileExit}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchAction} + TTntSearchAction = class(TSearchAction{TNT-ALLOW TSearchAction}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + public + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchFind} + TTntSearchFind = class(TSearchFind{TNT-ALLOW TSearchFind}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchReplace} + TTntSearchReplace = class(TSearchReplace{TNT-ALLOW TSearchReplace}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchFindFirst} + TTntSearchFindFirst = class(TSearchFindFirst{TNT-ALLOW TSearchFindFirst}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TSearchFindNext} + TTntSearchFindNext = class(TSearchFindNext{TNT-ALLOW TSearchFindNext}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TFontEdit} + TTntFontEdit = class(TFontEdit{TNT-ALLOW TFontEdit}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TColorSelect} + TTntColorSelect = class(TColorSelect{TNT-ALLOW TColorSelect}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +{TNT-WARN TPrintDlg} + TTntPrintDlg = class(TPrintDlg{TNT-ALLOW TPrintDlg}, ITntAction) + private + function GetCaption: WideString; + procedure SetCaption(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure DefineProperties(Filer: TFiler); override; + public + procedure Assign(Source: TPersistent); override; + published + property Caption: WideString read GetCaption write SetCaption; + property Hint: WideString read GetHint write SetHint; + end; + +procedure TntStdActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); + +implementation + +uses + Dialogs, TntClasses; + +{TNT-IGNORE-UNIT} + +procedure TntStdActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); +begin + TntAction_AfterInherited_Assign(Action, Source); + // TCommonDialogAction + if (Action is TCommonDialogAction) and (Source is TCommonDialogAction) then begin + TCommonDialogAction(Action).BeforeExecute := TCommonDialogAction(Source).BeforeExecute; + TCommonDialogAction(Action).OnAccept := TCommonDialogAction(Source).OnAccept; + TCommonDialogAction(Action).OnCancel := TCommonDialogAction(Source).OnCancel; + end; + // TFileOpen + if (Action is TFileOpen) and (Source is TFileOpen) then begin + {$IFDEF COMPILER_7_UP} + TFileOpen(Action).UseDefaultApp := TFileOpen(Source).UseDefaultApp; + {$ENDIF} + end; + // TFileOpenWith + if (Action is TFileOpenWith) and (Source is TFileOpenWith) then begin + TFileOpenWith(Action).FileName := TFileOpenWith(Source).FileName; + {$IFDEF COMPILER_7_UP} + TFileOpenWith(Action).AfterOpen := TFileOpenWith(Source).AfterOpen; + {$ENDIF} + end; + // TSearchFindNext + if (Action is TSearchFindNext) and (Source is TSearchFindNext) then begin + TSearchFindNext(Action).SearchFind := TSearchFindNext(Source).SearchFind; + end; +end; + +//------------------------- +// TNT STD ACTNS +//------------------------- + +{ TTntHintAction } + +procedure TTntHintAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHintAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHintAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHintAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHintAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHintAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditAction } + +procedure TTntEditAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditCut } + +procedure TTntEditCut.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditCut.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditCut.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditCut.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditCut.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditCut.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditCopy } + +procedure TTntEditCopy.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditCopy.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditCopy.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditCopy.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditCopy.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditCopy.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditPaste } + +procedure TTntEditPaste.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditPaste.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditPaste.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditPaste.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditPaste.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditPaste.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditSelectAll } + +procedure TTntEditSelectAll.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditSelectAll.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditSelectAll.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditSelectAll.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditSelectAll.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditSelectAll.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditUndo } + +procedure TTntEditUndo.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditUndo.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditUndo.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditUndo.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditUndo.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditUndo.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntEditDelete } + +procedure TTntEditDelete.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntEditDelete.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntEditDelete.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntEditDelete.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntEditDelete.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntEditDelete.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +procedure TTntEditDelete.UpdateTarget(Target: TObject); +begin + Enabled := True; +end; + +procedure TTntEditDelete.ExecuteTarget(Target: TObject); +begin + if GetControl(Target).SelLength = 0 then + GetControl(Target).SelLength := 1; + GetControl(Target).ClearSelection +end; + +{ TTntWindowAction } + +procedure TTntWindowAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowClose } + +procedure TTntWindowClose.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowClose.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowClose.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowClose.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowClose.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowClose.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowCascade } + +procedure TTntWindowCascade.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowCascade.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowCascade.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowCascade.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowCascade.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowCascade.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowTileHorizontal } + +procedure TTntWindowTileHorizontal.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowTileHorizontal.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowTileHorizontal.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowTileHorizontal.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowTileHorizontal.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowTileHorizontal.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowTileVertical } + +procedure TTntWindowTileVertical.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowTileVertical.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowTileVertical.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowTileVertical.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowTileVertical.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowTileVertical.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowMinimizeAll } + +procedure TTntWindowMinimizeAll.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowMinimizeAll.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowMinimizeAll.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowMinimizeAll.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowMinimizeAll.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowMinimizeAll.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntWindowArrange } + +procedure TTntWindowArrange.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntWindowArrange.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntWindowArrange.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntWindowArrange.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntWindowArrange.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntWindowArrange.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpAction } + +procedure TTntHelpAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpContents } + +procedure TTntHelpContents.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpContents.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpContents.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpContents.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpContents.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpContents.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpTopicSearch } + +procedure TTntHelpTopicSearch.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpTopicSearch.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpTopicSearch.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpTopicSearch.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpTopicSearch.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpTopicSearch.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpOnHelp } + +procedure TTntHelpOnHelp.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpOnHelp.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpOnHelp.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpOnHelp.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpOnHelp.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpOnHelp.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntHelpContextAction } + +procedure TTntHelpContextAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntHelpContextAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntHelpContextAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntHelpContextAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntHelpContextAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntHelpContextAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntCommonDialogAction } + +procedure TTntCommonDialogAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntCommonDialogAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCommonDialogAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntCommonDialogAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntCommonDialogAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntCommonDialogAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntFileAction } + +procedure TTntFileAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntFileOpen } + +procedure TTntFileOpen.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileOpen.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileOpen.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileOpen.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileOpen.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileOpen.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +function TTntFileOpen.GetDialog: TTntOpenDialog; +begin + Result := inherited Dialog as TTntOpenDialog; +end; + +function TTntFileOpen.GetDialogClass: TCommonDialogClass; +begin + Result := TTntOpenDialog; +end; + +{ TTntFileOpenWith } + +procedure TTntFileOpenWith.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileOpenWith.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileOpenWith.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileOpenWith.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileOpenWith.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileOpenWith.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +function TTntFileOpenWith.GetDialog: TTntOpenDialog; +begin + Result := inherited Dialog as TTntOpenDialog; +end; + +function TTntFileOpenWith.GetDialogClass: TCommonDialogClass; +begin + Result := TTntOpenDialog; +end; + +{ TTntFileSaveAs } + +procedure TTntFileSaveAs.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileSaveAs.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileSaveAs.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileSaveAs.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileSaveAs.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileSaveAs.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +function TTntFileSaveAs.GetDialog: TTntSaveDialog; +begin + Result := TOpenDialog(inherited Dialog) as TTntSaveDialog; +end; + +function TTntFileSaveAs.GetDialogClass: TCommonDialogClass; +begin + Result := TTntSaveDialog; +end; + +{ TTntFilePrintSetup } + +procedure TTntFilePrintSetup.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFilePrintSetup.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFilePrintSetup.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFilePrintSetup.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFilePrintSetup.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFilePrintSetup.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + + {$IFDEF COMPILER_7_UP} + +{ TTntFilePageSetup } + +procedure TTntFilePageSetup.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFilePageSetup.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFilePageSetup.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFilePageSetup.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFilePageSetup.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFilePageSetup.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + {$ENDIF} + +{ TTntFileExit } + +procedure TTntFileExit.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFileExit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFileExit.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFileExit.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFileExit.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFileExit.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchAction } + +procedure TTntSearchAction.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchAction.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchAction.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchAction.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchAction.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchAction.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchFind } + +procedure TTntSearchFind.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchFind.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchFind.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchFind.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchFind.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchFind.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchReplace } + +procedure TTntSearchReplace.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchReplace.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchReplace.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchReplace.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchReplace.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchReplace.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchFindFirst } + +procedure TTntSearchFindFirst.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchFindFirst.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchFindFirst.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchFindFirst.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchFindFirst.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchFindFirst.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntSearchFindNext } + +procedure TTntSearchFindNext.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntSearchFindNext.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntSearchFindNext.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntSearchFindNext.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntSearchFindNext.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntSearchFindNext.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntFontEdit } + +procedure TTntFontEdit.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntFontEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntFontEdit.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntFontEdit.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntFontEdit.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntFontEdit.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntColorSelect } + +procedure TTntColorSelect.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntColorSelect.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntColorSelect.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntColorSelect.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntColorSelect.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntColorSelect.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +{ TTntPrintDlg } + +procedure TTntPrintDlg.Assign(Source: TPersistent); +begin + inherited; + TntStdActn_AfterInherited_Assign(Self, Source); +end; + +procedure TTntPrintDlg.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntPrintDlg.GetCaption: WideString; +begin + Result := TntAction_GetCaption(Self); +end; + +procedure TTntPrintDlg.SetCaption(const Value: WideString); +begin + TntAction_SetCaption(Self, Value); +end; + +function TTntPrintDlg.GetHint: WideString; +begin + Result := TntAction_GetHint(Self); +end; + +procedure TTntPrintDlg.SetHint(const Value: WideString); +begin + TntAction_SetHint(Self, Value); +end; + +end. diff --git a/Source/TntStdCtrls.pas b/Source/TntStdCtrls.pas new file mode 100644 index 0000000..09c7da4 --- /dev/null +++ b/Source/TntStdCtrls.pas @@ -0,0 +1,3215 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntStdCtrls; + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: Implement TCustomListBox.KeyPress, OnDataFind. } + +uses + Windows, Messages, Classes, Controls, TntControls, StdCtrls, Graphics, + TntClasses, TntSysUtils; + +{TNT-WARN TCustomEdit} +type + TTntCustomEdit = class(TCustomEdit{TNT-ALLOW TCustomEdit}) + private + FPasswordChar: WideChar; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + function GetPasswordChar: WideChar; + procedure SetPasswordChar(const Value: WideChar); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetSelStart: Integer; reintroduce; virtual; + procedure SetSelStart(const Value: Integer); reintroduce; virtual; + function GetSelLength: Integer; reintroduce; virtual; + procedure SetSelLength(const Value: Integer); reintroduce; virtual; + function GetSelText: WideString; reintroduce; virtual; + property PasswordChar: WideChar read GetPasswordChar write SetPasswordChar default #0; + public + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TEdit} + TTntEdit = class(TTntCustomEdit) + published + property Align; + property Anchors; + property AutoSelect; + property AutoSize; + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property CharCase; + property Color; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property ImeMode; + property ImeName; + property MaxLength; + property OEMConvert; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PasswordChar; + property PopupMenu; + property ReadOnly; + property ShowHint; + property TabOrder; + property TabStop; + property Text; + property Visible; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +type + TTntCustomMemo = class; + + TTntMemoStrings = class(TTntStrings) + protected + FMemo: TCustomMemo{TNT-ALLOW TCustomMemo}; + FMemoLines: TStrings{TNT-ALLOW TStrings}; + FRichEditMode: Boolean; + FLineBreakStyle: TTntTextLineBreakStyle; + function Get(Index: Integer): WideString; override; + function GetCount: Integer; override; + function GetTextStr: WideString; override; + procedure Put(Index: Integer; const S: WideString); override; + procedure SetUpdateState(Updating: Boolean); override; + public + constructor Create; + procedure SetTextStr(const Value: WideString); override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: WideString); override; + end; + +{TNT-WARN TCustomMemo} + TTntCustomMemo = class(TCustomMemo{TNT-ALLOW TCustomMemo}) + private + FLines: TTntStrings; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure SetLines(const Value: TTntStrings); virtual; + function GetSelStart: Integer; reintroduce; virtual; + procedure SetSelStart(const Value: Integer); reintroduce; virtual; + function GetSelLength: Integer; reintroduce; virtual; + procedure SetSelLength(const Value: Integer); reintroduce; virtual; + function GetSelText: WideString; reintroduce; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + property Lines: TTntStrings read FLines write SetLines; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TMemo} + TTntMemo = class(TTntCustomMemo) + published + property Align; + property Alignment; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property BiDiMode; + property BorderStyle; + property Color; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property ImeMode; + property ImeName; + property Lines; + property MaxLength; + property OEMConvert; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly; + property ScrollBars; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property WantReturns; + property WantTabs; + property WordWrap; + property OnChange; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + + TTntComboBoxStrings = class(TTntStrings) + protected + function Get(Index: Integer): WideString; override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + ComboBox: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + function Add(const S: WideString): Integer; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + function IndexOf(const S: WideString): Integer; override; + procedure Insert(Index: Integer; const S: WideString); override; + end; + +type + TWMCharMsgHandler = procedure(var Message: TWMChar) of object; + +{$IFDEF DELPHI_7} // fix for Delphi 7 only +{ TD7PatchedComboBoxStrings } +type + TD7PatchedComboBoxStrings = class(TCustomComboBoxStrings) + protected + function Get(Index: Integer): string{TNT-ALLOW string}; override; + public + function Add(const S: string{TNT-ALLOW string}): Integer; override; + procedure Insert(Index: Integer; const S: string{TNT-ALLOW string}); override; + end; +{$ENDIF} + +type + ITntComboFindString = interface + ['{63BEBEF4-B1A2-495A-B558-7487B66F6827}'] + function FindString(const Value: WideString; StartPos: Integer): Integer; + end; + +{TNT-WARN TCustomComboBox} +type + TTntCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}, + IWideCustomListControl) + private + FItems: TTntStrings; + FSaveItems: TTntStrings; + FSaveItemIndex: Integer; + FFilter: WideString; + FLastTime: Cardinal; + function GetItems: TTntStrings; + function GetSelStart: Integer; + procedure SetSelStart(const Value: Integer); + function GetSelLength: Integer; + procedure SetSelLength(const Value: Integer); + function GetSelText: WideString; + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure WMChar(var Message: TWMChar); message WM_CHAR; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure DestroyWnd; override; + function GetAutoComplete_UniqueMatchOnly: Boolean; dynamic; + function GetAutoComplete_PreserveDataEntryCase: Boolean; dynamic; + procedure DoEditCharMsg(var Message: TWMChar); virtual; + procedure CreateWnd; override; + procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); override; + procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; + procedure KeyPress(var Key: AnsiChar); override; + {$IFDEF DELPHI_7} // fix for Delphi 7 only + function GetItemsClass: TCustomComboBoxStringsClass; override; + {$ENDIF} + procedure SetItems(const Value: TTntStrings); reintroduce; virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + public + property SelText: WideString read GetSelText write SetSelText; + property SelStart: Integer read GetSelStart write SetSelStart; + property SelLength: Integer read GetSelLength write SetSelLength; + property Text: WideString read GetText write SetText; + property Items: TTntStrings read GetItems write SetItems; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TComboBox} + TTntComboBox = class(TTntCustomComboBox) + published + property Align; + property AutoComplete default True; + {$IFDEF COMPILER_9_UP} + property AutoCompleteDelay default 500; + {$ENDIF} + property AutoDropDown default False; + {$IFDEF COMPILER_7_UP} + property AutoCloseUp default False; + {$ENDIF} + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property Style; {Must be published before Items} + property Anchors; + property BiDiMode; + property CharCase; + property Color; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property DropDownCount; + property Enabled; + property Font; + property ImeMode; + property ImeName; + property ItemHeight; + property ItemIndex default -1; + property MaxLength; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property Sorted; + property TabOrder; + property TabStop; + property Text; + property Visible; + property OnChange; + property OnClick; + property OnCloseUp; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawItem; + property OnDropDown; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMeasureItem; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnSelect; + property OnStartDock; + property OnStartDrag; + property Items; { Must be published after OnMeasureItem } + end; + + TLBGetWideDataEvent = procedure(Control: TWinControl; Index: Integer; + var Data: WideString) of object; + + TAccessCustomListBox = class(TCustomListBox{TNT-ALLOW TCustomListBox}); + + TTntListBoxStrings = class(TTntStrings) + private + FListBox: TAccessCustomListBox; + function GetListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + procedure SetListBox(const Value: TCustomListBox{TNT-ALLOW TCustomListBox}); + protected + procedure Put(Index: Integer; const S: WideString); override; + function Get(Index: Integer): WideString; override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + function Add(const S: WideString): Integer; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Exchange(Index1, Index2: Integer); override; + function IndexOf(const S: WideString): Integer; override; + procedure Insert(Index: Integer; const S: WideString); override; + procedure Move(CurIndex, NewIndex: Integer); override; + property ListBox: TCustomListBox{TNT-ALLOW TCustomListBox} read GetListBox write SetListBox; + end; + +{TNT-WARN TCustomListBox} +type + TTntCustomListBox = class(TCustomListBox{TNT-ALLOW TCustomListBox}, IWideCustomListControl) + private + FItems: TTntStrings; + FSaveItems: TTntStrings; + FSaveTopIndex: Integer; + FSaveItemIndex: Integer; + FOnData: TLBGetWideDataEvent; + procedure SetItems(const Value: TTntStrings); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + procedure LBGetText(var Message: TMessage); message LB_GETTEXT; + procedure LBGetTextLen(var Message: TMessage); message LB_GETTEXTLEN; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; + property OnData: TLBGetWideDataEvent read FOnData write FOnData; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure CopySelection(Destination: TCustomListControl); override; + procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; + property Items: TTntStrings read FItems write SetItems; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TListBox} + TTntListBox = class(TTntCustomListBox) + published + property Style; + property AutoComplete; + {$IFDEF COMPILER_9_UP} + property AutoCompleteDelay; + {$ENDIF} + property Align; + property Anchors; + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property BevelWidth; + property BiDiMode; + property BorderStyle; + property Color; + property Columns; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ExtendedSelect; + property Font; + property ImeMode; + property ImeName; + property IntegralHeight; + property ItemHeight; + property Items; + property MultiSelect; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ScrollWidth; + property ShowHint; + property Sorted; + property TabOrder; + property TabStop; + property TabWidth; + property Visible; + property OnClick; + property OnContextPopup; + property OnData; + property OnDataFind; + property OnDataObject; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawItem; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMeasureItem; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +{TNT-WARN TCustomLabel} + TTntCustomLabel = class(TCustomLabel{TNT-ALLOW TCustomLabel}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function GetLabelText: WideString; reintroduce; virtual; + procedure DoDrawText(var Rect: TRect; Flags: Longint); override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TLabel} + TTntLabel = class(TTntCustomLabel) + published + property Align; + property Alignment; + property Anchors; + property AutoSize; + property BiDiMode; + property Caption; + property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + {$IFDEF COMPILER_9_UP} + property EllipsisPosition; + {$ENDIF} + property Enabled; + property FocusControl; + property Font; + property ParentBiDiMode; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowAccelChar; + property ShowHint; + property Transparent; + property Layout; + property Visible; + property WordWrap; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseEnter; + property OnMouseLeave; + property OnStartDock; + property OnStartDrag; + end; + +{TNT-WARN TButton} + TTntButton = class(TButton{TNT-ALLOW TButton}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomCheckBox} + TTntCustomCheckBox = class(TCustomCheckBox{TNT-ALLOW TCustomCheckBox}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + public + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCheckBox} + TTntCheckBox = class(TTntCustomCheckBox) + published + property Action; + property Align; + property Alignment; + property AllowGrayed; + property Anchors; + property BiDiMode; + property Caption; + property Checked; + property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; + property Constraints; + property Ctl3D; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property State; + property TabOrder; + property TabStop; + property Visible; + {$IFDEF COMPILER_7_UP} + property WordWrap; + {$ENDIF} + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +{TNT-WARN TRadioButton} + TTntRadioButton = class(TRadioButton{TNT-ALLOW TRadioButton}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TScrollBar} + TTntScrollBar = class(TScrollBar{TNT-ALLOW TScrollBar}) + private + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsHintStored: Boolean; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomGroupBox} + TTntCustomGroupBox = class(TCustomGroupBox{TNT-ALLOW TCustomGroupBox}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure Paint; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TGroupBox} + TTntGroupBox = class(TTntCustomGroupBox) + published + property Align; + property Anchors; + property BiDiMode; + property Caption; + property Color; + property Constraints; + property Ctl3D; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + {$IFDEF COMPILER_10_UP} + property Padding; + {$ENDIF} + {$IFDEF COMPILER_7_UP} + property ParentBackground default True; + {$ENDIF} + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + {$IFDEF COMPILER_9_UP} + property OnAlignInsertBefore; + property OnAlignPosition; + {$ENDIF} + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDockDrop; + property OnDockOver; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +{TNT-WARN TCustomStaticText} + TTntCustomStaticText = class(TCustomStaticText{TNT-ALLOW TCustomStaticText}) + private + procedure AdjustBounds; + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + protected + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; + procedure Loaded; override; + procedure SetAutoSize(AValue: boolean); override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + public + constructor Create(AOwner: TComponent); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TStaticText} + TTntStaticText = class(TTntCustomStaticText) + published + property Align; + property Alignment; + property Anchors; + property AutoSize; + property BevelEdges; + property BevelInner; + property BevelKind default bkNone; + property BevelOuter; + property BiDiMode; + property BorderStyle; + property Caption; + property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property FocusControl; + property Font; + property ParentBiDiMode; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowAccelChar; + property ShowHint; + property TabOrder; + property TabStop; + {$IFDEF COMPILER_7_UP} + property Transparent; + {$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + +procedure TntCombo_AfterInherited_CreateWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var FSaveItems: TTntStrings; FSaveItemIndex: integer; PreInheritedAnsiText: AnsiString); +procedure TntCombo_BeforeInherited_DestroyWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var FSaveItems: TTntStrings; ItemIndex: integer; var FSaveItemIndex: integer; + var SavedText: WideString); +function TntCombo_ComboWndProc(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer; DoEditCharMsg: TWMCharMsgHandler): Boolean; +function TntCombo_CNCommand(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; Items: TTntStrings; var Message: TWMCommand): Boolean; +function TntCombo_GetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; +procedure TntCombo_SetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); +function TntCombo_GetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; +procedure TntCombo_SetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); +function TntCombo_GetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): WideString; +procedure TntCombo_SetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: WideString); +procedure TntCombo_BeforeKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); +procedure TntCombo_AfterKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); +procedure TntCombo_DropDown_PreserveSelection(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}); +procedure TntComboBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); +procedure TntComboBox_CopySelection(Items: TTntStrings; ItemIndex: Integer; + Destination: TCustomListControl); +procedure TntCombo_AutoSearchKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var Message: TWMChar; var FFilter: WideString; var FLastTime: Cardinal); +procedure TntCombo_AutoCompleteKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var Message: TWMChar; + AutoComplete_UniqueMatchOnly, AutoComplete_PreserveDataEntryCase: Boolean); +procedure TntCombo_DefaultDrawItem(Canvas: TCanvas; Index: Integer; Rect: TRect; + State: TOwnerDrawState; Items: TTntStrings); + +procedure TntCustomEdit_CreateWindowHandle(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Params: TCreateParams); +procedure TntCustomEdit_AfterInherited_CreateWnd(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar); +function TntCustomEdit_GetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; +procedure TntCustomEdit_SetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); +function TntCustomEdit_GetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; +procedure TntCustomEdit_SetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); +function TntCustomEdit_GetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): WideString; +procedure TntCustomEdit_SetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: WideString); +function TntCustomEdit_GetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar): WideChar; +procedure TntCustomEdit_SetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar; const Value: WideChar); + + +function TntMemo_LineStart(Handle: THandle; Index: Integer): Integer; +function TntMemo_LineLength(Handle: THandle; Index: Integer; StartPos: Integer = -1): Integer; + +procedure TntListBox_AfterInherited_CreateWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + var FSaveItems: TTntStrings; FItems: TTntStrings; FSaveTopIndex, FSaveItemIndex: Integer); +procedure TntListBox_BeforeInherited_DestroyWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + var FSaveItems: TTntStrings; const FItems: TTntStrings; var FSaveTopIndex, FSaveItemIndex: Integer); +procedure TntListBox_DrawItem_Text(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; Items: TTntStrings; Index: Integer; Rect: TRect); +procedure TntListBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); +procedure TntListBox_CopySelection(ListBox: TCustomListbox{TNT-ALLOW TCustomListbox}; + Items: TTntStrings; Destination: TCustomListControl); +function TntCustomListBox_LBGetText(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; +function TntCustomListBox_LBGetTextLen(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; + +function TntLabel_DoDrawText(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Rect: TRect; Flags: Integer; const GetLabelText: WideString): Boolean; +procedure TntLabel_CMDialogChar(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Message: TCMDialogChar; const Caption: WideString); + +procedure TntButton_CMDialogChar(Button: TButton{TNT-ALLOW TButton}; var Message: TCMDialogChar); + +implementation + +uses + Forms, SysUtils, Consts, RichEdit, ComStrs, + RTLConsts, {$IFDEF THEME_7_UP} Themes, {$ENDIF} + TntForms, TntGraphics, TntActnList, TntWindows, + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; + +{ TTntCustomEdit } + +procedure TntCustomEdit_CreateWindowHandle(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Params: TCreateParams); +var + P: TCreateParams; +begin + if SysLocale.FarEast + and (not Win32PlatformIsUnicode) + and ((Params.Style and ES_READONLY) <> 0) then begin + // Work around Far East Win95 API/IME bug. + P := Params; + P.Style := P.Style and (not ES_READONLY); + CreateUnicodeHandle(Edit, P, 'EDIT'); + if Edit.HandleAllocated then + SendMessage(Edit.Handle, EM_SETREADONLY, Ord(True), 0); + end else + CreateUnicodeHandle(Edit, Params, 'EDIT'); +end; + +procedure TntCustomEdit_AfterInherited_CreateWnd(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar); +var + PasswordChar: WideChar; +begin + PasswordChar := TntCustomEdit_GetPasswordChar(Edit, FPasswordChar); + if Win32PlatformIsUnicode then + SendMessageW(Edit.Handle, EM_SETPASSWORDCHAR, Ord(PasswordChar), 0); +end; + +function TntCustomEdit_GetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; +begin + if Win32PlatformIsUnicode then + Result := Edit.SelStart + else + Result := Length(WideString(Copy(Edit.Text, 1, Edit.SelStart))); +end; + +procedure TntCustomEdit_SetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); +begin + if Win32PlatformIsUnicode then + Edit.SelStart := Value + else + Edit.SelStart := Length(AnsiString(Copy(TntControl_GetText(Edit), 1, Value))); +end; + +function TntCustomEdit_GetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; +begin + if Win32PlatformIsUnicode then + Result := Edit.SelLength + else + Result := Length(TntCustomEdit_GetSelText(Edit)); +end; + +procedure TntCustomEdit_SetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); +var + StartPos: Integer; +begin + if Win32PlatformIsUnicode then + Edit.SelLength := Value + else begin + StartPos := TntCustomEdit_GetSelStart(Edit); + Edit.SelLength := Length(AnsiString(Copy(TntControl_GetText(Edit), StartPos + 1, Value))); + end; +end; + +function TntCustomEdit_GetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): WideString; +begin + if Win32PlatformIsUnicode then + Result := Copy(TntControl_GetText(Edit), Edit.SelStart + 1, Edit.SelLength) + else + Result := Edit.SelText +end; + +procedure TntCustomEdit_SetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: WideString); +begin + if Win32PlatformIsUnicode then + SendMessageW(Edit.Handle, EM_REPLACESEL, 0, Longint(PWideChar(Value))) + else + Edit.SelText := Value; +end; + +function WideCharToAnsiChar(const C: WideChar): AnsiChar; +begin + if C <= High(AnsiChar) then + Result := AnsiChar(C) + else + Result := '*'; +end; + +type TAccessCustomEdit = class(TCustomEdit{TNT-ALLOW TCustomEdit}); + +function TntCustomEdit_GetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar): WideChar; +begin + if TAccessCustomEdit(Edit).PasswordChar <> WideCharToAnsiChar(FPasswordChar) then + FPasswordChar := WideChar(TAccessCustomEdit(Edit).PasswordChar); + Result := FPasswordChar; +end; + +procedure TntCustomEdit_SetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar; const Value: WideChar); +var + SaveWindowHandle: Integer; + PasswordCharSetHere: Boolean; +begin + if TntCustomEdit_GetPasswordChar(Edit, FPasswordChar) <> Value then + begin + FPasswordChar := Value; + PasswordCharSetHere := Win32PlatformIsUnicode and Edit.HandleAllocated; + SaveWindowHandle := TAccessCustomEdit(Edit).WindowHandle; + try + if PasswordCharSetHere then + TAccessCustomEdit(Edit).WindowHandle := 0; // this prevents TCustomEdit from actually changing it + TAccessCustomEdit(Edit).PasswordChar := WideCharToAnsiChar(FPasswordChar); + finally + TAccessCustomEdit(Edit).WindowHandle := SaveWindowHandle; + end; + if PasswordCharSetHere then + begin + Assert(Win32PlatformIsUnicode); + Assert(Edit.HandleAllocated); + SendMessageW(Edit.Handle, EM_SETPASSWORDCHAR, Ord(FPasswordChar), 0); + Edit.Invalidate; + end; + end; +end; + +procedure TTntCustomEdit.CreateWindowHandle(const Params: TCreateParams); +begin + TntCustomEdit_CreateWindowHandle(Self, Params); +end; + +procedure TTntCustomEdit.CreateWnd; +begin + inherited; + TntCustomEdit_AfterInherited_CreateWnd(Self, FPasswordChar); +end; + +procedure TTntCustomEdit.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomEdit.GetSelStart: Integer; +begin + Result := TntCustomEdit_GetSelStart(Self); +end; + +procedure TTntCustomEdit.SetSelStart(const Value: Integer); +begin + TntCustomEdit_SetSelStart(Self, Value); +end; + +function TTntCustomEdit.GetSelLength: Integer; +begin + Result := TntCustomEdit_GetSelLength(Self); +end; + +procedure TTntCustomEdit.SetSelLength(const Value: Integer); +begin + TntCustomEdit_SetSelLength(Self, Value); +end; + +function TTntCustomEdit.GetSelText: WideString; +begin + Result := TntCustomEdit_GetSelText(Self); +end; + +procedure TTntCustomEdit.SetSelText(const Value: WideString); +begin + TntCustomEdit_SetSelText(Self, Value); +end; + +function TTntCustomEdit.GetPasswordChar: WideChar; +begin + Result := TntCustomEdit_GetPasswordChar(Self, FPasswordChar); +end; + +procedure TTntCustomEdit.SetPasswordChar(const Value: WideChar); +begin + TntCustomEdit_SetPasswordChar(Self, FPasswordChar, Value); +end; + +function TTntCustomEdit.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomEdit.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +function TTntCustomEdit.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomEdit.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomEdit.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomEdit.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntMemoStrings } + +constructor TTntMemoStrings.Create; +begin + inherited; + FLineBreakStyle := tlbsCRLF; +end; + +function TTntMemoStrings.GetCount: Integer; +begin + Result := FMemoLines.Count; +end; + +function TntMemo_LineStart(Handle: THandle; Index: Integer): Integer; +begin + Assert(Win32PlatformIsUnicode); + Result := SendMessageW(Handle, EM_LINEINDEX, Index, 0); +end; + +function TntMemo_LineLength(Handle: THandle; Index: Integer; StartPos: Integer = -1): Integer; +begin + Assert(Win32PlatformIsUnicode); + if StartPos = -1 then + StartPos := TntMemo_LineStart(Handle, Index); + if StartPos < 0 then + Result := 0 + else + Result := SendMessageW(Handle, EM_LINELENGTH, StartPos, 0); +end; + +function TTntMemoStrings.Get(Index: Integer): WideString; +var + Len: Integer; +begin + if (not IsWindowUnicode(FMemo.Handle)) then + Result := FMemoLines[Index] + else begin + SetLength(Result, TntMemo_LineLength(FMemo.Handle, Index)); + if Length(Result) > 0 then begin + if Length(Result) > High(Word) then + raise EOutOfResources.Create(SOutlineLongLine); + Word((PWideChar(Result))^) := Length(Result); + Len := SendMessageW(FMemo.Handle, EM_GETLINE, Index, Longint(PWideChar(Result))); + SetLength(Result, Len); + end; + end; +end; + +procedure TTntMemoStrings.Put(Index: Integer; const S: WideString); +var + StartPos: Integer; +begin + if (not IsWindowUnicode(FMemo.Handle)) then + FMemoLines[Index] := S + else begin + StartPos := TntMemo_LineStart(FMemo.Handle, Index); + if StartPos >= 0 then + begin + SendMessageW(FMemo.Handle, EM_SETSEL, StartPos, StartPos + TntMemo_LineLength(FMemo.Handle, Index)); + SendMessageW(FMemo.Handle, EM_REPLACESEL, 0, Longint(PWideChar(S))); + end; + end; +end; + +procedure TTntMemoStrings.Insert(Index: Integer; const S: Widestring); + + function RichEditSelStartW: Integer; + var + CharRange: TCharRange; + begin + SendMessageW(FMemo.Handle, EM_EXGETSEL, 0, Longint(@CharRange)); + Result := CharRange.cpMin; + end; + +var + StartPos, LineLen: Integer; + Line: WideString; +begin + if (not IsWindowUnicode(FMemo.Handle)) then + FMemoLines.Insert(Index, S) + else begin + if Index >= 0 then + begin + StartPos := TntMemo_LineStart(FMemo.Handle, Index); + if StartPos >= 0 then + Line := S + CRLF + else begin + StartPos := TntMemo_LineStart(FMemo.Handle, Index - 1); + LineLen := TntMemo_LineLength(FMemo.Handle, Index - 1); + if LineLen = 0 then + Exit; + Inc(StartPos, LineLen); + Line := CRLF + s; + end; + SendMessageW(FMemo.Handle, EM_SETSEL, StartPos, StartPos); + + if (FRichEditMode) + and (FLineBreakStyle <> tlbsCRLF) then begin + Line := TntAdjustLineBreaks(Line, FLineBreakStyle); + if Line = CR then + Line := CRLF; { This helps a ReadOnly RichEdit 4.1 control to insert a blank line. } + SendMessageW(FMemo.Handle, EM_REPLACESEL, 0, Longint(PWideChar(Line))); + if Line = CRLF then + Line := CR; + end else + SendMessageW(FMemo.Handle, EM_REPLACESEL, 0, Longint(PWideChar(Line))); + + if (FRichEditMode) + and (RichEditSelStartW <> (StartPos + Length(Line))) then + raise EOutOfResources.Create(sRichEditInsertError); + end; + end; +end; + +procedure TTntMemoStrings.Delete(Index: Integer); +begin + FMemoLines.Delete(Index); +end; + +procedure TTntMemoStrings.Clear; +begin + FMemoLines.Clear; +end; + +type TAccessStrings = class(TStrings{TNT-ALLOW TStrings}); + +procedure TTntMemoStrings.SetUpdateState(Updating: Boolean); +begin + TAccessStrings(FMemoLines).SetUpdateState(Updating); +end; + +function TTntMemoStrings.GetTextStr: WideString; +begin + if (not FRichEditMode) then + Result := TntControl_GetText(FMemo) + else + Result := inherited GetTextStr; +end; + +procedure TTntMemoStrings.SetTextStr(const Value: WideString); +var + NewText: WideString; +begin + NewText := TntAdjustLineBreaks(Value, FLineBreakStyle); + if NewText <> GetTextStr then begin + FMemo.HandleNeeded; + TntControl_SetText(FMemo, NewText); + end; +end; + +{ TTntCustomMemo } + +constructor TTntCustomMemo.Create(AOwner: TComponent); +begin + inherited; + FLines := TTntMemoStrings.Create; + TTntMemoStrings(FLines).FMemo := Self; + TTntMemoStrings(FLines).FMemoLines := TCustomMemo{TNT-ALLOW TCustomMemo}(Self).Lines; +end; + +destructor TTntCustomMemo.Destroy; +begin + FreeAndNil(FLines); + inherited; +end; + +procedure TTntCustomMemo.SetLines(const Value: TTntStrings); +begin + FLines.Assign(Value); +end; + +procedure TTntCustomMemo.CreateWindowHandle(const Params: TCreateParams); +begin + TntCustomEdit_CreateWindowHandle(Self, Params); +end; + +procedure TTntCustomMemo.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomMemo.GetSelStart: Integer; +begin + Result := TntCustomEdit_GetSelStart(Self); +end; + +procedure TTntCustomMemo.SetSelStart(const Value: Integer); +begin + TntCustomEdit_SetSelStart(Self, Value); +end; + +function TTntCustomMemo.GetSelLength: Integer; +begin + Result := TntCustomEdit_GetSelLength(Self); +end; + +procedure TTntCustomMemo.SetSelLength(const Value: Integer); +begin + TntCustomEdit_SetSelLength(Self, Value); +end; + +function TTntCustomMemo.GetSelText: WideString; +begin + Result := TntCustomEdit_GetSelText(Self); +end; + +procedure TTntCustomMemo.SetSelText(const Value: WideString); +begin + TntCustomEdit_SetSelText(Self, Value); +end; + +function TTntCustomMemo.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomMemo.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +function TTntCustomMemo.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomMemo.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomMemo.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomMemo.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomMemo.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{$IFDEF DELPHI_7} // fix for Delphi 7 only +function TD7PatchedComboBoxStrings.Get(Index: Integer): string{TNT-ALLOW string}; +var + Len: Integer; +begin + Len := SendMessage(ComboBox.Handle, CB_GETLBTEXTLEN, Index, 0); + if Len > 0 then + begin + SetLength(Result, Len); + SendMessage(ComboBox.Handle, CB_GETLBTEXT, Index, Longint(PChar{TNT-ALLOW PChar}(Result))); + end + else + SetLength(Result, 0); +end; + +function TD7PatchedComboBoxStrings.Add(const S: string{TNT-ALLOW string}): Integer; +begin + Result := SendMessage(ComboBox.Handle, CB_ADDSTRING, 0, Longint(PChar{TNT-ALLOW PChar}(S))); + if Result < 0 then + raise EOutOfResources.Create(SInsertLineError); +end; + +procedure TD7PatchedComboBoxStrings.Insert(Index: Integer; const S: string{TNT-ALLOW string}); +begin + if SendMessage(ComboBox.Handle, CB_INSERTSTRING, Index, + Longint(PChar{TNT-ALLOW PChar}(S))) < 0 then + raise EOutOfResources.Create(SInsertLineError); +end; +{$ENDIF} + +{ TTntComboBoxStrings } + +function TTntComboBoxStrings.GetCount: Integer; +begin + Result := ComboBox.Items.Count; +end; + +function TTntComboBoxStrings.Get(Index: Integer): WideString; +var + Len: Integer; +begin + if (not IsWindowUnicode(ComboBox.Handle)) then + Result := ComboBox.Items[Index] + else begin + Len := SendMessageW(ComboBox.Handle, CB_GETLBTEXTLEN, Index, 0); + if Len = CB_ERR then + Result := '' + else begin + SetLength(Result, Len + 1); + Len := SendMessageW(ComboBox.Handle, CB_GETLBTEXT, Index, Longint(PWideChar(Result))); + if Len = CB_ERR then + Result := '' + else + Result := PWideChar(Result); + end; + end; +end; + +function TTntComboBoxStrings.GetObject(Index: Integer): TObject; +begin + Result := ComboBox.Items.Objects[Index]; +end; + +procedure TTntComboBoxStrings.PutObject(Index: Integer; AObject: TObject); +begin + ComboBox.Items.Objects[Index] := AObject; +end; + +function TTntComboBoxStrings.Add(const S: WideString): Integer; +begin + if (not IsWindowUnicode(ComboBox.Handle)) then + Result := ComboBox.Items.Add(S) + else begin + Result := SendMessageW(ComboBox.Handle, CB_ADDSTRING, 0, Longint(PWideChar(S))); + if Result < 0 then + raise EOutOfResources.Create(SInsertLineError); + end; +end; + +procedure TTntComboBoxStrings.Insert(Index: Integer; const S: WideString); +begin + if (not IsWindowUnicode(ComboBox.Handle)) then + ComboBox.Items.Insert(Index, S) + else begin + if SendMessageW(ComboBox.Handle, CB_INSERTSTRING, Index, Longint(PWideChar(S))) < 0 then + raise EOutOfResources.Create(SInsertLineError); + end; +end; + +procedure TTntComboBoxStrings.Delete(Index: Integer); +begin + ComboBox.Items.Delete(Index); +end; + +procedure TTntComboBoxStrings.Clear; +var + S: WideString; +begin + S := TntControl_GetText(ComboBox); + SendMessage(ComboBox.Handle, CB_RESETCONTENT, 0, 0); + TntControl_SetText(ComboBox, S); + ComboBox.Update; +end; + +procedure TTntComboBoxStrings.SetUpdateState(Updating: Boolean); +begin + TAccessStrings(ComboBox.Items).SetUpdateState(Updating); +end; + +function TTntComboBoxStrings.IndexOf(const S: WideString): Integer; +begin + if (not IsWindowUnicode(ComboBox.Handle)) then + Result := ComboBox.Items.IndexOf(S) + else + Result := SendMessageW(ComboBox.Handle, CB_FINDSTRINGEXACT, -1, LongInt(PWideChar(S))); +end; + +{ TTntCustomComboBox } + +type TAccessCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}); + +procedure TntCombo_AfterInherited_CreateWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var FSaveItems: TTntStrings; FSaveItemIndex: integer; PreInheritedAnsiText: AnsiString); +begin + if (not Win32PlatformIsUnicode) then begin + TAccessCustomComboBox(Combo).Text := PreInheritedAnsiText; + end else begin + with TAccessCustomComboBox(Combo) do + begin + if ListHandle <> 0 then begin + // re-extract FDefListProc as a Unicode proc + SetWindowLongA(ListHandle, GWL_WNDPROC, Integer(FDefListProc)); + FDefListProc := Pointer(GetWindowLongW(ListHandle, GWL_WNDPROC)); + // override with FListInstance as a Unicode proc + SetWindowLongW(ListHandle, GWL_WNDPROC, Integer(FListInstance)); + end; + SetWindowLongW(EditHandle, GWL_WNDPROC, GetWindowLong(EditHandle, GWL_WNDPROC)); + end; + if FSaveItems <> nil then + begin + Items.Assign(FSaveItems); + FreeAndNil(FSaveItems); + if FSaveItemIndex <> -1 then + begin + if Items.Count < FSaveItemIndex then FSaveItemIndex := Items.Count; + SendMessage(Combo.Handle, CB_SETCURSEL, FSaveItemIndex, 0); + end; + end; + TntControl_SetText(Combo, TntControl_GetStoredText(Combo, TAccessCustomComboBox(Combo).Text)); + end; +end; + +procedure TntCombo_BeforeInherited_DestroyWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var FSaveItems: TTntStrings; ItemIndex: integer; var FSaveItemIndex: integer; + var SavedText: WideString); +begin + Assert(not (csDestroyingHandle in Combo.ControlState)); + if (Win32PlatformIsUnicode) then begin + SavedText := TntControl_GetText(Combo); + if (Items.Count > 0) then + begin + FSaveItems := TTntStringList.Create; + FSaveItems.Assign(Items); + FSaveItemIndex:= ItemIndex; + Items.Clear; { This keeps TCustomComboBox from creating its own FSaveItems. (this kills the original ItemIndex) } + end; + end; +end; + +function TntCombo_ComboWndProc(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer; DoEditCharMsg: TWMCharMsgHandler): Boolean; + + procedure CallDefaultWindowProc; + begin + with Message do begin { call default wnd proc } + if IsWindowUnicode(ComboWnd) then + Result := CallWindowProcW(ComboProc, ComboWnd, Msg, WParam, LParam) + else + Result := CallWindowProcA(ComboProc, ComboWnd, Msg, WParam, LParam); + end; + end; + + function DoWideKeyPress(Message: TWMChar): Boolean; + begin + DoEditCharMsg(Message); + Result := (Message.CharCode = 0); + end; + +begin + Result := False; + try + if (Message.Msg = WM_CHAR) then begin + // WM_CHAR + Result := True; + if IsWindowUnicode(ComboWnd) then + MakeWMCharMsgSafeForAnsi(Message); + try + if TAccessCustomComboBox(Combo).DoKeyPress(TWMKey(Message)) then Exit; + if DoWideKeyPress(TWMKey(Message)) then Exit; + finally + if IsWindowUnicode(ComboWnd) then + RestoreWMCharMsg(Message); + end; + with TWMKey(Message) do begin + if ((CharCode = VK_RETURN) or (CharCode = VK_ESCAPE)) and Combo.DroppedDown then begin + Combo.DroppedDown := False; + Exit; + end; + end; + CallDefaultWindowProc; + end else if (IsWindowUnicode(ComboWnd)) then begin + // UNICODE + if IsTextMessage(Message.Msg) + or (Message.Msg = EM_REPLACESEL) + or (Message.Msg = WM_IME_COMPOSITION) + then begin + // message w/ text parameter + Result := True; + CallDefaultWindowProc; + end else if (Message.Msg = WM_IME_CHAR) then begin + // WM_IME_CHAR + Result := True; + with Message do { convert to WM_CHAR } + Result := SendMessageW(ComboWnd, WM_CHAR, WParam, LParam); + end; + end; + except + Application.HandleException(Combo); + end; +end; + +function TntCombo_CNCommand(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; Items: TTntStrings; var Message: TWMCommand): Boolean; +begin + Result := False; + if Message.NotifyCode = CBN_SELCHANGE then begin + Result := True; + TntControl_SetText(Combo, Items[Combo.ItemIndex]); + TAccessCustomComboBox(Combo).Click; + TAccessCustomComboBox(Combo).Select; + end; +end; + +function TntCombo_GetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; +begin + if Win32PlatformIsUnicode then + Result := Combo.SelStart + else + Result := Length(WideString(Copy(TAccessCustomComboBox(Combo).Text, 1, Combo.SelStart))); +end; + +procedure TntCombo_SetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); +begin + if Win32PlatformIsUnicode then + Combo.SelStart := Value + else + Combo.SelStart := Length(AnsiString(Copy(TntControl_GetText(Combo), 1, Value))); +end; + +function TntCombo_GetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; +begin + if Win32PlatformIsUnicode then + Result := Combo.SelLength + else + Result := Length(TntCombo_GetSelText(Combo)); +end; + +procedure TntCombo_SetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); +var + StartPos: Integer; +begin + if Win32PlatformIsUnicode then + Combo.SelLength := Value + else begin + StartPos := TntCombo_GetSelStart(Combo); + Combo.SelLength := Length(AnsiString(Copy(TntControl_GetText(Combo), StartPos + 1, Value))); + end; +end; + +function TntCombo_GetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): WideString; +begin + if Win32PlatformIsUnicode then begin + Result := ''; + if TAccessCustomComboBox(Combo).Style < csDropDownList then + Result := Copy(TntControl_GetText(Combo), Combo.SelStart + 1, Combo.SelLength); + end else + Result := Combo.SelText +end; + +procedure TntCombo_SetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: WideString); +begin + if Win32PlatformIsUnicode then begin + if TAccessCustomComboBox(Combo).Style < csDropDownList then + begin + Combo.HandleNeeded; + SendMessageW(TAccessCustomComboBox(Combo).EditHandle, EM_REPLACESEL, 0, Longint(PWideChar(Value))); + end; + end else + Combo.SelText := Value +end; + +procedure TntCombo_BeforeKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); +begin + SaveAutoComplete := TAccessCustomComboBox(Combo).AutoComplete; + TAccessCustomComboBox(Combo).AutoComplete := False; +end; + +procedure TntCombo_AfterKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); +begin + TAccessCustomComboBox(Combo).AutoComplete := SaveAutoComplete; +end; + +procedure TntCombo_DropDown_PreserveSelection(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}); +var + OldSelStart, OldSelLength: Integer; + OldText: WideString; +begin + OldText := TntControl_GetText(Combo); + OldSelStart := TntCombo_GetSelStart(Combo); + OldSelLength := TntCombo_GetSelLength(Combo); + Combo.DroppedDown := True; + TntControl_SetText(Combo, OldText); + TntCombo_SetSelStart(Combo, OldSelStart); + TntCombo_SetSelLength(Combo ,OldSelLength); +end; + +procedure TntComboBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); +begin + Items.AddObject(Item, AObject); +end; + +procedure TntComboBox_CopySelection(Items: TTntStrings; ItemIndex: Integer; + Destination: TCustomListControl); +begin + if ItemIndex <> -1 then + WideListControl_AddItem(Destination, Items[ItemIndex], Items.Objects[ItemIndex]); +end; + +function TntCombo_FindString(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + StartPos: Integer; const Text: WideString): Integer; +var + ComboFindString: ITntComboFindString; +begin + if Combo.GetInterface(ITntComboFindString, ComboFindString) then + Result := ComboFindString.FindString(Text, StartPos) + else if IsWindowUnicode(Combo.Handle) then + Result := SendMessageW(Combo.Handle, CB_FINDSTRING, StartPos, Integer(PWideChar(Text))) + else + Result := SendMessageA(Combo.Handle, CB_FINDSTRING, StartPos, Integer(PAnsiChar(AnsiString(Text)))) +end; + +function TntCombo_FindUniqueString(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + StartPos: Integer; const Text: WideString): Integer; +var + Match_1, Match_2: Integer; +begin + Result := CB_ERR; + Match_1 := TntCombo_FindString(Combo, -1, Text); + if Match_1 <> CB_ERR then begin + Match_2 := TntCombo_FindString(Combo, Match_1, Text); + if Match_2 = Match_1 then + Result := Match_1; + end; +end; + +function TntCombo_AutoSelect(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; Items: TTntStrings; + const SearchText: WideString; UniqueMatchOnly: Boolean; UseDataEntryCase: Boolean): Boolean; +var + Idx: Integer; + ValueChange: Boolean; +begin + if UniqueMatchOnly then + Idx := TntCombo_FindUniqueString(Combo, -1, SearchText) + else + Idx := TntCombo_FindString(Combo, -1, SearchText); + Result := (Idx <> CB_ERR); + if Result then begin + if TAccessCustomComboBox(Combo).Style = csDropDown then + ValueChange := not WideSameStr(TntControl_GetText(Combo), Items[Idx]) + else + ValueChange := Idx <> Combo.ItemIndex; + {$IFDEF COMPILER_7_UP} + // auto-closeup + if Combo.AutoCloseUp and (Items.IndexOf(SearchText) <> -1) then + Combo.DroppedDown := False; + {$ENDIF} + // select item + Combo.ItemIndex := Idx; + // update edit + if (TAccessCustomComboBox(Combo).Style in [csDropDown, csSimple]) then begin + if UseDataEntryCase then begin + // preserve case of characters as they are entered + TntControl_SetText(Combo, SearchText + Copy(Items[Combo.ItemIndex], Length(SearchText) + 1, MaxInt)); + end else begin + TntControl_SetText(Combo, Items[Idx]); + end; + // select the rest of the string + TntCombo_SetSelStart(Combo, Length(SearchText)); + TntCombo_SetSelLength(Combo, Length(TntControl_GetText(Combo)) - TntCombo_GetSelStart(Combo)); + end; + // notify events + if ValueChange then begin + TAccessCustomComboBox(Combo).Click; + TAccessCustomComboBox(Combo).Select; + end; + end; +end; + +procedure TntCombo_AutoSearchKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var Message: TWMChar; var FFilter: WideString; var FLastTime: Cardinal); +var + Key: WideChar; +begin + if TAccessCustomComboBox(Combo).Style in [csSimple, csDropDown] then + exit; + if not Combo.AutoComplete then + exit; + Key := GetWideCharFromWMCharMsg(Message); + try + case Ord(Key) of + VK_ESCAPE: + exit; + VK_TAB: + if Combo.AutoDropDown and Combo.DroppedDown then + Combo.DroppedDown := False; + VK_BACK: + Delete(FFilter, Length(FFilter), 1); + else begin + if Combo.AutoDropDown and (not Combo.DroppedDown) then + Combo.DroppedDown := True; + // reset FFilter if it's been too long (1.25 sec) { Windows XP is actually 2 seconds! } + if GetTickCount - FLastTime >= 1250 then + FFilter := ''; + FLastTime := GetTickCount; + // if AutoSelect works, remember new FFilter + if TntCombo_AutoSelect(Combo, Items, FFilter + Key, False, True) then begin + FFilter := FFilter + Key; + Key := #0; + end; + end; + end; + finally + SetWideCharForWMCharMsg(Message, Key); + end; +end; + +procedure TntCombo_AutoCompleteKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; + Items: TTntStrings; var Message: TWMChar; + AutoComplete_UniqueMatchOnly, AutoComplete_PreserveDataEntryCase: Boolean); +var + Key: WideChar; + FindText: WideString; +begin + Assert(TAccessCustomComboBox(Combo).Style in [csSimple, csDropDown], 'Internal Error: TntCombo_AutoCompleteKeyPress is only for csSimple and csDropDown style combo boxes.'); + if not Combo.AutoComplete then exit; + Key := GetWideCharFromWMCharMsg(Message); + try + case Ord(Key) of + VK_ESCAPE: + exit; + VK_TAB: + if Combo.AutoDropDown and Combo.DroppedDown then + Combo.DroppedDown := False; + VK_BACK: + exit; + else begin + if Combo.AutoDropDown and (not Combo.DroppedDown) then + TntCombo_DropDown_PreserveSelection(Combo); + // AutoComplete only if the selection is at the very end + if ((TntCombo_GetSelStart(Combo) + TntCombo_GetSelLength(Combo)) + = Length(TntControl_GetText(Combo))) then + begin + FindText := Copy(TntControl_GetText(Combo), 1, TntCombo_GetSelStart(Combo)) + Key; + if TntCombo_AutoSelect(Combo, Items, FindText, AutoComplete_UniqueMatchOnly, AutoComplete_PreserveDataEntryCase) then + begin + Key := #0; + end; + end; + end; + end; + finally + SetWideCharForWMCharMsg(Message, Key); + end; +end; + +//-- +constructor TTntCustomComboBox.Create(AOwner: TComponent); +begin + inherited; + FItems := TTntComboBoxStrings.Create; + TTntComboBoxStrings(FItems).ComboBox := Self; +end; + +destructor TTntCustomComboBox.Destroy; +begin + FreeAndNil(FItems); + FreeAndNil(FSaveItems); + inherited; +end; + +procedure TTntCustomComboBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'COMBOBOX'); +end; + +procedure TTntCustomComboBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomComboBox.CreateWnd; +var + PreInheritedAnsiText: AnsiString; +begin + PreInheritedAnsiText := TAccessCustomComboBox(Self).Text; + inherited; + TntCombo_AfterInherited_CreateWnd(Self, Items, FSaveItems, FSaveItemIndex, PreInheritedAnsiText); +end; + +procedure TTntCustomComboBox.DestroyWnd; +var + SavedText: WideString; +begin + if not (csDestroyingHandle in ControlState) then begin { avoid recursion when parent is TToolBar and system font changes. } + TntCombo_BeforeInherited_DestroyWnd(Self, Items, FSaveItems, ItemIndex, FSaveItemIndex, SavedText); + inherited; + TntControl_SetStoredText(Self, SavedText); + end; +end; + +procedure TTntCustomComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); +begin + if not TntCombo_ComboWndProc(Self, Message, ComboWnd, ComboProc, DoEditCharMsg) then + inherited; +end; + +procedure TTntCustomComboBox.KeyPress(var Key: AnsiChar); +var + SaveAutoComplete: Boolean; +begin + TntCombo_BeforeKeyPress(Self, SaveAutoComplete); + try + inherited; + finally + TntCombo_AfterKeyPress(Self, SaveAutoComplete); + end; +end; + +procedure TTntCustomComboBox.DoEditCharMsg(var Message: TWMChar); +begin + TntCombo_AutoCompleteKeyPress(Self, Items, Message, + GetAutoComplete_UniqueMatchOnly, GetAutoComplete_PreserveDataEntryCase); +end; + +procedure TTntCustomComboBox.WMChar(var Message: TWMChar); +begin + TntCombo_AutoSearchKeyPress(Self, Items, Message, FFilter, FLastTime); + if Message.CharCode <> 0 then + inherited; +end; + +procedure TntCombo_DefaultDrawItem(Canvas: TCanvas; Index: Integer; Rect: TRect; + State: TOwnerDrawState; Items: TTntStrings); +begin + Canvas.FillRect(Rect); + if Index >= 0 then + WideCanvasTextOut(Canvas, Rect.Left + 2, Rect.Top, Items[Index]); +end; + +procedure TTntCustomComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); +begin + TControlCanvas(Canvas).UpdateTextFlags; + if Assigned(OnDrawItem) then + OnDrawItem(Self, Index, Rect, State) + else + TntCombo_DefaultDrawItem(Canvas, Index, Rect, State, Items); +end; + +function TTntCustomComboBox.GetItems: TTntStrings; +begin + Result := FItems; +end; + +procedure TTntCustomComboBox.SetItems(const Value: TTntStrings); +begin + FItems.Assign(Value); +end; + +function TTntCustomComboBox.GetSelStart: Integer; +begin + Result := TntCombo_GetSelStart(Self); +end; + +procedure TTntCustomComboBox.SetSelStart(const Value: Integer); +begin + TntCombo_SetSelStart(Self, Value); +end; + +function TTntCustomComboBox.GetSelLength: Integer; +begin + Result := TntCombo_GetSelLength(Self); +end; + +procedure TTntCustomComboBox.SetSelLength(const Value: Integer); +begin + TntCombo_SetSelLength(Self, Value); +end; + +function TTntCustomComboBox.GetSelText: WideString; +begin + Result := TntCombo_GetSelText(Self); +end; + +procedure TTntCustomComboBox.SetSelText(const Value: WideString); +begin + TntCombo_SetSelText(Self, Value); +end; + +function TTntCustomComboBox.GetText: WideString; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomComboBox.SetText(const Value: WideString); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomComboBox.CNCommand(var Message: TWMCommand); +begin + if not TntCombo_CNCommand(Self, Items, Message) then + inherited; +end; + +function TTntCustomComboBox.GetAutoComplete_PreserveDataEntryCase: Boolean; +begin + Result := True; +end; + +function TTntCustomComboBox.GetAutoComplete_UniqueMatchOnly: Boolean; +begin + Result := False; +end; + +function TTntCustomComboBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomComboBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomComboBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomComboBox.AddItem(const Item: WideString; AObject: TObject); +begin + TntComboBox_AddItem(Items, Item, AObject); +end; + +procedure TTntCustomComboBox.CopySelection(Destination: TCustomListControl); +begin + TntComboBox_CopySelection(Items, ItemIndex, Destination); +end; + +procedure TTntCustomComboBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomComboBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{$IFDEF DELPHI_7} // fix for Delphi 7 only +function TTntCustomComboBox.GetItemsClass: TCustomComboBoxStringsClass; +begin + Result := TD7PatchedComboBoxStrings; +end; +{$ENDIF} + +{ TTntListBoxStrings } + +function TTntListBoxStrings.GetListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; +begin + Result := TCustomListBox{TNT-ALLOW TCustomListBox}(FListBox); +end; + +procedure TTntListBoxStrings.SetListBox(const Value: TCustomListBox{TNT-ALLOW TCustomListBox}); +begin + FListBox := TAccessCustomListBox(Value); +end; + +function TTntListBoxStrings.GetCount: Integer; +begin + Result := ListBox.Items.Count; +end; + +function TTntListBoxStrings.Get(Index: Integer): WideString; +var + Len: Integer; +begin + if (not IsWindowUnicode(ListBox.Handle)) then + Result := ListBox.Items[Index] + else begin + Len := SendMessageW(ListBox.Handle, LB_GETTEXTLEN, Index, 0); + if Len = LB_ERR then + Error(SListIndexError, Index) + else begin + SetLength(Result, Len + 1); + Len := SendMessageW(ListBox.Handle, LB_GETTEXT, Index, Longint(PWideChar(Result))); + if Len = LB_ERR then + Result := '' + else + Result := PWideChar(Result); + end; + end; +end; + +function TTntListBoxStrings.GetObject(Index: Integer): TObject; +begin + Result := ListBox.Items.Objects[Index]; +end; + +procedure TTntListBoxStrings.Put(Index: Integer; const S: WideString); +var + I: Integer; + TempData: Longint; +begin + I := ListBox.ItemIndex; + TempData := FListBox.InternalGetItemData(Index); + // Set the Item to 0 in case it is an object that gets freed during Delete + FListBox.InternalSetItemData(Index, 0); + Delete(Index); + InsertObject(Index, S, nil); + FListBox.InternalSetItemData(Index, TempData); + ListBox.ItemIndex := I; +end; + +procedure TTntListBoxStrings.PutObject(Index: Integer; AObject: TObject); +begin + ListBox.Items.Objects[Index] := AObject; +end; + +function TTntListBoxStrings.Add(const S: WideString): Integer; +begin + if (not IsWindowUnicode(ListBox.Handle)) then + Result := ListBox.Items.Add(S) + else begin + Result := SendMessageW(ListBox.Handle, LB_ADDSTRING, 0, Longint(PWideChar(S))); + if Result < 0 then + raise EOutOfResources.Create(SInsertLineError); + end; +end; + +procedure TTntListBoxStrings.Insert(Index: Integer; const S: WideString); +begin + if (not IsWindowUnicode(ListBox.Handle)) then + ListBox.Items.Insert(Index, S) + else begin + if SendMessageW(ListBox.Handle, LB_INSERTSTRING, Index, Longint(PWideChar(S))) < 0 then + raise EOutOfResources.Create(SInsertLineError); + end; +end; + +procedure TTntListBoxStrings.Delete(Index: Integer); +begin + FListBox.DeleteString(Index); +end; + +procedure TTntListBoxStrings.Exchange(Index1, Index2: Integer); +var + TempData: Longint; + TempString: WideString; +begin + BeginUpdate; + try + TempString := Strings[Index1]; + TempData := FListBox.InternalGetItemData(Index1); + Strings[Index1] := Strings[Index2]; + FListBox.InternalSetItemData(Index1, FListBox.InternalGetItemData(Index2)); + Strings[Index2] := TempString; + FListBox.InternalSetItemData(Index2, TempData); + if ListBox.ItemIndex = Index1 then + ListBox.ItemIndex := Index2 + else if ListBox.ItemIndex = Index2 then + ListBox.ItemIndex := Index1; + finally + EndUpdate; + end; +end; + +procedure TTntListBoxStrings.Clear; +begin + FListBox.ResetContent; +end; + +procedure TTntListBoxStrings.SetUpdateState(Updating: Boolean); +begin + TAccessStrings(ListBox.Items).SetUpdateState(Updating); +end; + +function TTntListBoxStrings.IndexOf(const S: WideString): Integer; +begin + if (not IsWindowUnicode(ListBox.Handle)) then + Result := ListBox.Items.IndexOf(S) + else + Result := SendMessageW(ListBox.Handle, LB_FINDSTRINGEXACT, -1, LongInt(PWideChar(S))); +end; + +procedure TTntListBoxStrings.Move(CurIndex, NewIndex: Integer); +var + TempData: Longint; + TempString: WideString; +begin + BeginUpdate; + FListBox.FMoving := True; + try + if CurIndex <> NewIndex then + begin + TempString := Get(CurIndex); + TempData := FListBox.InternalGetItemData(CurIndex); + FListBox.InternalSetItemData(CurIndex, 0); + Delete(CurIndex); + Insert(NewIndex, TempString); + FListBox.InternalSetItemData(NewIndex, TempData); + end; + finally + FListBox.FMoving := False; + EndUpdate; + end; +end; + +//-- list box helper procs + +procedure TntListBox_AfterInherited_CreateWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + var FSaveItems: TTntStrings; FItems: TTntStrings; FSaveTopIndex, FSaveItemIndex: Integer); +begin + if FSaveItems <> nil then + begin + FItems.Assign(FSaveItems); + FreeAndNil(FSaveItems); + ListBox.TopIndex := FSaveTopIndex; + ListBox.ItemIndex := FSaveItemIndex; + end; +end; + +procedure TntListBox_BeforeInherited_DestroyWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; + var FSaveItems: TTntStrings; const FItems: TTntStrings; var FSaveTopIndex, FSaveItemIndex: Integer); +begin + if (FItems.Count > 0) + and (not (TAccessCustomListBox(ListBox).Style in [lbVirtual, lbVirtualOwnerDraw])) + then begin + FSaveItems := TTntStringList.Create; + FSaveItems.Assign(FItems); + FSaveTopIndex := ListBox.TopIndex; + FSaveItemIndex := ListBox.ItemIndex; + ListBox.Items.Clear; { This keeps TCustomListBox from creating its own FSaveItems. (this kills the original ItemIndex) } + end; +end; + +procedure TntListBox_DrawItem_Text(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; Items: TTntStrings; Index: Integer; Rect: TRect); +var + Flags: Integer; + Canvas: TCanvas; +begin + Canvas := TAccessCustomListBox(ListBox).Canvas; + Canvas.FillRect(Rect); + if Index < Items.Count then + begin + Flags := ListBox.DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX); + if not ListBox.UseRightToLeftAlignment then + Inc(Rect.Left, 2) + else + Dec(Rect.Right, 2); + Tnt_DrawTextW(Canvas.Handle, PWideChar(Items[Index]), Length(Items[Index]), Rect, Flags); + end; +end; + +procedure TntListBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); +begin + Items.AddObject(PWideChar(Item), AObject); +end; + +procedure TntListBox_CopySelection(ListBox: TCustomListbox{TNT-ALLOW TCustomListbox}; + Items: TTntStrings; Destination: TCustomListControl); +var + I: Integer; +begin + if ListBox.MultiSelect then + begin + for I := 0 to Items.Count - 1 do + if ListBox.Selected[I] then + WideListControl_AddItem(Destination, PWideChar(Items[I]), Items.Objects[I]); + end + else + if Listbox.ItemIndex <> -1 then + WideListControl_AddItem(Destination, PWideChar(Items[ListBox.ItemIndex]), Items.Objects[ListBox.ItemIndex]); +end; + +function TntCustomListBox_GetOwnerData(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; Index: Integer; out Data: WideString): Boolean; +var + AnsiData: AnsiString; +begin + Result := False; + Data := ''; + if (Index > -1) and (Index < ListBox.Count) then begin + if Assigned(OnData) then begin + OnData(ListBox, Index, Data); + Result := True; + end else if Assigned(TAccessCustomListBox(ListBox).OnData) then begin + AnsiData := ''; + TAccessCustomListBox(ListBox).OnData(ListBox, Index, AnsiData); + Data := AnsiData; + Result := True; + end; + end; +end; + +function TntCustomListBox_LBGetText(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; +var + S: WideString; + AnsiS: AnsiString; +begin + if TAccessCustomListBox(ListBox).Style in [lbVirtual, lbVirtualOwnerDraw] then + begin + Result := True; + if TntCustomListBox_GetOwnerData(ListBox, OnData, Message.WParam, S) then begin + if Win32PlatformIsUnicode then begin + WStrCopy(PWideChar(Message.LParam), PWideChar(S)); + Message.Result := Length(S); + end else begin + AnsiS := S; + StrCopy{TNT-ALLOW StrCopy}(PAnsiChar(Message.LParam), PAnsiChar(AnsiS)); + Message.Result := Length(AnsiS); + end; + end + else + Message.Result := LB_ERR; + end + else + Result := False; +end; + +function TntCustomListBox_LBGetTextLen(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; +var + S: WideString; +begin + if TAccessCustomListBox(ListBox).Style in [lbVirtual, lbVirtualOwnerDraw] then + begin + Result := True; + if TntCustomListBox_GetOwnerData(ListBox, OnData, Message.WParam, S) then begin + if Win32PlatformIsUnicode then + Message.Result := Length(S) + else + Message.Result := Length(AnsiString(S)); + end else + Message.Result := LB_ERR; + end + else + Result := False; +end; + +{ TTntCustomListBox } + +constructor TTntCustomListBox.Create(AOwner: TComponent); +begin + inherited; + FItems := TTntListBoxStrings.Create; + TTntListBoxStrings(FItems).ListBox := Self; +end; + +destructor TTntCustomListBox.Destroy; +begin + FreeAndNil(FItems); + FreeAndNil(FSaveItems); + inherited; +end; + +procedure TTntCustomListBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'LISTBOX'); +end; + +procedure TTntCustomListBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomListBox.CreateWnd; +begin + inherited; + TntListBox_AfterInherited_CreateWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); +end; + +procedure TTntCustomListBox.DestroyWnd; +begin + TntListBox_BeforeInherited_DestroyWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); + inherited; +end; + +procedure TTntCustomListBox.SetItems(const Value: TTntStrings); +begin + FItems.Assign(Value); +end; + +procedure TTntCustomListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); +begin + if Assigned(OnDrawItem) then + OnDrawItem(Self, Index, Rect, State) + else + TntListBox_DrawItem_Text(Self, Items, Index, Rect); +end; + +function TTntCustomListBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomListBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomListBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomListBox.AddItem(const Item: WideString; AObject: TObject); +begin + TntListBox_AddItem(Items, Item, AObject); +end; + +procedure TTntCustomListBox.CopySelection(Destination: TCustomListControl); +begin + TntListBox_CopySelection(Self, Items, Destination); +end; + +procedure TTntCustomListBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomListBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntCustomListBox.LBGetText(var Message: TMessage); +begin + if not TntCustomListBox_LBGetText(Self, OnData, Message) then + inherited; +end; + +procedure TTntCustomListBox.LBGetTextLen(var Message: TMessage); +begin + if not TntCustomListBox_LBGetTextLen(Self, OnData, Message) then + inherited; +end; + +// --- label helper procs + +type TAccessCustomLabel = class(TCustomLabel{TNT-ALLOW TCustomLabel}); + +function TntLabel_DoDrawText(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Rect: TRect; Flags: Integer; const GetLabelText: WideString): Boolean; +{$IFDEF COMPILER_9_UP} +const + EllipsisStr = '...'; + Ellipsis: array[TEllipsisPosition] of Longint = (0, DT_PATH_ELLIPSIS, + DT_END_ELLIPSIS, DT_WORD_ELLIPSIS); +{$ENDIF} +var + Text: WideString; + ShowAccelChar: Boolean; + Canvas: TCanvas; + {$IFDEF COMPILER_9_UP} + DText: WideString; + NewRect: TRect; + Height: Integer; + Delim: Integer; + {$ENDIF} +begin + Result := False; + if Win32PlatformIsUnicode then begin + Result := True; + Text := GetLabelText; + ShowAccelChar := TAccessCustomLabel(Control).ShowAccelChar; + Canvas := Control.Canvas; + if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and + (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' '; + if not ShowAccelChar then Flags := Flags or DT_NOPREFIX; + Flags := Control.DrawTextBiDiModeFlags(Flags); + Canvas.Font := TAccessCustomLabel(Control).Font; + {$IFDEF COMPILER_9_UP} + if (TAccessCustomLabel(Control).EllipsisPosition <> epNone) + and (not TAccessCustomLabel(Control).AutoSize) then + begin + DText := Text; + Flags := Flags and not (DT_EXPANDTABS or DT_CALCRECT); + Flags := Flags or Ellipsis[TAccessCustomLabel(Control).EllipsisPosition]; + if TAccessCustomLabel(Control).WordWrap + and (TAccessCustomLabel(Control).EllipsisPosition in [epEndEllipsis, epWordEllipsis]) then + begin + repeat + NewRect := Rect; + Dec(NewRect.Right, WideCanvasTextWidth(Canvas, EllipsisStr)); + Tnt_DrawTextW(Canvas.Handle, PWideChar(DText), Length(DText), NewRect, Flags or DT_CALCRECT); + Height := NewRect.Bottom - NewRect.Top; + if (Height > TAccessCustomLabel(Control).ClientHeight) + and (Height > Canvas.Font.Height) then + begin + Delim := WideLastDelimiter(' '#9, Text); + if Delim = 0 then + Delim := Length(Text); + Dec(Delim); + Text := Copy(Text, 1, Delim); + DText := Text + EllipsisStr; + if Text = '' then + Break; + end else + Break; + until False; + end; + if Text <> '' then + Text := DText; + end; + {$ENDIF} + if not Control.Enabled then + begin + OffsetRect(Rect, 1, 1); + Canvas.Font.Color := clBtnHighlight; + Tnt_DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Flags); + OffsetRect(Rect, -1, -1); + Canvas.Font.Color := clBtnShadow; + Tnt_DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Flags); + end + else + Tnt_DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Flags); + end; +end; + +procedure TntLabel_CMDialogChar(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Message: TCMDialogChar; const Caption: WideString); +var + FocusControl: TWinControl; + ShowAccelChar: Boolean; +begin + FocusControl := TAccessCustomLabel(Control).FocusControl; + ShowAccelChar := TAccessCustomLabel(Control).ShowAccelChar; + if (FocusControl <> nil) and Control.Enabled and ShowAccelChar and + IsWideCharAccel(Message.CharCode, Caption) then + with FocusControl do + if CanFocus then + begin + SetFocus; + Message.Result := 1; + end; +end; + +{ TTntCustomLabel } + +procedure TTntCustomLabel.CMDialogChar(var Message: TCMDialogChar); +begin + TntLabel_CMDialogChar(Self, Message, Caption); +end; + +function TTntCustomLabel.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntCustomLabel.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self); +end; + +procedure TTntCustomLabel.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomLabel.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomLabel.GetLabelText: WideString; +begin + Result := Caption; +end; + +procedure TTntCustomLabel.DoDrawText(var Rect: TRect; Flags: Integer); +begin + if not TntLabel_DoDrawText(Self, Rect, Flags, GetLabelText) then + inherited; +end; + +function TTntCustomLabel.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomLabel.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomLabel.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomLabel.CMHintShow(var Message: TMessage); +begin + ProcessCMHintShowMsg(Message); + inherited; +end; + +procedure TTntCustomLabel.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomLabel.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntButton } + +procedure TntButton_CMDialogChar(Button: TButton{TNT-ALLOW TButton}; var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(Message.CharCode, TntControl_GetText(Button)) + and Button.CanFocus then + begin + Button.Click; + Result := 1; + end else + Button.Broadcast(Message); +end; + +procedure TTntButton.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntButton.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntButton.CMDialogChar(var Message: TCMDialogChar); +begin + TntButton_CMDialogChar(Self, Message); +end; + +function TTntButton.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntButton.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntButton.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntButton.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntButton.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntButton.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntButton.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomCheckBox } + +procedure TTntCustomCheckBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntCustomCheckBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomCheckBox.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(Message.CharCode, Caption) + and CanFocus then + begin + SetFocus; + if Focused then Toggle; + Result := 1; + end else + Broadcast(Message); +end; + +function TTntCustomCheckBox.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +function TTntCustomCheckBox.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomCheckBox.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntCustomCheckBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomCheckBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomCheckBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomCheckBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomCheckBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntRadioButton } + +procedure TTntRadioButton.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'BUTTON'); +end; + +procedure TTntRadioButton.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntRadioButton.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(Message.CharCode, Caption) + and CanFocus then + begin + SetFocus; + Result := 1; + end else + Broadcast(Message); +end; + +function TTntRadioButton.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntRadioButton.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntRadioButton.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntRadioButton.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntRadioButton.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntRadioButton.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntRadioButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntRadioButton.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntScrollBar } + +procedure TTntScrollBar.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'SCROLLBAR'); +end; + +procedure TTntScrollBar.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntScrollBar.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntScrollBar.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntScrollBar.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntScrollBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntScrollBar.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomGroupBox } + +procedure TTntCustomGroupBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomGroupBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomGroupBox.CMDialogChar(var Message: TCMDialogChar); +begin + with Message do + if IsWideCharAccel(Message.CharCode, Caption) + and CanFocus then + begin + SelectFirst; + Result := 1; + end else + Broadcast(Message); +end; + +function TTntCustomGroupBox.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntCustomGroupBox.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomGroupBox.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +procedure TTntCustomGroupBox.Paint; + + {$IFDEF THEME_7_UP} + procedure PaintThemedGroupBox; + var + CaptionRect: TRect; + OuterRect: TRect; + Size: TSize; + Box: TThemedButton; + Details: TThemedElementDetails; + begin + with Canvas do begin + if Caption <> '' then + begin + GetTextExtentPoint32W(Handle, PWideChar(Caption), Length(Caption), Size); + CaptionRect := Rect(0, 0, Size.cx, Size.cy); + if not UseRightToLeftAlignment then + OffsetRect(CaptionRect, 8, 0) + else + OffsetRect(CaptionRect, Width - 8 - CaptionRect.Right, 0); + end + else + CaptionRect := Rect(0, 0, 0, 0); + + OuterRect := ClientRect; + OuterRect.Top := (CaptionRect.Bottom - CaptionRect.Top) div 2; + with CaptionRect do + ExcludeClipRect(Handle, Left, Top, Right, Bottom); + if Enabled then + Box := tbGroupBoxNormal + else + Box := tbGroupBoxDisabled; + Details := ThemeServices.GetElementDetails(Box); + ThemeServices.DrawElement(Handle, Details, OuterRect); + + SelectClipRgn(Handle, 0); + if Text <> '' then + ThemeServices.DrawText{TNT-ALLOW DrawText}(Handle, Details, Caption, CaptionRect, DT_LEFT, 0); + end; + end; + {$ENDIF} + + procedure PaintGroupBox; + var + H: Integer; + R: TRect; + Flags: Longint; + begin + with Canvas do begin + H := WideCanvasTextHeight(Canvas, '0'); + R := Rect(0, H div 2 - 1, Width, Height); + if Ctl3D then + begin + Inc(R.Left); + Inc(R.Top); + Brush.Color := clBtnHighlight; + FrameRect(R); + OffsetRect(R, -1, -1); + Brush.Color := clBtnShadow; + end else + Brush.Color := clWindowFrame; + FrameRect(R); + if Caption <> '' then + begin + if not UseRightToLeftAlignment then + R := Rect(8, 0, 0, H) + else + R := Rect(R.Right - WideCanvasTextWidth(Canvas, Caption) - 8, 0, 0, H); + Flags := DrawTextBiDiModeFlags(DT_SINGLELINE); + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), R, Flags or DT_CALCRECT); + Brush.Color := Color; + Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), R, Flags); + end; + end; + end; + +begin + if (not Win32PlatformIsUnicode) then + inherited + else + begin + Canvas.Font := Self.Font; + {$IFDEF THEME_7_UP} + if ThemeServices.ThemesEnabled then + PaintThemedGroupBox + else + PaintGroupBox; + {$ELSE} + PaintGroupBox; + {$ENDIF} + end; +end; + +function TTntCustomGroupBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomGroupBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomGroupBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomGroupBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomGroupBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntCustomStaticText } + +constructor TTntCustomStaticText.Create(AOwner: TComponent); +begin + inherited; + AdjustBounds; +end; + +procedure TTntCustomStaticText.CMFontChanged(var Message: TMessage); +begin + inherited; + AdjustBounds; +end; + +procedure TTntCustomStaticText.CMTextChanged(var Message: TMessage); +begin + inherited; + AdjustBounds; +end; + +procedure TTntCustomStaticText.Loaded; +begin + inherited; + AdjustBounds; +end; + +procedure TTntCustomStaticText.SetAutoSize(AValue: boolean); +begin + inherited; + if AValue then + AdjustBounds; +end; + +procedure TTntCustomStaticText.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'STATIC'); +end; + +procedure TTntCustomStaticText.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntCustomStaticText.CMDialogChar(var Message: TCMDialogChar); +begin + if (FocusControl <> nil) and Enabled and ShowAccelChar and + IsWideCharAccel(Message.CharCode, Caption) then + with FocusControl do + if CanFocus then + begin + SetFocus; + Message.Result := 1; + end; +end; + +function TTntCustomStaticText.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self) +end; + +procedure TTntCustomStaticText.AdjustBounds; +var + DC: HDC; + SaveFont: HFont; + TextSize: TSize; +begin + if not (csReading in ComponentState) and AutoSize then + begin + DC := GetDC(0); + SaveFont := SelectObject(DC, Font.Handle); + GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), TextSize); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + SetBounds(Left, Top, + TextSize.cx + (GetSystemMetrics(SM_CXBORDER) * 4), + TextSize.cy + (GetSystemMetrics(SM_CYBORDER) * 4)); + end; +end; + +function TTntCustomStaticText.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntCustomStaticText.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value); +end; + +function TTntCustomStaticText.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self) +end; + +function TTntCustomStaticText.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntCustomStaticText.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomStaticText.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomStaticText.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +end. diff --git a/Source/TntSysUtils.pas b/Source/TntSysUtils.pas new file mode 100644 index 0000000..6feaf4c --- /dev/null +++ b/Source/TntSysUtils.pas @@ -0,0 +1,1883 @@ + +{*****************************************************************************} +{ } +{ 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 + WideException = class(Exception) + private + FMessage: WideString; + procedure SetMessage(const Value: WideString); + public + constructor Create(const Msg: WideString); + constructor CreateFmt(const Msg: WideString; const Args: array of const); + constructor CreateRes(Ident: Integer); overload; + constructor CreateRes(ResStringRec: PResStringRec); overload; + constructor CreateResFmt(Ident: Integer; const Args: array of const); overload; + constructor CreateResFmt(ResStringRec: PResStringRec; const Args: array of const); overload; + constructor CreateHelp(const Msg: WideString; AHelpContext: Integer); + constructor CreateFmtHelp(const Msg: WideString; const Args: array of const; + AHelpContext: Integer); + constructor CreateResHelp(Ident: Integer; AHelpContext: Integer); overload; + constructor CreateResHelp(ResStringRec: PResStringRec; AHelpContext: Integer); overload; + constructor CreateResFmtHelp(ResStringRec: PResStringRec; const Args: array of const; + AHelpContext: Integer); overload; + constructor CreateResFmtHelp(Ident: Integer; const Args: array of const; + AHelpContext: Integer); overload; + property Message: WideString read FMessage write SetMessage; + end; + + EWideOSError = class(WideException) + public + ErrorCode: DWORD; + end; + + // 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} + +function WideLoadStr(Ident: Integer): WideString; +function WideFmtLoadStr(Ident: Integer; const Args: array of const): WideString; + +{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; +procedure WideRaiseLastOSError; + +// ......... 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 - Types +//--------------------------------------------------------------------------------------------- + +{ WideException } + +constructor WideException.Create(const Msg: WideString); +begin + FMessage := Msg; + inherited Message := FMessage; +end; + +constructor WideException.CreateFmt(const Msg: WideString; + const Args: array of const); +begin + FMessage := WideFormat(Msg, Args); + inherited Message := FMessage; +end; + +constructor WideException.CreateRes(Ident: Integer); +begin + FMessage := WideLoadStr(Ident); + inherited Message := FMessage; +end; + +constructor WideException.CreateRes(ResStringRec: PResStringRec); +begin + FMessage := WideLoadResString(ResStringRec); + inherited Message := FMessage; +end; + +constructor WideException.CreateResFmt(Ident: Integer; + const Args: array of const); +begin + FMessage := WideFormat(WideLoadStr(Ident), Args); + inherited Message := FMessage; +end; + +constructor WideException.CreateResFmt(ResStringRec: PResStringRec; + const Args: array of const); +begin + FMessage := WideFormat(WideLoadResString(ResStringRec), Args); + inherited Message := FMessage; +end; + +constructor WideException.CreateHelp(const Msg: WideString; + AHelpContext: Integer); +begin + FMessage := Msg; + inherited Message := FMessage; + inherited HelpContext := AHelpContext; +end; + +constructor WideException.CreateFmtHelp(const Msg: WideString; + const Args: array of const; AHelpContext: Integer); +begin + FMessage := WideFormat(Msg, Args); + inherited Message := FMessage; + inherited HelpContext := AHelpContext; +end; + +constructor WideException.CreateResHelp(Ident: Integer; AHelpContext: Integer); +begin + FMessage := WideLoadStr(Ident); + inherited Message := FMessage; + inherited HelpContext := AHelpContext; +end; + +constructor WideException.CreateResHelp(ResStringRec: PResStringRec; + AHelpContext: Integer); +begin + FMessage := WideLoadResString(ResStringRec); + inherited Message := FMessage; + inherited HelpContext := AHelpContext; +end; + +constructor WideException.CreateResFmtHelp(Ident: Integer; + const Args: array of const; AHelpContext: Integer); +begin + FMessage := WideFormat(WideLoadStr(Ident), Args); + inherited Message := FMessage; + inherited HelpContext := AHelpContext; +end; + +constructor WideException.CreateResFmtHelp(ResStringRec: PResStringRec; + const Args: array of const; AHelpContext: Integer); +begin + FMessage := WideFormat(WideLoadResString(ResStringRec), Args); + inherited Message := FMessage; + inherited HelpContext := AHelpContext; +end; + +procedure WideException.SetMessage(const Value: WideString); +begin + FMessage := Value; + inherited Message := FMessage; +end; + +//--------------------------------------------------------------------------------------------- +// 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} + +type + PWStrData = ^TWStrData; + TWStrData = record + Ident: Integer; + Str: WideString; + end; + +function EnumStringModules(Instance: Longint; Data: Pointer): Boolean; +var + ResStringRec: TResStringRec; +begin + with PWStrData(Data)^ do + begin + ResStringRec.Module^ := Instance; + ResStringRec.Identifier := Ident; + Str := WideLoadResString(@ResStringRec); + Result := Str = ''; + end; +end; + +function WideFindStringResource(Ident: Integer): WideString; +var + StrData: TWStrData; +begin + StrData.Ident := Ident; + StrData.Str := ''; + EnumResourceModules(EnumStringModules, @StrData); + Result := StrData.Str; +end; + +function WideLoadStr(Ident: Integer): WideString; +begin + Result := WideFindStringResource(Ident); +end; + +function WideFmtLoadStr(Ident: Integer; const Args: array of const): WideString; +begin + WideFmtStr(Result, WideFindStringResource(Ident), Args); +end; + +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; + +procedure WideRaiseLastOSError; +var + LastError: Integer; + Error: EWideOSError; +begin + LastError := GetLastError; + if LastError <> 0 then + Error := EWideOSError.Create(WideSysErrorMessage(LastError)) + else + Error := EWideOSError.CreateRes(PResStringRec(@SUnkOSError)); + Error.ErrorCode := LastError; + raise Error; +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/Source/TntSystem.pas b/Source/TntSystem.pas new file mode 100644 index 0000000..196c0a4 --- /dev/null +++ b/Source/TntSystem.pas @@ -0,0 +1,1397 @@ + +{*****************************************************************************} +{ } +{ 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} + tsWideExceptions + ); + TTntSystemUpdateSet = set of TTntSystemUpdate; + +const + AllTntSystemUpdates = [Low(TTntSystemUpdate)..High(TTntSystemUpdate)]; + +procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); + +implementation + +uses + SysUtils, Variants, Forms, TntWindows, TntSysUtils, TntForms; + +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} + Forms_TApplication_ShowException_Code, + SysUtils_RaiseLastOsError_Code: 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 InstallWideExceptions; +begin + OverwriteProcedure(@Forms.TApplication.ShowException, @TTntApplication.ShowException, @Forms_TApplication_ShowException_Code); + OverwriteProcedure(@SysUtils.RaiseLastOsError, @TntSysUtils.WideRaiseLastOsError, @SysUtils_RaiseLastOsError_Code); +end; + +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} + if tsWideExceptions in Updates then begin + InstallWideExceptions + end; +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} + // Wide exception + RestoreProcedure(@Forms.TApplication.ShowException, Forms_TApplication_ShowException_Code); + RestoreProcedure(@SysUtils.RaiseLastOsError, SysUtils_RaiseLastOsError_Code); +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/Source/TntWideStrUtils.pas b/Source/TntWideStrUtils.pas new file mode 100644 index 0000000..02a64bb --- /dev/null +++ b/Source/TntWideStrUtils.pas @@ -0,0 +1,451 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntWideStrUtils; + +{$INCLUDE TntCompilers.inc} + +interface + +{ Wide string manipulation functions } + +{$IFNDEF COMPILER_9_UP} +function WStrAlloc(Size: Cardinal): PWideChar; +function WStrBufSize(const Str: PWideChar): Cardinal; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_9_UP} +function WStrNew(const Str: PWideChar): PWideChar; +procedure WStrDispose(Str: PWideChar); +{$ENDIF} +//--------------------------------------------------------------------------------------------- +{$IFNDEF COMPILER_9_UP} +function WStrLen(Str: PWideChar): Cardinal; +function WStrEnd(Str: PWideChar): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_9_UP} +function WStrCopy(Dest, Source: PWideChar): PWideChar; +function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; +function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; +function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; +// WStrComp and WStrPos were introduced as broken in Delphi 2006, but fixed in Delphi 2006 Update 2 +function WStrComp(Str1, Str2: PWideChar): Integer; +function WStrPos(Str, SubStr: PWideChar): PWideChar; +{$ENDIF} +function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; +function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; + +{ ------------ introduced --------------- } +function WStrECopy(Dest, Source: PWideChar): PWideChar; +function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +function WStrIComp(Str1, Str2: PWideChar): Integer; +function WStrLower(Str: PWideChar): PWideChar; +function WStrUpper(Str: PWideChar): PWideChar; +function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; +function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; +function WStrPas(const Str: PWideChar): WideString; + +{ SysUtils.pas } //------------------------------------------------------------------------- + +{$IFNDEF COMPILER_10_UP} +function WideLastChar(const S: WideString): PWideChar; +function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; +{$ENDIF} +{$IFNDEF COMPILER_9_UP} +function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; +{$ENDIF} +{$IFNDEF COMPILER_10_UP} +function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; +{$ENDIF} + +implementation + +uses + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} Math, Windows, TntWindows; + +{$IFNDEF COMPILER_9_UP} +function WStrAlloc(Size: Cardinal): PWideChar; +begin + Size := SizeOf(Cardinal) + (Size * SizeOf(WideChar)); + GetMem(Result, Size); + PCardinal(Result)^ := Size; + Inc(PAnsiChar(Result), SizeOf(Cardinal)); +end; + +function WStrBufSize(const Str: PWideChar): Cardinal; +var + P: PWideChar; +begin + P := Str; + Dec(PAnsiChar(P), SizeOf(Cardinal)); + Result := PCardinal(P)^ - SizeOf(Cardinal); + Result := Result div SizeOf(WideChar); +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; +var + Length: Integer; +begin + Result := Dest; + Length := Count * SizeOf(WideChar); + Move(Source^, Dest^, Length); +end; +{$ENDIF} + +{$IFNDEF COMPILER_9_UP} +function WStrNew(const Str: PWideChar): PWideChar; +var + Size: Cardinal; +begin + if Str = nil then Result := nil else + begin + Size := WStrLen(Str) + 1; + Result := WStrMove(WStrAlloc(Size), Str, Size); + end; +end; + +procedure WStrDispose(Str: PWideChar); +begin + if Str <> nil then + begin + Dec(PAnsiChar(Str), SizeOf(Cardinal)); + FreeMem(Str, Cardinal(Pointer(Str)^)); + end; +end; +{$ENDIF} + +//--------------------------------------------------------------------------------------------- + +{$IFNDEF COMPILER_9_UP} +function WStrLen(Str: PWideChar): Cardinal; +begin + Result := WStrEnd(Str) - Str; +end; + +function WStrEnd(Str: PWideChar): PWideChar; +begin + // returns a pointer to the end of a null terminated string + Result := Str; + While Result^ <> #0 do + Inc(Result); +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; +begin + Result := Dest; + WStrCopy(WStrEnd(Dest), Source); +end; +{$ENDIF} + +{$IFNDEF COMPILER_9_UP} +function WStrCopy(Dest, Source: PWideChar): PWideChar; +begin + Result := WStrLCopy(Dest, Source, MaxInt); +end; + +function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; +var + Count: Cardinal; +begin + // copies a specified maximum number of characters from Source to Dest + Result := Dest; + Count := 0; + While (Count < MaxLen) and (Source^ <> #0) do begin + Dest^ := Source^; + Inc(Source); + Inc(Dest); + Inc(Count); + end; + Dest^ := #0; +end; + +function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; +begin + Result := WStrLCopy(Dest, PWideChar(Source), Length(Source)); +end; + +function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; +begin + Result := WStrLCopy(Dest, PWideChar(Source), MaxLen); +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; +begin + Result := Str; + while Result^ <> Chr do + begin + if Result^ = #0 then + begin + Result := nil; + Exit; + end; + Inc(Result); + end; +end; + +function WStrComp(Str1, Str2: PWideChar): Integer; +begin + Result := WStrLComp(Str1, Str2, MaxInt); +end; + +function WStrPos(Str, SubStr: PWideChar): PWideChar; +var + PSave: PWideChar; + P: PWideChar; + PSub: PWideChar; +begin + // returns a pointer to the first occurance of SubStr in Str + Result := nil; + if (Str <> nil) and (Str^ <> #0) and (SubStr <> nil) and (SubStr^ <> #0) then begin + P := Str; + While P^ <> #0 do begin + if P^ = SubStr^ then begin + // investigate possibility here + PSave := P; + PSub := SubStr; + While (P^ = PSub^) do begin + Inc(P); + Inc(PSub); + if (PSub^ = #0) then begin + Result := PSave; + exit; // found a match + end; + if (P^ = #0) then + exit; // no match, hit end of string + end; + P := PSave; + end; + Inc(P); + end; + end; +end; +{$ENDIF} + +function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; +begin + Result := WStrComp(Str1, Str2); +end; + +function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; +begin + Result := WStrPos(Str, SubStr); +end; + +//------------------------------------------------------------------------------ + +function WStrECopy(Dest, Source: PWideChar): PWideChar; +begin + Result := WStrEnd(WStrCopy(Dest, Source)); +end; + +function WStrComp_EX(Str1, Str2: PWideChar; MaxLen: Cardinal; dwCmpFlags: Cardinal): Integer; +var + Len1, Len2: Integer; +begin + if MaxLen = Cardinal(MaxInt) then begin + Len1 := -1; + Len2 := -1; + end else begin + Len1 := Min(WStrLen(Str1), MaxLen); + Len2 := Min(WStrLen(Str2), MaxLen); + end; + Result := Tnt_CompareStringW(GetThreadLocale, dwCmpFlags, Str1, Len1, Str2, Len2) - 2; +end; + +function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +begin + Result := WStrComp_EX(Str1, Str2, MaxLen, 0); +end; + +function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; +begin + Result := WStrComp_EX(Str1, Str2, MaxLen, NORM_IGNORECASE); +end; + +function WStrIComp(Str1, Str2: PWideChar): Integer; +begin + Result := WStrLIComp(Str1, Str2, MaxInt); +end; + +function WStrLower(Str: PWideChar): PWideChar; +begin + Result := Str; + Tnt_CharLowerBuffW(Str, WStrLen(Str)) +end; + +function WStrUpper(Str: PWideChar): PWideChar; +begin + Result := Str; + Tnt_CharUpperBuffW(Str, WStrLen(Str)) +end; + +function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; +var + MostRecentFound: PWideChar; +begin + if Chr = #0 then + Result := WStrEnd(Str) + else + begin + Result := nil; + MostRecentFound := Str; + while True do + begin + while MostRecentFound^ <> Chr do + begin + if MostRecentFound^ = #0 then + Exit; + Inc(MostRecentFound); + end; + Result := MostRecentFound; + Inc(MostRecentFound); + end; + end; +end; + +function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; +begin + Result := Dest; + WStrLCopy(WStrEnd(Dest), Source, MaxLen - WStrLen(Dest)); +end; + +function WStrPas(const Str: PWideChar): WideString; +begin + Result := Str; +end; + +//--------------------------------------------------------------------------------------------- + +{$IFNDEF COMPILER_10_UP} +function WideLastChar(const S: WideString): PWideChar; +begin + if S = '' then + Result := nil + else + Result := @S[Length(S)]; +end; + +function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; +var + P, Src, + Dest: PWideChar; + AddCount: Integer; +begin + AddCount := 0; + P := WStrScan(PWideChar(S), Quote); + while (P <> nil) do + begin + Inc(P); + Inc(AddCount); + P := WStrScan(P, Quote); + end; + + if AddCount = 0 then + Result := Quote + S + Quote + else + begin + SetLength(Result, Length(S) + AddCount + 2); + Dest := PWideChar(Result); + Dest^ := Quote; + Inc(Dest); + Src := PWideChar(S); + P := WStrScan(Src, Quote); + repeat + Inc(P); + Move(Src^, Dest^, 2 * (P - Src)); + Inc(Dest, P - Src); + Dest^ := Quote; + Inc(Dest); + Src := P; + P := WStrScan(Src, Quote); + until P = nil; + P := WStrEnd(Src); + Move(Src^, Dest^, 2 * (P - Src)); + Inc(Dest, P - Src); + Dest^ := Quote; + end; +end; +{$ENDIF} + +{$IFNDEF COMPILER_9_UP} +function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; +var + P, Dest: PWideChar; + DropCount: Integer; +begin + Result := ''; + if (Src = nil) or (Src^ <> Quote) then Exit; + Inc(Src); + DropCount := 1; + P := Src; + Src := WStrScan(Src, Quote); + while Src <> nil do // count adjacent pairs of quote chars + begin + Inc(Src); + if Src^ <> Quote then Break; + Inc(Src); + Inc(DropCount); + Src := WStrScan(Src, Quote); + end; + if Src = nil then Src := WStrEnd(P); + if ((Src - P) <= 1) then Exit; + if DropCount = 1 then + SetString(Result, P, Src - P - 1) + else + begin + SetLength(Result, Src - P - DropCount); + Dest := PWideChar(Result); + Src := WStrScan(P, Quote); + while Src <> nil do + begin + Inc(Src); + if Src^ <> Quote then Break; + Move(P^, Dest^, (Src - P) * SizeOf(WideChar)); + Inc(Dest, Src - P); + Inc(Src); + P := Src; + Src := WStrScan(Src, Quote); + end; + if Src = nil then Src := WStrEnd(P); + Move(P^, Dest^, (Src - P - 1) * SizeOf(WideChar)); + end; +end; +{$ENDIF} + +{$IFNDEF COMPILER_10_UP} +function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; +var + LText : PWideChar; +begin + LText := PWideChar(S); + Result := WideExtractQuotedStr(LText, AQuote); + if Result = '' then + Result := S; +end; +{$ENDIF} + + +end. diff --git a/Source/TntWideStrings.pas b/Source/TntWideStrings.pas new file mode 100644 index 0000000..dfe3755 --- /dev/null +++ b/Source/TntWideStrings.pas @@ -0,0 +1,831 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntWideStrings; + +{$INCLUDE TntCompilers.inc} + +interface + +{$IFDEF COMPILER_10_UP} + {$MESSAGE FATAL 'Do not refer to TntWideStrings.pas. It works correctly in Delphi 2006.'} +{$ENDIF} + +uses + Classes; + +{******************************************************************************} +{ } +{ Delphi 2005 introduced TWideStrings in WideStrings.pas. } +{ Unfortunately, it was not ready for prime time. } +{ Setting CommaText is not consistent, and it relies on CharNextW } +{ Which is only available on Windows NT+. } +{ } +{******************************************************************************} + +type + TWideStrings = class; + +{ IWideStringsAdapter interface } +{ Maintains link between TWideStrings and IWideStrings implementations } + + IWideStringsAdapter = interface + ['{25FE0E3B-66CB-48AA-B23B-BCFA67E8F5DA}'] + procedure ReferenceStrings(S: TWideStrings); + procedure ReleaseStrings; + end; + + TWideStringsEnumerator = class + private + FIndex: Integer; + FStrings: TWideStrings; + public + constructor Create(AStrings: TWideStrings); + function GetCurrent: WideString; + function MoveNext: Boolean; + property Current: WideString read GetCurrent; + end; + +{ TWideStrings class } + + TWideStrings = class(TPersistent) + private + FDefined: TStringsDefined; + FDelimiter: WideChar; + FQuoteChar: WideChar; + {$IFDEF COMPILER_7_UP} + FNameValueSeparator: WideChar; + {$ENDIF} + FUpdateCount: Integer; + FAdapter: IWideStringsAdapter; + function GetCommaText: WideString; + function GetDelimitedText: WideString; + function GetName(Index: Integer): WideString; + function GetValue(const Name: WideString): WideString; + procedure ReadData(Reader: TReader); + procedure SetCommaText(const Value: WideString); + procedure SetDelimitedText(const Value: WideString); + procedure SetStringsAdapter(const Value: IWideStringsAdapter); + procedure SetValue(const Name, Value: WideString); + procedure WriteData(Writer: TWriter); + function GetDelimiter: WideChar; + procedure SetDelimiter(const Value: WideChar); + function GetQuoteChar: WideChar; + procedure SetQuoteChar(const Value: WideChar); + function GetNameValueSeparator: WideChar; + {$IFDEF COMPILER_7_UP} + procedure SetNameValueSeparator(const Value: WideChar); + {$ENDIF} + function GetValueFromIndex(Index: Integer): WideString; + procedure SetValueFromIndex(Index: Integer; const Value: WideString); + protected + procedure AssignTo(Dest: TPersistent); override; + procedure DefineProperties(Filer: TFiler); override; + procedure Error(const Msg: WideString; Data: Integer); overload; + procedure Error(Msg: PResStringRec; Data: Integer); overload; + function ExtractName(const S: WideString): WideString; + function Get(Index: Integer): WideString; virtual; abstract; + function GetCapacity: Integer; virtual; + function GetCount: Integer; virtual; abstract; + function GetObject(Index: Integer): TObject; virtual; + function GetTextStr: WideString; virtual; + procedure Put(Index: Integer; const S: WideString); virtual; + procedure PutObject(Index: Integer; AObject: TObject); virtual; + procedure SetCapacity(NewCapacity: Integer); virtual; + procedure SetTextStr(const Value: WideString); virtual; + procedure SetUpdateState(Updating: Boolean); virtual; + property UpdateCount: Integer read FUpdateCount; + function CompareStrings(const S1, S2: WideString): Integer; virtual; + public + destructor Destroy; override; + function Add(const S: WideString): Integer; virtual; + function AddObject(const S: WideString; AObject: TObject): Integer; virtual; + procedure Append(const S: WideString); + procedure AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); overload; virtual; + procedure AddStrings(Strings: TWideStrings); overload; virtual; + procedure Assign(Source: TPersistent); override; + procedure BeginUpdate; + procedure Clear; virtual; abstract; + procedure Delete(Index: Integer); virtual; abstract; + procedure EndUpdate; + function Equals(Strings: TWideStrings): Boolean; + procedure Exchange(Index1, Index2: Integer); virtual; + function GetEnumerator: TWideStringsEnumerator; + function GetTextW: PWideChar; virtual; + function IndexOf(const S: WideString): Integer; virtual; + function IndexOfName(const Name: WideString): Integer; virtual; + function IndexOfObject(AObject: TObject): Integer; virtual; + procedure Insert(Index: Integer; const S: WideString); virtual; abstract; + procedure InsertObject(Index: Integer; const S: WideString; + AObject: TObject); virtual; + procedure LoadFromFile(const FileName: WideString); virtual; + procedure LoadFromStream(Stream: TStream); virtual; + procedure Move(CurIndex, NewIndex: Integer); virtual; + procedure SaveToFile(const FileName: WideString); virtual; + procedure SaveToStream(Stream: TStream); virtual; + procedure SetTextW(const Text: PWideChar); virtual; + property Capacity: Integer read GetCapacity write SetCapacity; + property CommaText: WideString read GetCommaText write SetCommaText; + property Count: Integer read GetCount; + property Delimiter: WideChar read GetDelimiter write SetDelimiter; + property DelimitedText: WideString read GetDelimitedText write SetDelimitedText; + property Names[Index: Integer]: WideString read GetName; + property Objects[Index: Integer]: TObject read GetObject write PutObject; + property QuoteChar: WideChar read GetQuoteChar write SetQuoteChar; + property Values[const Name: WideString]: WideString read GetValue write SetValue; + property ValueFromIndex[Index: Integer]: WideString read GetValueFromIndex write SetValueFromIndex; + property NameValueSeparator: WideChar read GetNameValueSeparator {$IFDEF COMPILER_7_UP} write SetNameValueSeparator {$ENDIF}; + property Strings[Index: Integer]: WideString read Get write Put; default; + property Text: WideString read GetTextStr write SetTextStr; + property StringsAdapter: IWideStringsAdapter read FAdapter write SetStringsAdapter; + end; + + PWideStringItem = ^TWideStringItem; + TWideStringItem = record + FString: WideString; + FObject: TObject; + end; + + PWideStringItemList = ^TWideStringItemList; + TWideStringItemList = array[0..MaxListSize] of TWideStringItem; + +implementation + +uses + Windows, SysUtils, TntSystem, {$IFDEF COMPILER_9_UP} WideStrUtils, {$ELSE} TntWideStrUtils, {$ENDIF} + TntSysUtils, TntClasses; + +{ TWideStringsEnumerator } + +constructor TWideStringsEnumerator.Create(AStrings: TWideStrings); +begin + inherited Create; + FIndex := -1; + FStrings := AStrings; +end; + +function TWideStringsEnumerator.GetCurrent: WideString; +begin + Result := FStrings[FIndex]; +end; + +function TWideStringsEnumerator.MoveNext: Boolean; +begin + Result := FIndex < FStrings.Count - 1; + if Result then + Inc(FIndex); +end; + +{ TWideStrings } + +destructor TWideStrings.Destroy; +begin + StringsAdapter := nil; + inherited; +end; + +function TWideStrings.Add(const S: WideString): Integer; +begin + Result := GetCount; + Insert(Result, S); +end; + +function TWideStrings.AddObject(const S: WideString; AObject: TObject): Integer; +begin + Result := Add(S); + PutObject(Result, AObject); +end; + +procedure TWideStrings.Append(const S: WideString); +begin + Add(S); +end; + +procedure TWideStrings.AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); +var + I: Integer; +begin + BeginUpdate; + try + for I := 0 to Strings.Count - 1 do + AddObject(Strings[I], Strings.Objects[I]); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.AddStrings(Strings: TWideStrings); +var + I: Integer; +begin + BeginUpdate; + try + for I := 0 to Strings.Count - 1 do + AddObject(Strings[I], Strings.Objects[I]); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.Assign(Source: TPersistent); +begin + if Source is TWideStrings then + begin + BeginUpdate; + try + Clear; + FDefined := TWideStrings(Source).FDefined; + {$IFDEF COMPILER_7_UP} + FNameValueSeparator := TWideStrings(Source).FNameValueSeparator; + {$ENDIF} + FQuoteChar := TWideStrings(Source).FQuoteChar; + FDelimiter := TWideStrings(Source).FDelimiter; + AddStrings(TWideStrings(Source)); + finally + EndUpdate; + end; + end + else if Source is TStrings{TNT-ALLOW TStrings} then + begin + BeginUpdate; + try + Clear; + {$IFDEF COMPILER_7_UP} + FNameValueSeparator := WideChar(TStrings{TNT-ALLOW TStrings}(Source).NameValueSeparator); + {$ENDIF} + FQuoteChar := WideChar(TStrings{TNT-ALLOW TStrings}(Source).QuoteChar); + FDelimiter := WideChar(TStrings{TNT-ALLOW TStrings}(Source).Delimiter); + AddStrings(TStrings{TNT-ALLOW TStrings}(Source)); + finally + EndUpdate; + end; + end + else + inherited Assign(Source); +end; + +procedure TWideStrings.AssignTo(Dest: TPersistent); +var + I: Integer; +begin + if Dest is TWideStrings then Dest.Assign(Self) + else if Dest is TStrings{TNT-ALLOW TStrings} then + begin + TStrings{TNT-ALLOW TStrings}(Dest).BeginUpdate; + try + TStrings{TNT-ALLOW TStrings}(Dest).Clear; + {$IFDEF COMPILER_7_UP} + TStrings{TNT-ALLOW TStrings}(Dest).NameValueSeparator := AnsiChar(NameValueSeparator); + {$ENDIF} + TStrings{TNT-ALLOW TStrings}(Dest).QuoteChar := AnsiChar(QuoteChar); + TStrings{TNT-ALLOW TStrings}(Dest).Delimiter := AnsiChar(Delimiter); + for I := 0 to Count - 1 do + TStrings{TNT-ALLOW TStrings}(Dest).AddObject(Strings[I], Objects[I]); + finally + TStrings{TNT-ALLOW TStrings}(Dest).EndUpdate; + end; + end + else + inherited AssignTo(Dest); +end; + +procedure TWideStrings.BeginUpdate; +begin + if FUpdateCount = 0 then SetUpdateState(True); + Inc(FUpdateCount); +end; + +procedure TWideStrings.DefineProperties(Filer: TFiler); + + function DoWrite: Boolean; + begin + if Filer.Ancestor <> nil then + begin + Result := True; + if Filer.Ancestor is TWideStrings then + Result := not Equals(TWideStrings(Filer.Ancestor)) + end + else Result := Count > 0; + end; + +begin + Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite); +end; + +procedure TWideStrings.EndUpdate; +begin + Dec(FUpdateCount); + if FUpdateCount = 0 then SetUpdateState(False); +end; + +function TWideStrings.Equals(Strings: TWideStrings): Boolean; +var + I, Count: Integer; +begin + Result := False; + Count := GetCount; + if Count <> Strings.GetCount then Exit; + for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit; + Result := True; +end; + +procedure TWideStrings.Error(const Msg: WideString; Data: Integer); + + function ReturnAddr: Pointer; + asm + MOV EAX,[EBP+4] + end; + +begin + raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr; +end; + +procedure TWideStrings.Error(Msg: PResStringRec; Data: Integer); +begin + Error(WideLoadResString(Msg), Data); +end; + +procedure TWideStrings.Exchange(Index1, Index2: Integer); +var + TempObject: TObject; + TempString: WideString; +begin + BeginUpdate; + try + TempString := Strings[Index1]; + TempObject := Objects[Index1]; + Strings[Index1] := Strings[Index2]; + Objects[Index1] := Objects[Index2]; + Strings[Index2] := TempString; + Objects[Index2] := TempObject; + finally + EndUpdate; + end; +end; + +function TWideStrings.ExtractName(const S: WideString): WideString; +var + P: Integer; +begin + Result := S; + P := Pos(NameValueSeparator, Result); + if P <> 0 then + SetLength(Result, P-1) else + SetLength(Result, 0); +end; + +function TWideStrings.GetCapacity: Integer; +begin // descendents may optionally override/replace this default implementation + Result := Count; +end; + +function TWideStrings.GetCommaText: WideString; +var + LOldDefined: TStringsDefined; + LOldDelimiter: WideChar; + LOldQuoteChar: WideChar; +begin + LOldDefined := FDefined; + LOldDelimiter := FDelimiter; + LOldQuoteChar := FQuoteChar; + Delimiter := ','; + QuoteChar := '"'; + try + Result := GetDelimitedText; + finally + FDelimiter := LOldDelimiter; + FQuoteChar := LOldQuoteChar; + FDefined := LOldDefined; + end; +end; + +function TWideStrings.GetDelimitedText: WideString; +var + S: WideString; + P: PWideChar; + I, Count: Integer; +begin + Count := GetCount; + if (Count = 1) and (Get(0) = '') then + Result := WideString(QuoteChar) + QuoteChar + else + begin + Result := ''; + for I := 0 to Count - 1 do + begin + S := Get(I); + P := PWideChar(S); + while not ((P^ in [WideChar(#0)..WideChar(' ')]) or (P^ = QuoteChar) or (P^ = Delimiter)) do + Inc(P); + if (P^ <> #0) then S := WideQuotedStr(S, QuoteChar); + Result := Result + S + Delimiter; + end; + System.Delete(Result, Length(Result), 1); + end; +end; + +function TWideStrings.GetName(Index: Integer): WideString; +begin + Result := ExtractName(Get(Index)); +end; + +function TWideStrings.GetObject(Index: Integer): TObject; +begin + Result := nil; +end; + +function TWideStrings.GetEnumerator: TWideStringsEnumerator; +begin + Result := TWideStringsEnumerator.Create(Self); +end; + +function TWideStrings.GetTextW: PWideChar; +begin + Result := WStrNew(PWideChar(GetTextStr)); +end; + +function TWideStrings.GetTextStr: WideString; +var + I, L, Size, Count: Integer; + P: PWideChar; + S, LB: WideString; +begin + Count := GetCount; + Size := 0; + LB := sLineBreak; + for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + Length(LB)); + SetString(Result, nil, Size); + P := Pointer(Result); + for I := 0 to Count - 1 do + begin + S := Get(I); + L := Length(S); + if L <> 0 then + begin + System.Move(Pointer(S)^, P^, L * SizeOf(WideChar)); + Inc(P, L); + end; + L := Length(LB); + if L <> 0 then + begin + System.Move(Pointer(LB)^, P^, L * SizeOf(WideChar)); + Inc(P, L); + end; + end; +end; + +function TWideStrings.GetValue(const Name: WideString): WideString; +var + I: Integer; +begin + I := IndexOfName(Name); + if I >= 0 then + Result := Copy(Get(I), Length(Name) + 2, MaxInt) else + Result := ''; +end; + +function TWideStrings.IndexOf(const S: WideString): Integer; +begin + for Result := 0 to GetCount - 1 do + if CompareStrings(Get(Result), S) = 0 then Exit; + Result := -1; +end; + +function TWideStrings.IndexOfName(const Name: WideString): Integer; +var + P: Integer; + S: WideString; +begin + for Result := 0 to GetCount - 1 do + begin + S := Get(Result); + P := Pos(NameValueSeparator, S); + if (P <> 0) and (CompareStrings(Copy(S, 1, P - 1), Name) = 0) then Exit; + end; + Result := -1; +end; + +function TWideStrings.IndexOfObject(AObject: TObject): Integer; +begin + for Result := 0 to GetCount - 1 do + if GetObject(Result) = AObject then Exit; + Result := -1; +end; + +procedure TWideStrings.InsertObject(Index: Integer; const S: WideString; + AObject: TObject); +begin + Insert(Index, S); + PutObject(Index, AObject); +end; + +procedure TWideStrings.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TWideStrings.LoadFromStream(Stream: TStream); +var + Size: Integer; + S: WideString; +begin + BeginUpdate; + try + Size := Stream.Size - Stream.Position; + SetString(S, nil, Size div SizeOf(WideChar)); + Stream.Read(Pointer(S)^, Length(S) * SizeOf(WideChar)); + SetTextStr(S); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.Move(CurIndex, NewIndex: Integer); +var + TempObject: TObject; + TempString: WideString; +begin + if CurIndex <> NewIndex then + begin + BeginUpdate; + try + TempString := Get(CurIndex); + TempObject := GetObject(CurIndex); + Delete(CurIndex); + InsertObject(NewIndex, TempString, TempObject); + finally + EndUpdate; + end; + end; +end; + +procedure TWideStrings.Put(Index: Integer; const S: WideString); +var + TempObject: TObject; +begin + TempObject := GetObject(Index); + Delete(Index); + InsertObject(Index, S, TempObject); +end; + +procedure TWideStrings.PutObject(Index: Integer; AObject: TObject); +begin +end; + +procedure TWideStrings.ReadData(Reader: TReader); +begin + if Reader.NextValue in [vaString, vaLString] then + SetTextStr(Reader.ReadString) {JCL compatiblity} + else if Reader.NextValue = vaWString then + SetTextStr(Reader.ReadWideString) {JCL compatiblity} + else begin + BeginUpdate; + try + Clear; + Reader.ReadListBegin; + while not Reader.EndOfList do + if Reader.NextValue in [vaString, vaLString] then + Add(Reader.ReadString) {TStrings compatiblity} + else + Add(Reader.ReadWideString); + Reader.ReadListEnd; + finally + EndUpdate; + end; + end; +end; + +procedure TWideStrings.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TWideStrings.SaveToStream(Stream: TStream); +var + SW: WideString; +begin + SW := GetTextStr; + Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); +end; + +procedure TWideStrings.SetCapacity(NewCapacity: Integer); +begin + // do nothing - descendents may optionally implement this method +end; + +procedure TWideStrings.SetCommaText(const Value: WideString); +begin + Delimiter := ','; + QuoteChar := '"'; + SetDelimitedText(Value); +end; + +procedure TWideStrings.SetStringsAdapter(const Value: IWideStringsAdapter); +begin + if FAdapter <> nil then FAdapter.ReleaseStrings; + FAdapter := Value; + if FAdapter <> nil then FAdapter.ReferenceStrings(Self); +end; + +procedure TWideStrings.SetTextW(const Text: PWideChar); +begin + SetTextStr(Text); +end; + +procedure TWideStrings.SetTextStr(const Value: WideString); +var + P, Start: PWideChar; + S: WideString; +begin + BeginUpdate; + try + Clear; + P := Pointer(Value); + if P <> nil then + while P^ <> #0 do + begin + Start := P; + while not (P^ in [WideChar(#0), WideChar(#10), WideChar(#13)]) and (P^ <> WideLineSeparator) do + Inc(P); + SetString(S, Start, P - Start); + Add(S); + if P^ = #13 then Inc(P); + if P^ = #10 then Inc(P); + if P^ = WideLineSeparator then Inc(P); + end; + finally + EndUpdate; + end; +end; + +procedure TWideStrings.SetUpdateState(Updating: Boolean); +begin +end; + +procedure TWideStrings.SetValue(const Name, Value: WideString); +var + I: Integer; +begin + I := IndexOfName(Name); + if Value <> '' then + begin + if I < 0 then I := Add(''); + Put(I, Name + NameValueSeparator + Value); + end else + begin + if I >= 0 then Delete(I); + end; +end; + +procedure TWideStrings.WriteData(Writer: TWriter); +var + I: Integer; +begin + Writer.WriteListBegin; + for I := 0 to Count-1 do begin + Writer.WriteWideString(Get(I)); + end; + Writer.WriteListEnd; +end; + +procedure TWideStrings.SetDelimitedText(const Value: WideString); +var + P, P1: PWideChar; + S: WideString; +begin + BeginUpdate; + try + Clear; + P := PWideChar(Value); + while P^ in [WideChar(#1)..WideChar(' ')] do + Inc(P); + while P^ <> #0 do + begin + if P^ = QuoteChar then + S := WideExtractQuotedStr(P, QuoteChar) + else + begin + P1 := P; + while (P^ > ' ') and (P^ <> Delimiter) do + Inc(P); + SetString(S, P1, P - P1); + end; + Add(S); + while P^ in [WideChar(#1)..WideChar(' ')] do + Inc(P); + if P^ = Delimiter then + begin + P1 := P; + Inc(P1); + if P1^ = #0 then + Add(''); + repeat + Inc(P); + until not (P^ in [WideChar(#1)..WideChar(' ')]); + end; + end; + finally + EndUpdate; + end; +end; + +function TWideStrings.GetDelimiter: WideChar; +begin + if not (sdDelimiter in FDefined) then + Delimiter := ','; + Result := FDelimiter; +end; + +function TWideStrings.GetQuoteChar: WideChar; +begin + if not (sdQuoteChar in FDefined) then + QuoteChar := '"'; + Result := FQuoteChar; +end; + +procedure TWideStrings.SetDelimiter(const Value: WideChar); +begin + if (FDelimiter <> Value) or not (sdDelimiter in FDefined) then + begin + Include(FDefined, sdDelimiter); + FDelimiter := Value; + end +end; + +procedure TWideStrings.SetQuoteChar(const Value: WideChar); +begin + if (FQuoteChar <> Value) or not (sdQuoteChar in FDefined) then + begin + Include(FDefined, sdQuoteChar); + FQuoteChar := Value; + end +end; + +function TWideStrings.CompareStrings(const S1, S2: WideString): Integer; +begin + Result := WideCompareText(S1, S2); +end; + +function TWideStrings.GetNameValueSeparator: WideChar; +begin + {$IFDEF COMPILER_7_UP} + if not (sdNameValueSeparator in FDefined) then + NameValueSeparator := '='; + Result := FNameValueSeparator; + {$ELSE} + Result := '='; + {$ENDIF} +end; + +{$IFDEF COMPILER_7_UP} +procedure TWideStrings.SetNameValueSeparator(const Value: WideChar); +begin + if (FNameValueSeparator <> Value) or not (sdNameValueSeparator in FDefined) then + begin + Include(FDefined, sdNameValueSeparator); + FNameValueSeparator := Value; + end +end; +{$ENDIF} + +function TWideStrings.GetValueFromIndex(Index: Integer): WideString; +begin + if Index >= 0 then + Result := Copy(Get(Index), Length(Names[Index]) + 2, MaxInt) else + Result := ''; +end; + +procedure TWideStrings.SetValueFromIndex(Index: Integer; const Value: WideString); +begin + if Value <> '' then + begin + if Index < 0 then Index := Add(''); + Put(Index, Names[Index] + NameValueSeparator + Value); + end + else + if Index >= 0 then Delete(Index); +end; + +end. diff --git a/Source/TntWindows.pas b/Source/TntWindows.pas new file mode 100644 index 0000000..12d74d8 --- /dev/null +++ b/Source/TntWindows.pas @@ -0,0 +1,1452 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntWindows; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Windows, ShellApi, ShlObj; + +// ......... compatibility + +const + DT_NOFULLWIDTHCHARBREAK = $00080000; + +const + INVALID_FILE_ATTRIBUTES = DWORD(-1); + +// ................ ANSI TYPES ................ +{TNT-WARN LPSTR} +{TNT-WARN PLPSTR} +{TNT-WARN LPCSTR} +{TNT-WARN LPCTSTR} +{TNT-WARN LPTSTR} + +// ........ EnumResourceTypesW, EnumResourceNamesW and EnumResourceLanguagesW are supposed .... +// ........ to work on Win95/98/ME but have caused access violations in testing on Win95 ...... +// .. TNT--WARN EnumResourceTypes .. +// .. TNT--WARN EnumResourceTypesA .. +// .. TNT--WARN EnumResourceNames .. +// .. TNT--WARN EnumResourceNamesA .. +// .. TNT--WARN EnumResourceLanguages .. +// .. TNT--WARN EnumResourceLanguagesA .. + +//------------------------------------------------------------------------------------------ + +// ......... The Unicode form of these functions are supported on Windows 95/98/ME ......... +{TNT-WARN ExtTextOut} +{TNT-WARN ExtTextOutA} +{TNT-WARN Tnt_ExtTextOutW} + +{TNT-WARN FindResource} +{TNT-WARN FindResourceA} +{TNT-WARN Tnt_FindResourceW} + +{TNT-WARN FindResourceEx} +{TNT-WARN FindResourceExA} +{TNT-WARN Tnt_FindResourceExW} + +{TNT-WARN GetCharWidth} +{TNT-WARN GetCharWidthA} +{TNT-WARN Tnt_GetCharWidthW} + +{TNT-WARN GetCommandLine} +{TNT-WARN GetCommandLineA} +{TNT-WARN Tnt_GetCommandLineW} + +{TNT-WARN GetTextExtentPoint} +{TNT-WARN GetTextExtentPointA} +{TNT-WARN Tnt_GetTextExtentPointW} + +{TNT-WARN GetTextExtentPoint32} +{TNT-WARN GetTextExtentPoint32A} +{TNT-WARN Tnt_GetTextExtentPoint32W} + +{TNT-WARN lstrcat} +{TNT-WARN lstrcatA} +{TNT-WARN Tnt_lstrcatW} + +{TNT-WARN lstrcpy} +{TNT-WARN lstrcpyA} +{TNT-WARN Tnt_lstrcpyW} + +{TNT-WARN lstrlen} +{TNT-WARN lstrlenA} +{TNT-WARN Tnt_lstrlenW} + +{TNT-WARN MessageBox} +{TNT-WARN MessageBoxA} +{TNT-WARN Tnt_MessageBoxW} + +{TNT-WARN MessageBoxEx} +{TNT-WARN MessageBoxExA} +{TNT-WARN Tnt_MessageBoxExA} + +{TNT-WARN TextOut} +{TNT-WARN TextOutA} +{TNT-WARN Tnt_TextOutW} + +//------------------------------------------------------------------------------------------ + +{TNT-WARN LOCALE_USER_DEFAULT} // <-- use GetThreadLocale +{TNT-WARN LOCALE_SYSTEM_DEFAULT} // <-- use GetThreadLocale + +//------------------------------------------------------------------------------------------ +// compatiblity +//------------------------------------------------------------------------------------------ +{$IFNDEF COMPILER_9_UP} +type + TStartupInfoA = _STARTUPINFOA; + TStartupInfoW = record + cb: DWORD; + lpReserved: PWideChar; + lpDesktop: PWideChar; + lpTitle: PWideChar; + dwX: DWORD; + dwY: DWORD; + dwXSize: DWORD; + dwYSize: DWORD; + dwXCountChars: DWORD; + dwYCountChars: DWORD; + dwFillAttribute: DWORD; + dwFlags: DWORD; + wShowWindow: Word; + cbReserved2: Word; + lpReserved2: PByte; + hStdInput: THandle; + hStdOutput: THandle; + hStdError: THandle; + end; + +function CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName: PWideChar; lpCommandLine: PWideChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; + var lpProcessInformation: TProcessInformation): BOOL; stdcall; external kernel32 name 'CreateProcessW'; + +{$ENDIF} +//------------------------------------------------------------------------------------------ + +{TNT-WARN SetWindowText} +{TNT-WARN SetWindowTextA} +{TNT-WARN SetWindowTextW} +function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; + +{TNT-WARN RemoveDirectory} +{TNT-WARN RemoveDirectoryA} +{TNT-WARN RemoveDirectoryW} +function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; + +{TNT-WARN GetShortPathName} +{TNT-WARN GetShortPathNameA} +{TNT-WARN GetShortPathNameW} +function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; + cchBuffer: DWORD): DWORD; + +{TNT-WARN GetFullPathName} +{TNT-WARN GetFullPathNameA} +{TNT-WARN GetFullPathNameW} +function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; + lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; + +{TNT-WARN CreateFile} +{TNT-WARN CreateFileA} +{TNT-WARN CreateFileW} +function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; + lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; + hTemplateFile: THandle): THandle; + +{TNT-WARN FindFirstFile} +{TNT-WARN FindFirstFileA} +{TNT-WARN FindFirstFileW} +function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; + +{TNT-WARN FindNextFile} +{TNT-WARN FindNextFileA} +{TNT-WARN FindNextFileW} +function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; + +{TNT-WARN GetFileAttributes} +{TNT-WARN GetFileAttributesA} +{TNT-WARN GetFileAttributesW} +function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; + +{TNT-WARN SetFileAttributes} +{TNT-WARN SetFileAttributesA} +{TNT-WARN SetFileAttributesW} +function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; + +{TNT-WARN CreateDirectory} +{TNT-WARN CreateDirectoryA} +{TNT-WARN CreateDirectoryW} +function Tnt_CreateDirectoryW(lpPathName: PWideChar; + lpSecurityAttributes: PSecurityAttributes): BOOL; + +{TNT-WARN MoveFile} +{TNT-WARN MoveFileA} +{TNT-WARN MoveFileW} +function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; + +{TNT-WARN CopyFile} +{TNT-WARN CopyFileA} +{TNT-WARN CopyFileW} +function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; + +{TNT-WARN DeleteFile} +{TNT-WARN DeleteFileA} +{TNT-WARN DeleteFileW} +function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; + +{TNT-WARN DrawText} +{TNT-WARN DrawTextA} +{TNT-WARN DrawTextW} +function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; + var lpRect: TRect; uFormat: UINT): Integer; + +{TNT-WARN GetDiskFreeSpace} +{TNT-WARN GetDiskFreeSpaceA} +{TNT-WARN GetDiskFreeSpaceW} +function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, + lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; + +{TNT-WARN GetVolumeInformation} +{TNT-WARN GetVolumeInformationA} +{TNT-WARN GetVolumeInformationW} +function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; + nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; + var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; + nFileSystemNameSize: DWORD): BOOL; + +{TNT-WARN GetModuleFileName} +{TNT-WARN GetModuleFileNameA} +{TNT-WARN GetModuleFileNameW} +function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; + +{TNT-WARN GetTempPath} +{TNT-WARN GetTempPathA} +{TNT-WARN GetTempPathW} +function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; + +{TNT-WARN GetTempFileName} +{TNT-WARN GetTempFileNameA} +{TNT-WARN GetTempFileNameW} +function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; + lpTempFileName: PWideChar): UINT; + +{TNT-WARN GetWindowsDirectory} +{TNT-WARN GetWindowsDirectoryA} +{TNT-WARN GetWindowsDirectoryW} +function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; + +{TNT-WARN GetSystemDirectory} +{TNT-WARN GetSystemDirectoryA} +{TNT-WARN GetSystemDirectoryW} +function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; + +{TNT-WARN GetCurrentDirectory} +{TNT-WARN GetCurrentDirectoryA} +{TNT-WARN GetCurrentDirectoryW} +function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; + +{TNT-WARN SetCurrentDirectory} +{TNT-WARN SetCurrentDirectoryA} +{TNT-WARN SetCurrentDirectoryW} +function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; + +{TNT-WARN GetComputerName} +{TNT-WARN GetComputerNameA} +{TNT-WARN GetComputerNameW} +function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; + +{TNT-WARN GetUserName} +{TNT-WARN GetUserNameA} +{TNT-WARN GetUserNameW} +function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; + +{TNT-WARN ShellExecute} +{TNT-WARN ShellExecuteA} +{TNT-WARN ShellExecuteW} +function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, + Directory: PWideChar; ShowCmd: Integer): HINST; + +{TNT-WARN LoadLibrary} +{TNT-WARN LoadLibraryA} +{TNT-WARN LoadLibraryW} +function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; + +{TNT-WARN LoadLibraryEx} +{TNT-WARN LoadLibraryExA} +{TNT-WARN LoadLibraryExW} +function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; + +{TNT-WARN CreateProcess} +{TNT-WARN CreateProcessA} +{TNT-WARN CreateProcessW} +function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; + var lpProcessInformation: TProcessInformation): BOOL; + +{TNT-WARN GetCurrencyFormat} +{TNT-WARN GetCurrencyFormatA} +{TNT-WARN GetCurrencyFormatW} +function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; + lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; + +{TNT-WARN CompareString} +{TNT-WARN CompareStringA} +{TNT-WARN CompareStringW} +function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; + cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; + +{TNT-WARN CharUpper} +{TNT-WARN CharUpperA} +{TNT-WARN CharUpperW} +function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; + +{TNT-WARN CharUpperBuff} +{TNT-WARN CharUpperBuffA} +{TNT-WARN CharUpperBuffW} +function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; + +{TNT-WARN CharLower} +{TNT-WARN CharLowerA} +{TNT-WARN CharLowerW} +function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; + +{TNT-WARN CharLowerBuff} +{TNT-WARN CharLowerBuffA} +{TNT-WARN CharLowerBuffW} +function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; + +{TNT-WARN GetStringTypeEx} +{TNT-WARN GetStringTypeExA} +{TNT-WARN GetStringTypeExW} +function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; + lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; + +{TNT-WARN LoadString} +{TNT-WARN LoadStringA} +{TNT-WARN LoadStringW} +function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; + +{TNT-WARN InsertMenuItem} +{TNT-WARN InsertMenuItemA} +{TNT-WARN InsertMenuItemW} +function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: tagMenuItemINFOW): BOOL; + +{TNT-WARN ExtractIconEx} +{TNT-WARN ExtractIconExA} +{TNT-WARN ExtractIconExW} +function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; + var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; + +{TNT-WARN ExtractAssociatedIcon} +{TNT-WARN ExtractAssociatedIconA} +{TNT-WARN ExtractAssociatedIconW} +function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; + var lpiIcon: Word): HICON; + +{TNT-WARN GetFileVersionInfoSize} +{TNT-WARN GetFileVersionInfoSizeA} +{TNT-WARN GetFileVersionInfoSizeW} +function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; + +{TNT-WARN GetFileVersionInfo} +{TNT-WARN GetFileVersionInfoA} +{TNT-WARN GetFileVersionInfoW} +function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; + lpData: Pointer): BOOL; + +const + VQV_FIXEDFILEINFO = '\'; + VQV_VARFILEINFO_TRANSLATION = '\VarFileInfo\Translation'; + VQV_STRINGFILEINFO = '\StringFileInfo'; + + VER_COMMENTS = 'Comments'; + VER_INTERNALNAME = 'InternalName'; + VER_PRODUCTNAME = 'ProductName'; + VER_COMPANYNAME = 'CompanyName'; + VER_LEGALCOPYRIGHT = 'LegalCopyright'; + VER_PRODUCTVERSION = 'ProductVersion'; + VER_FILEDESCRIPTION = 'FileDescription'; + VER_LEGALTRADEMARKS = 'LegalTrademarks'; + VER_PRIVATEBUILD = 'PrivateBuild'; + VER_FILEVERSION = 'FileVersion'; + VER_ORIGINALFILENAME = 'OriginalFilename'; + VER_SPECIALBUILD = 'SpecialBuild'; + +{TNT-WARN VerQueryValue} +{TNT-WARN VerQueryValueA} +{TNT-WARN VerQueryValueW} +function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; + var lplpBuffer: Pointer; var puLen: UINT): BOOL; + +type + TSHNameMappingHeaderA = record + cNumOfMappings: Cardinal; + lpNM: PSHNAMEMAPPINGA; + end; + PSHNameMappingHeaderA = ^TSHNameMappingHeaderA; + + TSHNameMappingHeaderW = record + cNumOfMappings: Cardinal; + lpNM: PSHNAMEMAPPINGW; + end; + PSHNameMappingHeaderW = ^TSHNameMappingHeaderW; + +{TNT-WARN SHFileOperation} +{TNT-WARN SHFileOperationA} +{TNT-WARN SHFileOperationW} // <-- no stub on early Windows 95 +function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; + +{TNT-WARN SHFreeNameMappings} +procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); + +{TNT-WARN SHBrowseForFolder} +{TNT-WARN SHBrowseForFolderA} +{TNT-WARN SHBrowseForFolderW} // <-- no stub on early Windows 95 +function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; + +{TNT-WARN SHGetPathFromIDList} +{TNT-WARN SHGetPathFromIDListA} +{TNT-WARN SHGetPathFromIDListW} // <-- no stub on early Windows 95 +function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; + +{TNT-WARN SHGetFileInfo} +{TNT-WARN SHGetFileInfoA} +{TNT-WARN SHGetFileInfoW} // <-- no stub on early Windows 95 +function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; + var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; + +// ......... introduced ......... +function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; + +function LANGIDFROMLCID(lcid: LCID): WORD; +function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; +function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; +function PRIMARYLANGID(lgid: WORD): WORD; +function SORTIDFROMLCID(lcid: LCID): WORD; +function SUBLANGID(lgid: WORD): WORD; + +implementation + +uses + SysUtils, Math, TntSysUtils, + {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; + +function _PAnsiCharWithNil(const S: AnsiString): PAnsiChar; +begin + if S = '' then + Result := nil {Win9x needs nil for some parameters instead of empty strings} + else + Result := PAnsiChar(S); +end; + +function _PWideCharWithNil(const S: WideString): PWideChar; +begin + if S = '' then + Result := nil {Win9x needs nil for some parameters instead of empty strings} + else + Result := PWideChar(S); +end; + +function _WStr(lpString: PWideChar; cchCount: Integer): WideString; +begin + if cchCount = -1 then + Result := lpString + else + Result := Copy(WideString(lpString), 1, cchCount); +end; + +procedure _MakeWideWin32FindData(var WideFindData: TWIN32FindDataW; AnsiFindData: TWIN32FindDataA); +begin + CopyMemory(@WideFindData, @AnsiFindData, + Integer(@WideFindData.cFileName) - Integer(@WideFindData)); + WStrPCopy(WideFindData.cFileName, AnsiFindData.cFileName); + WStrPCopy(WideFindData.cAlternateFileName, AnsiFindData.cAlternateFileName); +end; + +function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := SetWindowTextW{TNT-ALLOW SetWindowTextW}(hWnd, lpString) + else + Result := SetWindowTextA{TNT-ALLOW SetWindowTextA}(hWnd, PAnsiChar(AnsiString(lpString))); +end; + +//----------------------------- + +type + TPathLengthResultOption = (poAllowDirectoryMode, poZeroSmallBuff, poExactCopy, poExactCopySubPaths); + TPathLengthResultOptions = set of TPathLengthResultOption; + +procedure _ExactStrCopyW(pDest, pSource: PWideChar; Count: Integer); +var + i: integer; +begin + for i := 1 to Count do begin + pDest^ := pSource^; + Inc(PSource); + Inc(pDest); + end; +end; + +procedure _ExactCopySubPaths(pDest, pSource: PWideChar; Count: Integer); +var + i: integer; + OriginalSource: PWideChar; + PNextSlash: PWideChar; +begin + if Count >= 4 then begin + OriginalSource := pSource; + PNextSlash := WStrScan(pSource, '\'); + for i := 1 to Count - 1 do begin + // determine next path delimiter + if pSource > pNextSlash then begin + PNextSlash := WStrScan(pSource, '\'); + end; + // leave if no more sub paths + if (PNextSlash = nil) + or ((pNextSlash - OriginalSource) >= Count) then begin + exit; + end; + // copy char + pDest^ := pSource^; + Inc(PSource); + Inc(pDest); + end; + end; +end; + +function _HandlePathLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; +var + WideBuff: WideString; +begin + WideBuff := AnsiBuff; + if nBufferLength > Cardinal(Length(WideBuff)) then begin + // normal + Result := Length(WideBuff); + WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); + end else if (poExactCopy in Options) then begin + // exact + Result := nBufferLength; + _ExactStrCopyW(lpBuffer, PWideChar(WideBuff), nBufferLength); + end else begin + // other + if (poAllowDirectoryMode in Options) + and (nBufferLength = Cardinal(Length(WideBuff))) then begin + Result := Length(WideBuff) + 1; + WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength - 1); + end else begin + Result := Length(WideBuff) + 1; + if (nBufferLength > 0) then begin + if (poZeroSmallBuff in Options) then + lpBuffer^ := #0 + else if (poExactCopySubPaths in Options) then + _ExactCopySubPaths(lpBuffer, PWideChar(WideBuff), nBufferLength); + end; + end; + end; +end; + +function _HandleStringLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; +var + WideBuff: WideString; +begin + WideBuff := AnsiBuff; + if nBufferLength >= Cardinal(Length(WideBuff)) then begin + // normal + Result := Length(WideBuff); + WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); + end else if nBufferLength = 0 then + Result := Length(WideBuff) + else + Result := 0; +end; + +//------------------------------------------- + +function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := RemoveDirectoryW{TNT-ALLOW RemoveDirectoryW}(PWideChar(lpPathName)) + else + Result := RemoveDirectoryA{TNT-ALLOW RemoveDirectoryA}(PAnsiChar(AnsiString(lpPathName))); +end; + +function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; + cchBuffer: DWORD): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetShortPathNameW{TNT-ALLOW GetShortPathNameW}(lpszLongPath, lpszShortPath, cchBuffer) + else begin + SetLength(AnsiBuff, MAX_PATH * 2); + SetLength(AnsiBuff, GetShortPathNameA{TNT-ALLOW GetShortPathNameA}(PAnsiChar(AnsiString(lpszLongPath)), + PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(cchBuffer, lpszShortPath, AnsiBuff, [poExactCopySubPaths]); + end; +end; + +function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; + lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; +var + AnsiBuff: AnsiString; + AnsiFilePart: PAnsiChar; + AnsiLeadingChars: Integer; + WideLeadingChars: Integer; +begin + if Win32PlatformIsUnicode then + Result := GetFullPathNameW{TNT-ALLOW GetFullPathNameW}(lpFileName, nBufferLength, lpBuffer, lpFilePart) + else begin + SetLength(AnsiBuff, MAX_PATH * 2); + SetLength(AnsiBuff, GetFullPathNameA{TNT-ALLOW GetFullPathNameA}(PAnsiChar(AnsiString(lpFileName)), + Length(AnsiBuff), PAnsiChar(AnsiBuff), AnsiFilePart)); + Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poZeroSmallBuff]); + // deal w/ lpFilePart + if (AnsiFilePart = nil) or (nBufferLength < Result) then + lpFilePart := nil + else begin + AnsiLeadingChars := AnsiFilePart - PAnsiChar(AnsiBuff); + WideLeadingChars := Length(WideString(Copy(AnsiBuff, 1, AnsiLeadingChars))); + lpFilePart := lpBuffer + WideLeadingChars; + end; + end; +end; + +function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; + lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; + hTemplateFile: THandle): THandle; +begin + if Win32PlatformIsUnicode then + Result := CreateFileW{TNT-ALLOW CreateFileW}(lpFileName, dwDesiredAccess, dwShareMode, + lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) + else + Result := CreateFileA{TNT-ALLOW CreateFileA}(PAnsiChar(AnsiString(lpFileName)), dwDesiredAccess, dwShareMode, + lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) +end; + +function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; +var + Ansi_lpFindFileData: TWIN32FindDataA; +begin + if Win32PlatformIsUnicode then + Result := FindFirstFileW{TNT-ALLOW FindFirstFileW}(lpFileName, lpFindFileData) + else begin + Result := FindFirstFileA{TNT-ALLOW FindFirstFileA}(PAnsiChar(AnsiString(lpFileName)), + Ansi_lpFindFileData); + if Result <> INVALID_HANDLE_VALUE then + _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); + end; +end; + +function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; +var + Ansi_lpFindFileData: TWIN32FindDataA; +begin + if Win32PlatformIsUnicode then + Result := FindNextFileW{TNT-ALLOW FindNextFileW}(hFindFile, lpFindFileData) + else begin + Result := FindNextFileA{TNT-ALLOW FindNextFileA}(hFindFile, Ansi_lpFindFileData); + if Result then + _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); + end; +end; + +function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetFileAttributesW{TNT-ALLOW GetFileAttributesW}(lpFileName) + else + Result := GetFileAttributesA{TNT-ALLOW GetFileAttributesA}(PAnsiChar(AnsiString(lpFileName))); +end; + +function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; +begin + if Win32PlatformIsUnicode then + Result := SetFileAttributesW{TNT-ALLOW SetFileAttributesW}(lpFileName, dwFileAttributes) + else + Result := SetFileAttributesA{TNT-ALLOW SetFileAttributesA}(PAnsiChar(AnsiString(lpFileName)), dwFileAttributes); +end; + +function Tnt_CreateDirectoryW(lpPathName: PWideChar; + lpSecurityAttributes: PSecurityAttributes): BOOL; +begin + if Win32PlatformIsUnicode then + Result := CreateDirectoryW{TNT-ALLOW CreateDirectoryW}(lpPathName, lpSecurityAttributes) + else + Result := CreateDirectoryA{TNT-ALLOW CreateDirectoryA}(PAnsiChar(AnsiString(lpPathName)), lpSecurityAttributes); +end; + +function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := MoveFileW{TNT-ALLOW MoveFileW}(lpExistingFileName, lpNewFileName) + else + Result := MoveFileA{TNT-ALLOW MoveFileA}(PAnsiChar(AnsiString(lpExistingFileName)), PAnsiChar(AnsiString(lpNewFileName))); +end; + +function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; +begin + if Win32PlatformIsUnicode then + Result := CopyFileW{TNT-ALLOW CopyFileW}(lpExistingFileName, lpNewFileName, bFailIfExists) + else + Result := CopyFileA{TNT-ALLOW CopyFileA}(PAnsiChar(AnsiString(lpExistingFileName)), + PAnsiChar(AnsiString(lpNewFileName)), bFailIfExists); +end; + +function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := DeleteFileW{TNT-ALLOW DeleteFileW}(lpFileName) + else + Result := DeleteFileA{TNT-ALLOW DeleteFileA}(PAnsiChar(AnsiString(lpFileName))); +end; + +function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; + var lpRect: TRect; uFormat: UINT): Integer; +begin + if Win32PlatformIsUnicode then + Result := DrawTextW{TNT-ALLOW DrawTextW}(hDC, lpString, nCount, lpRect, uFormat) + else + Result := DrawTextA{TNT-ALLOW DrawTextA}(hDC, + PAnsiChar(AnsiString(_WStr(lpString, nCount))), -1, lpRect, uFormat); +end; + +function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, + lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; +begin + if Win32PlatformIsUnicode then + Result := GetDiskFreeSpaceW{TNT-ALLOW GetDiskFreeSpaceW}(lpRootPathName, + lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) + else + Result := GetDiskFreeSpaceA{TNT-ALLOW GetDiskFreeSpaceA}(PAnsiChar(AnsiString(lpRootPathName)), + lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) +end; + +function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; + nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; + var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; + nFileSystemNameSize: DWORD): BOOL; +var + AnsiFileSystemNameBuffer: AnsiString; + AnsiVolumeNameBuffer: AnsiString; + AnsiBuffLen: DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetVolumeInformationW{TNT-ALLOW GetVolumeInformationW}(lpRootPathName, lpVolumeNameBuffer, nVolumeNameSize, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, lpFileSystemNameBuffer, nFileSystemNameSize) + else begin + SetLength(AnsiVolumeNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); + SetLength(AnsiFileSystemNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); + AnsiBuffLen := Length(AnsiFileSystemNameBuffer); + Result := GetVolumeInformationA{TNT-ALLOW GetVolumeInformationA}(PAnsiChar(AnsiString(lpRootPathName)), PAnsiChar(AnsiVolumeNameBuffer), AnsiBuffLen, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, PAnsiChar(AnsiFileSystemNameBuffer), AnsiBuffLen); + if Result then begin + SetLength(AnsiFileSystemNameBuffer, AnsiBuffLen); + if (nFileSystemNameSize <= AnsiBuffLen) or (Length(AnsiFileSystemNameBuffer) = 0) then + Result := False + else begin + WStrPLCopy(lpFileSystemNameBuffer, AnsiFileSystemNameBuffer, nFileSystemNameSize); + WStrPLCopy(lpVolumeNameBuffer, AnsiVolumeNameBuffer, nVolumeNameSize); + end; + end; + end; +end; + +function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetModuleFileNameW{TNT-ALLOW GetModuleFileNameW}(hModule, lpFilename, nSize) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetModuleFileNameA{TNT-ALLOW GetModuleFileNameA}(hModule, PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(nSize, lpFilename, AnsiBuff, [poExactCopy]); + end; +end; + +function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetTempPathW{TNT-ALLOW GetTempPathW}(nBufferLength, lpBuffer) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetTempPathA{TNT-ALLOW GetTempPathA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); + Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); + end; +end; + +function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; + lpTempFileName: PWideChar): UINT; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetTempFileNameW{TNT-ALLOW GetTempFileNameW}(lpPathName, lpPrefixString, uUnique, lpTempFileName) + else begin + SetLength(AnsiBuff, MAX_PATH); + Result := GetTempFileNameA{TNT-ALLOW GetTempFileNameA}(PAnsiChar(AnsiString(lpPathName)), PAnsiChar(lpPrefixString), uUnique, PAnsiChar(AnsiBuff)); + AnsiBuff := PAnsiChar(AnsiBuff); + _HandlePathLengthResult(MAX_PATH, lpTempFileName, AnsiBuff, [poZeroSmallBuff]); + end; +end; + +function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetWindowsDirectoryW{TNT-ALLOW GetWindowsDirectoryW}(lpBuffer, uSize) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetWindowsDirectoryA{TNT-ALLOW GetWindowsDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); + end; +end; + +function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetSystemDirectoryW{TNT-ALLOW GetSystemDirectoryW}(lpBuffer, uSize) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetSystemDirectoryA{TNT-ALLOW GetSystemDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); + Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); + end; +end; + +function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetCurrentDirectoryW{TNT-ALLOW GetCurrentDirectoryW}(nBufferLength, lpBuffer) + else begin + SetLength(AnsiBuff, MAX_PATH); + SetLength(AnsiBuff, GetCurrentDirectoryA{TNT-ALLOW GetCurrentDirectoryA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); + Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); + end; +end; + +function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; +begin + if Win32PlatformIsUnicode then + Result := SetCurrentDirectoryW{TNT-ALLOW SetCurrentDirectoryW}(lpPathName) + else + Result := SetCurrentDirectoryA{TNT-ALLOW SetCurrentDirectoryA}(PAnsiChar(AnsiString(lpPathName))); +end; + +function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; +var + AnsiBuff: AnsiString; + AnsiBuffLen: DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetComputerNameW{TNT-ALLOW GetComputerNameW}(lpBuffer, nSize) + else begin + SetLength(AnsiBuff, MAX_COMPUTERNAME_LENGTH + 1); + AnsiBuffLen := Length(AnsiBuff); + Result := GetComputerNameA{TNT-ALLOW GetComputerNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); + if Result then begin + SetLength(AnsiBuff, AnsiBuffLen); + if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin + nSize := AnsiBuffLen + 1; + Result := False; + end else begin + WStrPLCopy(lpBuffer, AnsiBuff, nSize); + nSize := WStrLen(lpBuffer); + end; + end; + end; +end; + +function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; +var + AnsiBuff: AnsiString; + AnsiBuffLen: DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetUserNameW{TNT-ALLOW GetUserNameW}(lpBuffer, nSize) + else begin + SetLength(AnsiBuff, 255); + AnsiBuffLen := Length(AnsiBuff); + Result := GetUserNameA{TNT-ALLOW GetUserNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); + if Result then begin + SetLength(AnsiBuff, AnsiBuffLen); + if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin + nSize := AnsiBuffLen + 1; + Result := False; + end else begin + WStrPLCopy(lpBuffer, AnsiBuff, nSize); + nSize := WStrLen(lpBuffer); + end; + end; + end; +end; + +function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, + Directory: PWideChar; ShowCmd: Integer): HINST; +begin + if Win32PlatformIsUnicode then + Result := ShellExecuteW{TNT-ALLOW ShellExecuteW}(hWnd, _PWideCharWithNil(WideString(Operation)), + FileName, Parameters, + Directory, ShowCmd) + else begin + Result := ShellExecuteA{TNT-ALLOW ShellExecuteA}(hWnd, _PAnsiCharWithNil(AnsiString(Operation)), + _PAnsiCharWithNil(AnsiString(FileName)), _PAnsiCharWithNil(AnsiString(Parameters)), + _PAnsiCharWithNil(AnsiString(Directory)), ShowCmd) + end; +end; + +function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; +begin + if Win32PlatformIsUnicode then + Result := LoadLibraryW{TNT-ALLOW LoadLibraryW}(lpLibFileName) + else + Result := LoadLibraryA{TNT-ALLOW LoadLibraryA}(PAnsiChar(AnsiString(lpLibFileName))); +end; + +function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; +begin + if Win32PlatformIsUnicode then + Result := LoadLibraryExW{TNT-ALLOW LoadLibraryExW}(lpLibFileName, hFile, dwFlags) + else + Result := LoadLibraryExA{TNT-ALLOW LoadLibraryExA}(PAnsiChar(AnsiString(lpLibFileName)), hFile, dwFlags); +end; + +function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; + var lpProcessInformation: TProcessInformation): BOOL; +var + AnsiStartupInfo: TStartupInfoA; +begin + if Win32PlatformIsUnicode then begin + Result := CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName, lpCommandLine, + lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, + lpCurrentDirectory, lpStartupInfo, lpProcessInformation) + end else begin + CopyMemory(@AnsiStartupInfo, @lpStartupInfo, SizeOf(TStartupInfo)); + AnsiStartupInfo.lpReserved := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpReserved)); + AnsiStartupInfo.lpDesktop := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpDesktop)); + AnsiStartupInfo.lpTitle := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpTitle)); + Result := CreateProcessA{TNT-ALLOW CreateProcessA}(_PAnsiCharWithNil(AnsiString(lpApplicationName)), + _PAnsiCharWithNil(AnsiString(lpCommandLine)), + lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, + _PAnsiCharWithNil(AnsiString(lpCurrentDirectory)), AnsiStartupInfo, lpProcessInformation); + end; +end; + +function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; + lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; +const + MAX_ANSI_BUFF_SIZE = 64; // can a currency string actually be larger? +var + AnsiFormat: TCurrencyFmtA; + PAnsiFormat: PCurrencyFmtA; + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetCurrencyFormatW{TNT-ALLOW GetCurrencyFormatW}(Locale, dwFlags, lpValue, lpFormat, lpCurrencyStr, cchCurrency) + else begin + if lpFormat = nil then + PAnsiFormat := nil + else begin + ZeroMemory(@AnsiFormat, SizeOf(AnsiFormat)); + AnsiFormat.NumDigits := lpFormat.NumDigits; + AnsiFormat.LeadingZero := lpFormat.LeadingZero; + AnsiFormat.Grouping := lpFormat.Grouping; + AnsiFormat.lpDecimalSep := PAnsiChar(AnsiString(lpFormat.lpDecimalSep)); + AnsiFormat.lpThousandSep := PAnsiChar(AnsiString(lpFormat.lpThousandSep)); + AnsiFormat.NegativeOrder := lpFormat.NegativeOrder; + AnsiFormat.PositiveOrder := lpFormat.PositiveOrder; + AnsiFormat.lpCurrencySymbol := PAnsiChar(AnsiString(lpFormat.lpCurrencySymbol)); + PAnsiFormat := @AnsiFormat; + end; + SetLength(AnsiBuff, MAX_ANSI_BUFF_SIZE); + SetLength(AnsiBuff, GetCurrencyFormatA{TNT-ALLOW GetCurrencyFormatA}(Locale, dwFlags, + PAnsiChar(AnsiString(lpValue)), PAnsiFormat, PAnsiChar(AnsiBuff), MAX_ANSI_BUFF_SIZE)); + Result := _HandleStringLengthResult(cchCurrency, lpCurrencyStr, AnsiBuff, []); + end; +end; + +function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; + cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; +var + WideStr1, WideStr2: WideString; + AnsiStr1, AnsiStr2: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := CompareStringW{TNT-ALLOW CompareStringW}(Locale, dwCmpFlags, lpString1, cchCount1, lpString2, cchCount2) + else begin + WideStr1 := _WStr(lpString1, cchCount1); + WideStr2 := _WStr(lpString2, cchCount2); + if (dwCmpFlags = 0) then begin + // binary comparison + if WideStr1 < WideStr2 then + Result := 1 + else if WideStr1 = WideStr2 then + Result := 2 + else + Result := 3; + end else begin + AnsiStr1 := WideStr1; + AnsiStr2 := WideStr2; + Result := CompareStringA{TNT-ALLOW CompareStringA}(Locale, dwCmpFlags, + PAnsiChar(AnsiStr1), -1, PAnsiChar(AnsiStr2), -1); + end; + end; +end; + +function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; +var + AStr: AnsiString; + WStr: WideString; +begin + if Win32PlatformIsUnicode then + Result := CharUpperW{TNT-ALLOW CharUpperW}(lpsz) + else begin + if HiWord(Cardinal(lpsz)) = 0 then begin + // literal char mode + Result := lpsz; + if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin + AStr := WideChar(lpsz); // single character may be more than one byte + CharUpperA{TNT-ALLOW CharUpperA}(PAnsiChar(AStr)); + WStr := AStr; // should always be single wide char + if Length(WStr) = 1 then + Result := PWideChar(WStr[1]); + end + end else begin + // null-terminated string mode + Result := lpsz; + while lpsz^ <> #0 do begin + lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; + end; +end; + +function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; +var + i: integer; +begin + if Win32PlatformIsUnicode then + Result := CharUpperBuffW{TNT-ALLOW CharUpperBuffW}(lpsz, cchLength) + else begin + Result := cchLength; + for i := 1 to cchLength do begin + lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; +end; + +function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; +var + AStr: AnsiString; + WStr: WideString; +begin + if Win32PlatformIsUnicode then + Result := CharLowerW{TNT-ALLOW CharLowerW}(lpsz) + else begin + if HiWord(Cardinal(lpsz)) = 0 then begin + // literal char mode + Result := lpsz; + if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin + AStr := WideChar(lpsz); // single character may be more than one byte + CharLowerA{TNT-ALLOW CharLowerA}(PAnsiChar(AStr)); + WStr := AStr; // should always be single wide char + if Length(WStr) = 1 then + Result := PWideChar(WStr[1]); + end + end else begin + // null-terminated string mode + Result := lpsz; + while lpsz^ <> #0 do begin + lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; + end; +end; + +function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; +var + i: integer; +begin + if Win32PlatformIsUnicode then + Result := CharLowerBuffW{TNT-ALLOW CharLowerBuffW}(lpsz, cchLength) + else begin + Result := cchLength; + for i := 1 to cchLength do begin + lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); + Inc(lpsz); + end; + end; +end; + +function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; + lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; +var + AStr: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := GetStringTypeExW{TNT-ALLOW GetStringTypeExW}(Locale, dwInfoType, lpSrcStr, cchSrc, lpCharType) + else begin + AStr := _WStr(lpSrcStr, cchSrc); + Result := GetStringTypeExA{TNT-ALLOW GetStringTypeExA}(Locale, dwInfoType, + PAnsiChar(AStr), -1, lpCharType); + end; +end; + +function Win9x_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; +// This function originated by the WINE Project. +// It was translated to Pascal by Francisco Leong. +// It was further modified by Troy Wolbrink. +var + hmem: HGLOBAL; + hrsrc: THandle; + p: PWideChar; + string_num, i: Integer; + block: Integer; +begin + Result := 0; + // Netscape v3 fix... + if (HIWORD(uID) = $FFFF) then begin + uID := UINT(-(Integer(uID))); + end; + // figure block, string_num + block := ((uID shr 4) and $FFFF) + 1; // bits 4 - 19, mask out bits 20 - 31, inc by 1 + string_num := uID and $000F; + // get handle & pointer to string block + hrsrc := FindResource{TNT-ALLOW FindResource}(hInstance, MAKEINTRESOURCE(block), RT_STRING); + if (hrsrc <> 0) then + begin + hmem := LoadResource(hInstance, hrsrc); + if (hmem <> 0) then + begin + p := LockResource(hmem); + // walk the block to the requested string + for i := 0 to string_num - 1 do begin + p := p + Integer(p^) + 1; + end; + Result := Integer(p^); { p points to the length of string } + Inc(p); { p now points to the actual string } + if (lpBuffer <> nil) and (nBufferMax > 0) then + begin + Result := min(nBufferMax - 1, Result); { max length to copy } + if (Result > 0) then begin + CopyMemory(lpBuffer, p, Result * sizeof(WideChar)); + end; + lpBuffer[Result] := WideChar(0); { null terminate } + end; + end; + end; +end; + +function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; +begin + if Win32PlatformIsUnicode then + Result := Windows.LoadStringW{TNT-ALLOW LoadStringW}(hInstance, uID, lpBuffer, nBufferMax) + else + Result := Win9x_LoadStringW(hInstance, uID, lpBuffer, nBufferMax); +end; + +function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: TMenuItemInfoW): BOOL; +begin + if Win32PlatformIsUnicode then + Result := InsertMenuItemW{TNT-ALLOW InsertMenuItemW}(hMenu, uItem, fByPosition, lpmii) + else begin + TMenuItemInfoA(lpmii).dwTypeData := PAnsiChar(AnsiString(lpmii.dwTypeData)); + Result := InsertMenuItemA{TNT-ALLOW InsertMenuItemA}(hMenu, uItem, fByPosition, TMenuItemInfoA(lpmii)); + end; +end; + +function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; + var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; +begin + if Win32PlatformIsUnicode then + Result := ExtractIconExW{TNT-ALLOW ExtractIconExW}(lpszFile, + nIconIndex, phiconLarge, phiconSmall, nIcons) + else + Result := ExtractIconExA{TNT-ALLOW ExtractIconExA}(PAnsiChar(AnsiString(lpszFile)), + nIconIndex, phiconLarge, phiconSmall, nIcons); +end; + +function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; + var lpiIcon: Word): HICON; +begin + if Win32PlatformIsUnicode then + Result := ExtractAssociatedIconW{TNT-ALLOW ExtractAssociatedIconW}(hInst, lpIconPath, lpiIcon) + else + Result := ExtractAssociatedIconA{TNT-ALLOW ExtractAssociatedIconA}(hInst, + PAnsiChar(AnsiString(lpIconPath)), lpiIcon) +end; + +function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; +begin + if Win32PlatformIsUnicode then + Result := GetFileVersionInfoSizeW{TNT-ALLOW GetFileVersionInfoSizeW}(lptstrFilename, lpdwHandle) + else + Result := GetFileVersionInfoSizeA{TNT-ALLOW GetFileVersionInfoSizeA}(PAnsiChar(AnsiString(lptstrFilename)), lpdwHandle); +end; + +function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; + lpData: Pointer): BOOL; +begin + if Win32PlatformIsUnicode then + Result := GetFileVersionInfoW{TNT-ALLOW GetFileVersionInfoW}(lptstrFilename, dwHandle, dwLen, lpData) + else + Result := GetFileVersionInfoA{TNT-ALLOW GetFileVersionInfoA}(PAnsiChar(AnsiString(lptstrFilename)), dwHandle, dwLen, lpData); +end; + +var + Last_VerQueryValue_String: WideString; + +function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; + var lplpBuffer: Pointer; var puLen: UINT): BOOL; +var + AnsiBuff: AnsiString; +begin + if Win32PlatformIsUnicode then + Result := VerQueryValueW{TNT-ALLOW VerQueryValueW}(pBlock, lpSubBlock, lplpBuffer, puLen) + else begin + Result := VerQueryValueA{TNT-ALLOW VerQueryValueA}(pBlock, PAnsiChar(AnsiString(lpSubBlock)), lplpBuffer, puLen); + if WideTextPos(VQV_STRINGFILEINFO, lpSubBlock) <> 1 then + else begin + { /StringFileInfo, convert ansi result to unicode } + SetString(AnsiBuff, PAnsiChar(lplpBuffer), puLen); + Last_VerQueryValue_String := AnsiBuff; + lplpBuffer := PWideChar(Last_VerQueryValue_String); + puLen := Length(Last_VerQueryValue_String); + end; + end; +end; + +//--------------------------------------------------------------------------------------- +// Wide functions from Shell32.dll should be loaded dynamically (no stub on early Win95) +//--------------------------------------------------------------------------------------- + +type + TSHFileOperationW = function(var lpFileOp: TSHFileOpStructW): Integer; stdcall; + TSHBrowseForFolderW = function(var lpbi: TBrowseInfoW): PItemIDList; stdcall; + TSHGetPathFromIDListW = function(pidl: PItemIDList; pszPath: PWideChar): BOOL; stdcall; + TSHGetFileInfoW = function(pszPath: PWideChar; dwFileAttributes: DWORD; + var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; stdcall; + +var + Safe_SHFileOperationW: TSHFileOperationW = nil; + Safe_SHBrowseForFolderW: TSHBrowseForFolderW = nil; + Safe_SHGetPathFromIDListW: TSHGetPathFromIDListW = nil; + Safe_SHGetFileInfoW: TSHGetFileInfoW = nil; + +var Shell32DLL: HModule = 0; + +procedure LoadWideShell32Procs; +begin + if Shell32DLL = 0 then begin + Shell32DLL := WinCheckH(Tnt_LoadLibraryW('shell32.dll')); + Safe_SHFileOperationW := WinCheckP(GetProcAddress(Shell32DLL, 'SHFileOperationW')); + Safe_SHBrowseForFolderW := WinCheckP(GetProcAddress(Shell32DLL, 'SHBrowseForFolderW')); + Safe_SHGetPathFromIDListW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetPathFromIDListW')); + Safe_SHGetFileInfoW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetFileInfoW')); + end; +end; + +function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; +var + AnsiFileOp: TSHFileOpStructA; + MapCount: Integer; + PAnsiMap: PSHNameMappingA; + PWideMap: PSHNameMappingW; + OldPath: WideString; + NewPath: WideString; + i: integer; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHFileOperationW(lpFileOp); + end else begin + AnsiFileOp := TSHFileOpStructA(lpFileOp); + // convert PChar -> PWideChar + if lpFileOp.pFrom = nil then + AnsiFileOp.pFrom := nil + else + AnsiFileOp.pFrom := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pFrom))); + if lpFileOp.pTo = nil then + AnsiFileOp.pTo := nil + else + AnsiFileOp.pTo := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pTo))); + AnsiFileOp.lpszProgressTitle := PAnsiChar(AnsiString(lpFileOp.lpszProgressTitle)); + Result := SHFileOperationA{TNT-ALLOW SHFileOperationA}(AnsiFileOp); + // return struct results + lpFileOp.fAnyOperationsAborted := AnsiFileOp.fAnyOperationsAborted; + lpFileOp.hNameMappings := nil; + if (AnsiFileOp.hNameMappings <> nil) + and ((FOF_WANTMAPPINGHANDLE and AnsiFileOp.fFlags) <> 0) then begin + // alloc mem + MapCount := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).cNumOfMappings; + lpFileOp.hNameMappings := + AllocMem(SizeOf({hNameMappings}Cardinal) + SizeOf(TSHNameMappingW) * MapCount); + PSHNameMappingHeaderW(lpFileOp.hNameMappings).cNumOfMappings := MapCount; + // init pointers + PAnsiMap := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).lpNM; + PWideMap := PSHNameMappingHeaderW(lpFileOp.hNameMappings).lpNM; + for i := 1 to MapCount do begin + // old path + OldPath := Copy(PAnsiMap.pszOldPath, 1, PAnsiMap.cchOldPath); + PWideMap.pszOldPath := WStrNew(PWideChar(OldPath)); + PWideMap.cchOldPath := WStrLen(PWideMap.pszOldPath); + // new path + NewPath := Copy(PAnsiMap.pszNewPath, 1, PAnsiMap.cchNewPath); + PWideMap.pszNewPath := WStrNew(PWideChar(NewPath)); + PWideMap.cchNewPath := WStrLen(PWideMap.pszNewPath); + // next record + Inc(PAnsiMap); + Inc(PWideMap); + end; + end; + end; +end; + +procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); +var + i: integer; + MapCount: Integer; + PWideMap: PSHNameMappingW; +begin + if Win32PlatformIsUnicode then + SHFreeNameMappings{TNT-ALLOW SHFreeNameMappings}(hNameMappings) + else begin + // free strings + MapCount := PSHNameMappingHeaderW(hNameMappings).cNumOfMappings; + PWideMap := PSHNameMappingHeaderW(hNameMappings).lpNM; + for i := 1 to MapCount do begin + WStrDispose(PWideMap.pszOldPath); + WStrDispose(PWideMap.pszNewPath); + Inc(PWideMap); + end; + // free struct + FreeMem(Pointer(hNameMappings)); + end; +end; + +function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; +var + AnsiInfo: TBrowseInfoA; + AnsiBuffer: array[0..MAX_PATH] of AnsiChar; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHBrowseForFolderW(lpbi); + end else begin + AnsiInfo := TBrowseInfoA(lpbi); + AnsiInfo.lpszTitle := PAnsiChar(AnsiString(lpbi.lpszTitle)); + if lpbi.pszDisplayName <> nil then + AnsiInfo.pszDisplayName := AnsiBuffer; + Result := SHBrowseForFolderA{TNT-ALLOW SHBrowseForFolderA}(AnsiInfo); + if lpbi.pszDisplayName <> nil then + WStrPCopy(lpbi.pszDisplayName, AnsiInfo.pszDisplayName); + lpbi.iImage := AnsiInfo.iImage; + end; +end; + +function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; +var + AnsiPath: AnsiString; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHGetPathFromIDListW(pidl, pszPath); + end else begin + SetLength(AnsiPath, MAX_PATH); + Result := SHGetPathFromIDListA{TNT-ALLOW SHGetPathFromIDListA}(pidl, PAnsiChar(AnsiPath)); + if Result then + WStrPCopy(pszPath, PAnsiChar(AnsiPath)) + end; +end; + +function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; + var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; +var + SHFileInfoA: TSHFileInfoA; +begin + if Win32PlatformIsUnicode then begin + LoadWideShell32Procs; + Result := Safe_SHGetFileInfoW(pszPath, dwFileAttributes, psfi, cbFileInfo, uFlags) + end else begin + Result := SHGetFileInfoA{TNT-ALLOW SHGetFileInfoA}(PAnsiChar(AnsiString(pszPath)), + dwFileAttributes, SHFileInfoA, SizeOf(TSHFileInfoA), uFlags); + // update pfsi... + ZeroMemory(@psfi, SizeOf(TSHFileInfoW)); + psfi.hIcon := SHFileInfoA.hIcon; + psfi.iIcon := SHFileInfoA.iIcon; + psfi.dwAttributes := SHFileInfoA.dwAttributes; + WStrPLCopy(psfi.szDisplayName, SHFileInfoA.szDisplayName, MAX_PATH); + WStrPLCopy(psfi.szTypeName, SHFileInfoA.szTypeName, 80); + end; +end; + + +function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; +begin + Result := HiWord(Cardinal(ResStr)) = 0; +end; + +function LANGIDFROMLCID(lcid: LCID): WORD; +begin + Result := LoWord(lcid); +end; + +function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; +begin + Result := (usSubLanguage shl 10) or usPrimaryLanguage; +end; + +function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; +begin + Result := MakeLong(wLanguageID, wSortID); +end; + +function PRIMARYLANGID(lgid: WORD): WORD; +begin + Result := lgid and $03FF; +end; + +function SORTIDFROMLCID(lcid: LCID): WORD; +begin + Result := HiWord(lcid); +end; + +function SUBLANGID(lgid: WORD): WORD; +begin + Result := lgid shr 10; +end; + +initialization + +finalization + if Shell32DLL <> 0 then + FreeLibrary(Shell32DLL); + +end. -- 2.11.4.GIT