From 99f1c859eea7d70884d1ad8fa12b061f7b3f8b04 Mon Sep 17 00:00:00 2001 From: George Hazan Date: Tue, 9 Oct 2012 18:48:50 +0000 Subject: KOL merged with Libs git-svn-id: http://svn.miranda-ng.org/main/trunk@1849 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c --- plugins/ImportTXT/kol/CplxMath.pas | 278 - plugins/ImportTXT/kol/KOLDEF.INC | 303 - plugins/ImportTXT/kol/KOLEdb.pas | 2209 - plugins/ImportTXT/kol/KOLMHTooltip_implem.inc | 437 - plugins/ImportTXT/kol/KOLMHTooltip_interface.inc | 95 - plugins/ImportTXT/kol/KOLMHTooltip_intf2.inc | 13 - plugins/ImportTXT/kol/KOL_ASM.inc | 15855 ------ plugins/ImportTXT/kol/KOL_ASM_NOUNICODE.inc | 4351 -- plugins/ImportTXT/kol/KOL_ansi.inc | 2316 - plugins/ImportTXT/kol/KOL_unicode.inc | 1277 - plugins/ImportTXT/kol/LICENSE.txt | 150 - plugins/ImportTXT/kol/MCKfakeClasses.inc | 79 - plugins/ImportTXT/kol/MCKfakeClasses200x.inc | 51 - plugins/ImportTXT/kol/Mmx.pas | 361 - plugins/ImportTXT/kol/MsgDecode.pas | 4957 -- plugins/ImportTXT/kol/delphicommctrl.inc | 1594 - plugins/ImportTXT/kol/delphidef.inc | 48 - plugins/ImportTXT/kol/err.pas | 1197 - plugins/ImportTXT/kol/kol.pas | 61852 --------------------- plugins/ImportTXT/kol/kolmath.pas | 1845 - plugins/ImportTXT/kol/read1st.txt | 63 - plugins/ImportTXT/kol/read1st_rus.txt | 61 - plugins/ImportTXT/kol/visual_xp_styles.inc | 1448 - plugins/ImportTXT/make.bat | 31 +- plugins/Libs/CplxMath.pas | 278 + plugins/Libs/KOLEdb.pas | 2209 + plugins/Libs/KOLMHTooltip_implem.inc | 437 + plugins/Libs/KOLMHTooltip_interface.inc | 95 + plugins/Libs/KOLMHTooltip_intf2.inc | 13 + plugins/Libs/LICENSE.txt | 150 + plugins/Libs/Mmx.pas | 361 + plugins/Libs/delphidef.inc | 48 + plugins/Libs/read1st.txt | 63 + plugins/Libs/read1st_rus.txt | 61 + 34 files changed, 3735 insertions(+), 100851 deletions(-) delete mode 100644 plugins/ImportTXT/kol/CplxMath.pas delete mode 100644 plugins/ImportTXT/kol/KOLDEF.INC delete mode 100644 plugins/ImportTXT/kol/KOLEdb.pas delete mode 100644 plugins/ImportTXT/kol/KOLMHTooltip_implem.inc delete mode 100644 plugins/ImportTXT/kol/KOLMHTooltip_interface.inc delete mode 100644 plugins/ImportTXT/kol/KOLMHTooltip_intf2.inc delete mode 100644 plugins/ImportTXT/kol/KOL_ASM.inc delete mode 100644 plugins/ImportTXT/kol/KOL_ASM_NOUNICODE.inc delete mode 100644 plugins/ImportTXT/kol/KOL_ansi.inc delete mode 100644 plugins/ImportTXT/kol/KOL_unicode.inc delete mode 100644 plugins/ImportTXT/kol/LICENSE.txt delete mode 100644 plugins/ImportTXT/kol/MCKfakeClasses.inc delete mode 100644 plugins/ImportTXT/kol/MCKfakeClasses200x.inc delete mode 100644 plugins/ImportTXT/kol/Mmx.pas delete mode 100644 plugins/ImportTXT/kol/MsgDecode.pas delete mode 100644 plugins/ImportTXT/kol/delphicommctrl.inc delete mode 100644 plugins/ImportTXT/kol/delphidef.inc delete mode 100644 plugins/ImportTXT/kol/err.pas delete mode 100644 plugins/ImportTXT/kol/kol.pas delete mode 100644 plugins/ImportTXT/kol/kolmath.pas delete mode 100644 plugins/ImportTXT/kol/read1st.txt delete mode 100644 plugins/ImportTXT/kol/read1st_rus.txt delete mode 100644 plugins/ImportTXT/kol/visual_xp_styles.inc create mode 100644 plugins/Libs/CplxMath.pas create mode 100644 plugins/Libs/KOLEdb.pas create mode 100644 plugins/Libs/KOLMHTooltip_implem.inc create mode 100644 plugins/Libs/KOLMHTooltip_interface.inc create mode 100644 plugins/Libs/KOLMHTooltip_intf2.inc create mode 100644 plugins/Libs/LICENSE.txt create mode 100644 plugins/Libs/Mmx.pas create mode 100644 plugins/Libs/delphidef.inc create mode 100644 plugins/Libs/read1st.txt create mode 100644 plugins/Libs/read1st_rus.txt (limited to 'plugins') diff --git a/plugins/ImportTXT/kol/CplxMath.pas b/plugins/ImportTXT/kol/CplxMath.pas deleted file mode 100644 index 7cd180af9e..0000000000 --- a/plugins/ImportTXT/kol/CplxMath.pas +++ /dev/null @@ -1,278 +0,0 @@ -unit CplxMath; -{* This unit contains functins for working with complex numbers. To use with - KOL library and its kolmath.pas unit instead of standard math.pas, define - synmbol KOL in project options, or uncomment its definition below. } - -interface - -//{$DEFINE KOL} - -{$IFNDEF KOL} - {$IFDEF KOL_MCK} - {$DEFINE KOL} - {$ENDIF} -{$ENDIF} - -uses {$IFDEF KOL} kolmath, kol {$ELSE} math, sysutils {$ENDIF}; - -type - {$IFDEF CPLX_EXTENDED} - Double = Extended; - {$ENDIF} - - Complex = record Re, Im: double end; - {* } - - function CfromReIm( Re, Im: Double ): Complex; - {* Re + i * Im } - - function Cadd( const X, Y: Complex ): Complex; - {* X + Y } - - function Cneg( const X: Complex ): Complex; - {* -X } - - function Csub( const X, Y: Complex ): Complex; - {* X - Y } - - function Cmul( const X, Y: Complex ): Complex; - {* X * Y } - - function CmulD( const X: Complex; D: Double ): Complex; - {* X * D } - - function CmulI( const X: Complex ): Complex; - {* i * X } - - function Cdiv( const X, Y: Complex ): Complex; - {* X / Y } - - function Cmod( const X: Complex ): Double; - {* Q( X.Re^2 + X.Im^2 ) } - - function Carg( const X: Complex ): Double; - {* arctg( X.Im / X.Re ) } - - function CfromModArg( R, Arg: Double ): Complex; - {* R * ( cos Arg + i * sin Arg ) } - - function Cpow( const X: Complex; Pow: Double ): Complex; - {* X ^ Pow } - - function Cpower( const X, Pow: Complex ): Complex; - {* X ^ Pow } - - function CIntPower( const X: Complex; Pow: Integer ): Complex; - {* X ^ Pow} - - function Csqrt( const X: Complex ): Complex; - {* Q( X ) } - - function Cexp( const X: Complex ): Complex; - {* exp( X ) } - - function Cln( const X: Complex ): Complex; - {* ln( X ) } - - function Ccos( const X: Complex ): Complex; - {* cos( X ) } - - function Csin( const X: Complex ): Complex; - {* sin( X ) } - - function C2Str( const X: Complex ): String; - {* } - - function C2StrEx( const X: Complex ): String; - {* experimental } - -implementation - - function CfromReIm( Re, Im: Double ): Complex; - begin - Result.Re := Re; - Result.Im := Im; - end; - - function Cadd( const X, Y: Complex ): Complex; - begin - Result.Re := X.Re + Y.Re; - Result.Im := X.Im + Y.Im; - end; - - function Cneg( const X: Complex ): Complex; - begin - Result.Re := -X.Re; - Result.Im := -X.Im; - end; - - function Csub( const X, Y: Complex ): Complex; - begin - Result := Cadd( X, Cneg( Y ) ); - end; - - function Cmul( const X, Y: Complex ): Complex; - begin - Result.Re := X.Re * Y.Re - X.Im * Y.Im; - Result.Im := X.Re * Y.Im + X.Im * Y.Re; - end; - - function CmulD( const X: Complex; D: Double ): Complex; - begin - Result.Re := X.Re * D; - Result.Im := X.Im * D; - end; - - function CmulI( const X: Complex ): Complex; - begin - Result.Re := -X.Im; - Result.Im := X.Re; - end; - - function Cdiv( const X, Y: Complex ): Complex; - var Z: Double; - begin - Z := 1.0 / ( Y.Re * Y.Re + Y.Im * Y.Im ); - Result.Re := (X.Re * Y.Re + X.Im * Y.Im ) * Z; - Result.Im := (X.Im * Y.Re - X.Re * Y.Im ) * Z; - end; - - function Cmod( const X: Complex ): Double; - begin - Result := sqrt( X.Re * X.Re + X.Im * X.Im ); - end; - - function Carg( const X: Complex ): Double; - begin - Result := ArcTan2( X.Im, X.Re ); - end; - - function CfromModArg( R, Arg: Double ): Complex; - begin - Result.Re := R * cos( Arg ); - Result.Im := R * sin( Arg ); - end; - - function Cpow( const X: Complex; Pow: Double ): Complex; - var R, A: Double; - begin - R := power( Cmod( X ), Pow ); - A := Pow * Carg( X ); - Result := CfromModArg( R, A ); - end; - - function Cpower( const X, Pow: Complex ): Complex; - begin - Result := Cexp( Cmul( X, Cln( Pow ) ) ); - end; - - function CIntPower( const X: Complex; Pow: Integer ): Complex; - begin - if (Pow < 0) or (Pow > 100) then Result := Cpow( X, Pow ) - else if Pow = 0 then - begin - Result.Re := 1; - Result.Im := 0; - end - else - begin - Result := X; - while Pow > 1 do - begin - Result := Cmul( Result, X ); - dec( Pow ); - end; - end; - end; - - function Csqrt( const X: Complex ): Complex; - begin - Result := Cpow( X, 0.5 ); - end; - - function Cexp( const X: Complex ): Complex; - var Z: Double; - begin - Z := exp( X.Re ); - Result.Re := Z * cos( X.Im ); - Result.Im := Z * sin( X.Im ); - end; - - function Cln( const X: Complex ): Complex; - begin - Result := CfromModArg( ln( Cmod( X ) ), Carg( X ) ); - end; - - function Ccos( const X: Complex ): Complex; - begin - Result := CmulI( X ); - Result := CmulD( Cadd( Cexp( Result ), Cexp( Cneg( Result ) ) ), - 0.5 ); - end; - - function Csin( const X: Complex ): Complex; - begin - Result := CmulI( X ); - Result := CmulD( Csub( Cexp(Result), Cexp( Cneg(Result) ) ), - 0.5 ); - end; - - {$IFDEF KOL} - function Abs( X: Double ): Double; - begin - Result := EAbs( X ); - end; - {$ENDIF} - - {$IFNDEF KOL} - function Double2Str( D: Double ): String; - begin - Result := DoubleToStr( D ); - end; - {$ENDIF} - - function C2Str( const X: Complex ): String; - begin - if Abs( X.Im ) < 1e-307 then - begin - Result := Double2Str( X.Re ); - end - else - begin - Result := ''; - if Abs( X.Re ) > 1e-307 then - begin - Result := Double2Str( X.Re ); - if X.Im > 0.0 then - Result := Result + ' + '; - end; - if X.Im < 0.0 then - Result := Result + '- i * ' + Double2Str( -X.Im ) - else - Result := Result + 'i * ' + Double2Str( X.Im ); - end; - end; - - function C2StrEx( const X: Complex ): String; - begin - if Abs( X.Im ) < 1e-307 then - begin - Result := Double2StrEx( X.Re ); - end - else - begin - Result := ''; - if Abs( X.Re ) > 1e-307 then - begin - Result := Double2StrEx( X.Re ); - if X.Im > 0.0 then - Result := Result + ' + '; - end; - if X.Im < 0.0 then - Result := Result + '- i * ' + Double2StrEx( -X.Im ) - else - Result := Result + 'i * ' + Double2StrEx( X.Im ); - end; - end; - -end. diff --git a/plugins/ImportTXT/kol/KOLDEF.INC b/plugins/ImportTXT/kol/KOLDEF.INC deleted file mode 100644 index 548984765c..0000000000 --- a/plugins/ImportTXT/kol/KOLDEF.INC +++ /dev/null @@ -1,303 +0,0 @@ -{$IFDEF VER90} - {$DEFINE _D2} - {$DEFINE _D2orD3} - {$DEFINE _D2orD3orD4} -{$ENDIF} - -{$IFDEF VER100} - {$DEFINE _D3} - {$DEFINE _D3orHigher} - {$DEFINE _D2orD3} - {$DEFINE _D2orD3orD4} - {$DEFINE _D3orD4} -{$ENDIF} - -{$IFDEF VER120} - {$DEFINE _D3orHigher} - {$DEFINE _D3orD4} - {$DEFINE _D4} - {$DEFINE _D4orHigher} - {$DEFINE _D2orD3orD4} - {$IFnDEF KOL_MCK} - {$DEFINE INPACKAGE} - {$ENDIF} -{$ENDIF} - -{$IFDEF VER130} - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5} - {$DEFINE _D5orHigher} -{$ENDIF} - -{$IFDEF VER140} - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6} - {$DEFINE _D6orHigher} -{$ENDIF} - -{$IFDEF VER150} - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6orHigher} - {$DEFINE _D7} - {$DEFINE _D7orHigher} -{$WARN UNIT_DEPRECATED OFF} -{$WARN SYMBOL_PLATFORM OFF} -{$WARN UNSAFE_TYPE OFF} -{$WARN UNSAFE_CAST OFF} -{$WARN UNSAFE_CODE OFF} -{$ENDIF} - -{$IFDEF VER160} // Delphi 8 -Delphi version 8 not supported! (delphi 8 is .net only) -{$ENDIF} - -{$IFDEF VER170} // Delphi 2005 - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6orHigher} - {$DEFINE _D7orHigher} - {$DEFINE _D8} - {$DEFINE _D8orHigher} - {$DEFINE _D2005} - {$DEFINE _D2005orHigher} -{$WARN UNIT_DEPRECATED OFF} -{$WARN SYMBOL_PLATFORM OFF} -{$WARN UNSAFE_TYPE OFF} -{$WARN UNSAFE_CAST OFF} -{$WARN UNSAFE_CODE OFF} -{$ENDIF} - -{$IFDEF VER180} // Delphi 2006 - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6orHigher} - {$DEFINE _D7orHigher} - {$DEFINE _D8orHigher} - {$DEFINE _D2005} - {$DEFINE _D2005orHigher} - {$DEFINE _D2006orHigher} -{$WARN UNIT_DEPRECATED OFF} -{$WARN SYMBOL_PLATFORM OFF} -{$WARN UNSAFE_TYPE OFF} -{$WARN UNSAFE_CAST OFF} -{$WARN UNSAFE_CODE OFF} -{$ENDIF} - -{$IFDEF _D2005orHigher} - - // by Thaddy de Koning: - {$IFDEF VER185} // Delphi 2007 ( and Highlander ) - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6orHigher} - {$DEFINE _D7orHigher} - {$DEFINE _D2005orHigher} - {$DEFINE _D2006orHigher} - {$DEFINE _D2007} - {$DEFINE _D2007orHigher} - {$WARN UNIT_DEPRECATED OFF} - {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} - {$ENDIF} - -{$INLINE OFF} -{$ENDIF} - -{$IFDEF VER200} // Delphi 2009 - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6orHigher} - {$DEFINE _D7orHigher} - {$DEFINE _D2005orHigher} - {$DEFINE _D2006orHigher} - {$DEFINE _D2007orHigher} - {$DEFINE _D2009} - {$DEFINE _D2009orHigher} -{$WARN UNIT_DEPRECATED OFF} -{$WARN SYMBOL_PLATFORM OFF} -{$WARN UNSAFE_TYPE OFF} -{$WARN UNSAFE_CAST OFF} -{$WARN UNSAFE_CODE OFF} -{$ENDIF} - -{$IFDEF VER210} // Delphi 2010 - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6orHigher} - {$DEFINE _D7orHigher} - {$DEFINE _D2005orHigher} - {$DEFINE _D2006orHigher} - {$DEFINE _D2007orHigher} - {$DEFINE _D2009orHigher} - {$DEFINE _D2010} - {$DEFINE _D2010orHigher} - {$WARN UNIT_DEPRECATED OFF} - {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} -{$ENDIF} - -{$IFDEF VER220} // Delphi XE - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6orHigher} - {$DEFINE _D7orHigher} - {$DEFINE _D2005orHigher} - {$DEFINE _D2006orHigher} - {$DEFINE _D2007orHigher} - {$DEFINE _D2009orHigher} - {$DEFINE _D2010orHigher} - {$DEFINE _DXE} - {$DEFINE _DXEorHigher} - {$DEFINE _DXEorHigher} - {$WARN UNIT_DEPRECATED OFF} - {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} -{$ENDIF} - -{$IFDEF VER230} // Delphi XE - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6orHigher} - {$DEFINE _D7orHigher} - {$DEFINE _D2005orHigher} - {$DEFINE _D2006orHigher} - {$DEFINE _D2007orHigher} - {$DEFINE _D2009orHigher} - {$DEFINE _D2010orHigher} - {$DEFINE _DXE} - {$DEFINE _DXEorHigher} - {$DEFINE _DXE2orHigher} - {$WARN UNIT_DEPRECATED OFF} - {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CAST OFF} - {$WARN UNSAFE_CODE OFF} -{$ENDIF} - -// TODO: check DLL project -{$IFNDEF NO_STRIP_RELOC} - // by Thaddy de Koning: - {$IFDEF _D2006orHigher} - // strips relocs, like stripreloc.exe does - {$SetPEFlags 1} -// {$SETPEFlAGS IMAGE_FILE_RELOCS_STRIPPED or IMAGE_FILE_DEBUG_STRIPPED or IMAGE_FILE_LINE_NUMS_STRIPPED or IMAGE_FILE_LOCAL_SYMS_STRIPPED or IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP or IMAGE_FILE_NET_RUN_FROM_SWAP} - {$ENDIF} -{$ENDIF} - -{$IFDEF FPC} -{------------------------------------ -by Thaddy de Koning: - -FPC version 2.1.1 is very compatible with Delphi and kol now. -You can simply use the $(DELPHI)\source\rtl\win\*.pas files from Delphi 4/5 instead of the prepared files that were needed for -FPC1.X - -That is all to have full compatibility. -------------------------------------} -{$DEFINE PAS_VERSION} -{$IFDEF VER2} - {$DEFINE _D3orHigher} - {$DEFINE _D4orHigher} - {$DEFINE _D5orHigher} - {$DEFINE _D6orHigher} - {$DEFINE _D7} - {$DEFINE _D7orHigher} -{$ENDIF} -{$ENDIF FPC} - -{$IFNDEF _NOT_KOLCtrlWrapper_} - {$DEFINE _KOLCtrlWrapper_} -{$ENDIF} - -{$IFNDEF _NOT_KOLCtrlWrapper_} - {$DEFINE _KOLCtrlWrapper_} -{$ENDIF} - -//// from delphidef.inc //// - -//{$DEFINE _FPC} -{$DEFINE ASM_VERSION} // Comment this line to produce Pascal code. - // Or, just add PAS_VERSION to conditionals - // of your project (must be rebuilt). - -{$IFDEF ASM_VERSION} - {$IFDEF PAS_VERSION} - {$UNDEF ASM_VERSION} - // To compile a project with ASM_VERSION option turned off, - // define a symbol PAS_VERSION in project options. - {$ENDIF} -{$ENDIF} - -//{$DEFINE USE_CONSTRUCTORS} -// Comment this line to produce smaller code if constructors are not used. -// When uncommented, this definition allows to create descendant controls -// and objects overriding constructors, which are actually members of objects. -// Otherwise, global functions (usually named New) are used to -// create and initialize object instances. This gives smaller code, but -// prevents from using OOP inheritance. -// Note: creating descendant objects derived from TObj does not require using -// of this option. It is actually needed only for deriving new controls on -// base of TControl. See also option USE_CUSTOMEXTENSIONS below. - -//{$DEFINE USE_CUSTOMEXTENSIONS} -// Uncomment this option or add it to your project conditional defines, -// if You wish to extend existing TControl object from -// the inner of those. When this option is turned on, include directive at the -// tail of TControl declaration is enabled, causing a compiler to include your -// portion of source directly into the TControl body. See comments near this -// directive there. (Search the word: USE_CUSTOMEXTENSIONS). -// Please note, that this option is not fully supported now. - -//{$IFNDEF NOT_UNLOAD_RICHEDITLIB} -// {$DEFINE UNLOAD_RICHEDITLIB} -//{$ENDIF} -// You can freely comment this directive. 1st, if the application does not -// use richedit control. 2nd, even if it does, freeing the library handle -// actually is not needed. -// Another way to turn this option off is to define symbol NOT_UNLOAD_RICHEDITLIB -// in your project options. - -//{$DEFINE TEST_VERSION} -{$IFNDEF _D6orHigher} - {$DEFINE PARANOIA} //seems not needed from D6 !!! Inprise fixed this, finally... -{$ENDIF} - - -{$IFNDEF USE_OLD_FLAGS} - {$DEFINE USE_FLAGS} -{$ELSE} {$UNDEF USE_FLAGS} -{$ENDIF} - -{$IFnDEF EVENTS_STATIC} - {$DEFINE EVENTS_DYNAMIC} -{$ENDIF} -{$IFnDEF CMDACTIONS_RECORD} - {$DEFINE COMMANDACTIONS_OBJ} - {$DEFINE PACK_COMMANDACTIONS} - {$IFDEF NOT_PACK_COMMANDACTIONS} - {$UNDEF PACK_COMMANDACTIONS} - {$ENDIF} -{$ENDIF} - -{$DEFINE KOL3XX} - - - diff --git a/plugins/ImportTXT/kol/KOLEdb.pas b/plugins/ImportTXT/kol/KOLEdb.pas deleted file mode 100644 index 4744adc832..0000000000 --- a/plugins/ImportTXT/kol/KOLEdb.pas +++ /dev/null @@ -1,2209 +0,0 @@ -unit KOLEdb; -{* This unit is created for KOL to allow to communicate with DB using OLE DB. -|
======================================================================== -|
Copyright (C) 2001 by Vladimir Kladov. -|

- This unit conains three objects TDataSource, TSession and TQuery to implement - the most important things: to connect to database, to control transactions, - to perform commands (queries) and obtain results or update tables. -|

-} - -interface - -uses Windows, ActiveX, KOL, err; - -type - INT64 = I64; - PInt64 = PI64; - - tagVariant = packed Record - vt: WORD; - reserved1, - reserved2, - reserved3: WORD; - case Integer of - 0: ( bVal : Byte ); - 1: ( iVal : ShortInt ); - 2: ( lVal : Integer ); - 3: ( fltVal : Extended ); - 4: ( dblVal : Double ); - 5: ( boolVal : Bool ); - 6: ( scode : SCODE ); - //7: ( cyVal : CY ); - //8: ( date : Date ); - 9: ( bstrVal : Pointer ); // BSTR => [ Len: Integer; array[ 1..Len ] of WideChar ] - 10:( pdecVal : ^Decimal ); - end; - -(* -typedef struct tagVARIANT { - VARTYPE vt; - unsigned short wReserved1; - unsigned short wReserved2; - unsigned short wReserved3; - union { - Byte bVal; // VT_UI1. - Short iVal; // VT_I2. - long lVal; // VT_I4. - float fltVal; // VT_R4. - double dblVal; // VT_R8. - VARIANT_BOOL boolVal; // VT_BOOL. - SCODE scode; // VT_ERROR. - CY cyVal; // VT_CY. - DATE date; // VT_DATE. - BSTR bstrVal; // VT_BSTR. - DECIMAL FAR* pdecVal // VT_BYREF|VT_DECIMAL. - IUnknown FAR* punkVal; // VT_UNKNOWN. - IDispatch FAR* pdispVal; // VT_DISPATCH. - SAFEARRAY FAR* parray; // VT_ARRAY|*. - Byte FAR* pbVal; // VT_BYREF|VT_UI1. - short FAR* piVal; // VT_BYREF|VT_I2. - long FAR* plVal; // VT_BYREF|VT_I4. - float FAR* pfltVal; // VT_BYREF|VT_R4. - double FAR* pdblVal; // VT_BYREF|VT_R8. - VARIANT_BOOL FAR* pboolVal; // VT_BYREF|VT_BOOL. - SCODE FAR* pscode; // VT_BYREF|VT_ERROR. - CY FAR* pcyVal; // VT_BYREF|VT_CY. - DATE FAR* pdate; // VT_BYREF|VT_DATE. - BSTR FAR* pbstrVal; // VT_BYREF|VT_BSTR. - IUnknown FAR* FAR* ppunkVal; // VT_BYREF|VT_UNKNOWN. - IDispatch FAR* FAR* ppdispVal; // VT_BYREF|VT_DISPATCH. - SAFEARRAY FAR* FAR* pparray; // VT_ARRAY|*. - VARIANT FAR* pvarVal; // VT_BYREF|VT_VARIANT. - void FAR* byref; // Generic ByRef. - char cVal; // VT_I1. - unsigned short uiVal; // VT_UI2. - unsigned long ulVal; // VT_UI4. - int intVal; // VT_INT. - unsigned int uintVal; // VT_UINT. - char FAR * pcVal; // VT_BYREF|VT_I1. - unsigned short FAR * puiVal; // VT_BYREF|VT_UI2. - unsigned long FAR * pulVal; // VT_BYREF|VT_UI4. - int FAR * pintVal; // VT_BYREF|VT_INT. - unsigned int FAR * puintVal; //VT_BYREF|VT_UINT. - }; -}; -*) - -{============= This part of code is grabbed from OLEDB.pas ================} -const - MAXBOUND = 65535; { High bound for arrays } - DBSTATUS_S_ISNULL = $00000003; - -type - PIUnknown = ^IUnknown; - PUintArray = ^TUintArray; - TUintArray = array[0..MAXBOUND] of UINT; - - HROW = UINT; - PHROW = ^HROW; - PPHROW = ^PHROW; - - HACCESSOR = UINT; - HCHAPTER = UINT; - DBCOLUMNFLAGS = UINT; - DBTYPE = Word; - DBKIND = UINT; - DBPART = UINT; - DBMEMOWNER = UINT; - DBPARAMIO = UINT; - DBBINDSTATUS = UINT; - -const - IID_NULL : TGUID = '{00000000-0000-0000-0000-000000000000}'; - IID_IDataInitialize : TGUID = '{2206CCB1-19C1-11D1-89E0-00C04FD7A829}'; - CLSID_MSDAINITIALIZE: TGUID = '{2206CDB0-19C1-11D1-89E0-00C04FD7A829}'; - - IID_IDBInitialize : TGUID = '{0C733A8B-2A1C-11CE-ADE5-00AA0044773D}'; - //IID_IDBProperties : TGUID = '{0C733A8A-2A1C-11CE-ADE5-00AA0044773D}'; - IID_IDBCreateSession: TGUID = '{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}'; - IID_IDBCreateCommand: TGUID = '{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}'; - IID_ICommand : TGUID = '{0C733A63-2A1C-11CE-ADE5-00AA0044773D}'; - IID_ICommandText : TGUID = '{0C733A27-2A1C-11CE-ADE5-00AA0044773D}'; - IID_ICommandProperties: TGUID = '{0C733A79-2A1C-11CE-ADE5-00AA0044773D}'; - IID_IRowset : TGUID = '{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}'; - IID_IRowsetChange : TGUID = '{0C733A05-2A1C-11CE-ADE5-00AA0044773D}'; - IID_IRowsetUpdate : TGUID = '{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}'; - IID_IColumnsInfo : TGUID = '{0C733A11-2A1C-11CE-ADE5-00AA0044773D}'; - IID_IAccessor : TGUID = '{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}'; - - // Added By ECM !!! ================================================== - IID_ITransaction : TGUID = '{0FB15084-AF41-11CE-BD2B-204C4F4F5020}'; - IID_ITransactionLocal: TGUID = '{0C733A5F-2A1C-11CE-ADE5-00AA0044773D}'; - IID_ITransactionOptions: TGUID = '{3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD}'; - // =================================================================== - - // for version 1.5 of OLE DB: - //DBGUID_DBSQL : TGUID = '{c8b522df-5cf3-11ce-ade5-00aa0044773d}'; - - // otherwise: - DBGUID_DBSQL : TGUID = '{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}'; - DBGUID_DEFAULT : TGUID = '{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}'; - DBGUID_SQL : TGUID = '{C8B522D7-5CF3-11CE-ADE5-00AA0044773D}'; - - DBPROPSET_ROWSET : TGUID = '{C8B522BE-5CF3-11CE-ADE5-00AA0044773D}'; - - DB_S_ENDOFROWSET = $00040EC6; - -type - -// *********************************************************************// -// Interface: IDBInitialize -// GUID: {0C733A8B-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - IDBInitialize = interface(IUnknown) - ['{0C733A8B-2A1C-11CE-ADE5-00AA0044773D}'] - function Initialize: HResult; stdcall; - function Uninitialize: HResult; stdcall; - end; - -// *********************************************************************// -// Interface: IDBCreateCommand -// GUID: {0C733A1D-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - IDBCreateCommand = interface(IUnknown) - ['{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}'] - function CreateCommand(const punkOuter: IUnknown; const riid: TGUID; - out ppCommand: IUnknown): HResult; stdcall; - end; - - (*--- - { Safecall Version } - IDBCreateCommandSC = interface(IUnknown) - ['{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}'] - procedure CreateCommand(const punkOuter: IUnknown; const riid: TGUID; - out ppCommand: IUnknown); safecall; - end; - ---*) - -// *********************************************************************// -// Interface: IDBCreateSession -// GUID: {0C733A5D-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - IDBCreateSession = interface(IUnknown) - ['{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}'] - function CreateSession(const punkOuter: IUnknown; const riid: TGUID; - out ppDBSession: IUnknown): HResult; stdcall; - end; - - (*--- - { Safecall Version } - IDBCreateSessionSC = interface(IUnknown) - ['{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}'] - procedure CreateSession(const punkOuter: IUnknown; const riid: TGUID; - out ppDBSession: IUnknown); safecall; - end; - ---*) - -// *********************************************************************// -// Interface: IDataInitialize -// GUID: {2206CCB1-19C1-11D1-89E0-00C04FD7A829} -// *********************************************************************// - IDataInitialize = interface(IUnknown) - ['{2206CCB1-19C1-11D1-89E0-00C04FD7A829}'] - function GetDataSource(const pUnkOuter: IUnknown; dwClsCtx: DWORD; - pwszInitializationString: POleStr; const riid: TIID; - var DataSource: IUnknown): HResult; stdcall; - function GetInitializationString(const DataSource: IUnknown; - fIncludePassword: Boolean; out pwszInitString: POleStr): HResult; stdcall; - function CreateDBInstance(const clsidProvider: TGUID; - const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; - riid: TIID; var DataSource: IUnknown): HResult; stdcall; - function CreateDBInstanceEx(const clsidProvider: TGUID; - const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; - pServerInfo: PCoServerInfo; cmq: ULONG; rgmqResults: PMultiQI): HResult; stdcall; - function LoadStringFromStorage(pwszFileName: POleStr; - out pwszInitializationString: POleStr): HResult; stdcall; - function WriteStringToStorage(pwszFileName, pwszInitializationString: POleStr; - dwCreationDisposition: DWORD): HResult; stdcall; - end; - - (*--- - { Safecall Version } - IDataInitializeSC = interface(IUnknown) - ['{2206CCB1-19C1-11D1-89E0-00C04FD7A829}'] - procedure GetDataSource(const pUnkOuter: IUnknown; dwClsCtx: DWORD; - pwszInitializationString: POleStr; const riid: TIID; - var DataSource: IUnknown); safecall; - procedure GetInitializationString(const DataSource: IUnknown; - fIncludePassword: Boolean; out pwszInitString: POleStr); safecall; - procedure CreateDBInstance(const clsidProvider: TGUID; - const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; - riid: TIID; var DataSource: IUnknown); safecall; - procedure CreateDBInstanceEx(const clsidProvider: TGUID; - const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; - pServerInfo: PCoServerInfo; cmq: ULONG; rgmqResults: PMultiQI); safecall; - procedure LoadStringFromStorage(pwszFileName: POleStr; - out pwszInitializationString: POleStr); safecall; - procedure WriteStringToStorage(pwszFileName, pwszInitializationString: POleStr; - dwCreationDisposition: DWORD); safecall; - end; - ---*) - -// *********************************************************************// -// Interface: ICommand -// GUID: {0C733A63-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - ICommand = interface(IUnknown) - ['{0C733A63-2A1C-11CE-ADE5-00AA0044773D}'] - function Cancel: HResult; stdcall; - function Execute(const punkOuter: IUnknown; const riid: TGUID; - pParams: Pointer; // var pParams: DBPARAMS; - pcRowsAffected: PInteger; ppRowset: PIUnknown): HResult; stdcall; - function GetDBSession(const riid: TGUID; out ppSession: IUnknown): HResult; stdcall; - end; - - (* - { Safecall Version } - ICommandSC = interface(IUnknown) - ['{0C733A63-2A1C-11CE-ADE5-00AA0044773D}'] - procedure Cancel; safecall; - procedure Execute(const punkOuter: IUnknown; const riid: TGUID; var pParams: DBPARAMS; - pcRowsAffected: PInteger; ppRowset: PIUnknown); safecall; - procedure GetDBSession(const riid: TGUID; out ppSession: IUnknown); safecall; - end; - *) - -// *********************************************************************// -// Interface: ICommandText -// GUID: {0C733A27-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - ICommandText = interface(ICommand) - ['{0C733A27-2A1C-11CE-ADE5-00AA0044773D}'] - function GetCommandText(var pguidDialect: TGUID; - out ppwszCommand: PWideChar): HResult; stdcall; - function SetCommandText(rguidDialect: PGUID; - pwszCommand: PWideChar): HResult; stdcall; - end; - - (* - { Safecall Version } - ICommandTextSC = interface(ICommand) - ['{0C733A27-2A1C-11CE-ADE5-00AA0044773D}'] - procedure GetCommandText(var pguidDialect: TGUID; - out ppwszCommand: PWideChar); safecall; - procedure SetCommandText(rguidDialect: PGUID; - pwszCommand: PWideChar); safecall; - end; - *) - -// *********************************************************************// -// Interface: IRowset -// GUID: {0C733A7C-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - IRowset = interface(IUnknown) - ['{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}'] - function AddRefRows(cRows: UINT; rghRows: PUintArray; rgRefCounts: PUintArray; - rgRowStatus: PUintArray): HResult; stdcall; - function GetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall; - function GetNextRows(hReserved: HCHAPTER; lRowsOffset: Integer; cRows: Integer; - out pcRowsObtained: UINT; {var prghRows: PUintArray} prghRows: Pointer ): HResult; stdcall; - function ReleaseRows(cRows: UINT; rghRows: PUintArray; rgRowOptions, - rgRefCounts, rgRowStatus: PUintArray): HResult; stdcall; - function RestartPosition(hReserved: HCHAPTER): HResult; stdcall; - end; - - (* - { Safecall Version } - IRowsetSC = interface(IUnknown) - ['{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}'] - procedure AddRefRows(cRows: UINT; rghRows: PUintArray; rgRefCounts: PUintArray; - rgRowStatus: PUintArray); safecall; - procedure GetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall; - procedure GetNextRows(hReserved: HCHAPTER; lRowsOffset: Integer; cRows: Integer; - out pcRowsObtained: UINT; var prghRows: PUintArray); safecall; - procedure ReleaseRows(cRows: UINT; rghRows: PUintArray; rgRowOptions, - rgRefCounts, rgRowStatus: PUintArray); safecall; - procedure RestartPosition(hReserved: HCHAPTER); safecall; - end; - *) - -// *********************************************************************// -// Interface: IRowsetChange -// GUID: {0C733A05-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - IRowsetChange = interface(IUnknown) - ['{0C733A05-2A1C-11CE-ADE5-00AA0044773D}'] - function DeleteRows(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; - rgRowStatus: PUintArray): HResult; stdcall; - function SetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall; - function InsertRow(hReserved: HCHAPTER; HACCESSOR: HACCESSOR; pData: Pointer; - phRow: PHROW): HResult; stdcall; - end; - - (* - { Safecall Version } - IRowsetChangeSC = interface(IUnknown) - ['{0C733A05-2A1C-11CE-ADE5-00AA0044773D}'] - procedure DeleteRows(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; - rgRowStatus: PUintArray); safecall; - procedure SetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall; - procedure InsertRow(hReserved: HCHAPTER; HACCESSOR: HACCESSOR; pData: Pointer; - phRow: PHROW); safecall; - end; - *) - -// *********************************************************************// -// Interface: IRowsetUpdate -// GUID: {0C733A6D-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - DBPENDINGSTATUS = DWORD; - PDBPENDINGSTATUS = ^DBPENDINGSTATUS; - PPDBPENDINGSTATUS = ^PDBPENDINGSTATUS; - - DBROWSTATUS = UINT; - PDBROWSTATUS = ^DBROWSTATUS; - PPDBROWSTATUS = ^PDBROWSTATUS; - - IRowsetUpdate = interface(IRowsetChange) - ['{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}'] - function GetOriginalData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall; - function GetPendingRows(hReserved: HCHAPTER; dwRowStatus: DBPENDINGSTATUS; pcPendingRows: PUINT; - prgPendingRows: PPHROW; prgPendingStatus: PPDBPENDINGSTATUS): HResult; stdcall; - function GetRowStatus(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; - rgPendingStatus: PUintArray): HResult; stdcall; - function Undo(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRowsUndone: PUINT; - prgRowsUndone: PPHROW; prgRowStatus: PPDBROWSTATUS): HResult; stdcall; - function Update(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRows: PUINT; - prgRows: PPHROW; prgRowStatus: PPDBROWSTATUS): HResult; stdcall; - end; - - (* - { Safecall Version } - IRowsetUpdateSC = interface(IRowsetChange) - ['{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}'] - procedure GetOriginalData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall; - procedure GetPendingRows(hReserved: HCHAPTER; dwRowStatus: DBPENDINGSTATUS; pcPendingRows: PUINT; - prgPendingRows: PPHROW; prgPendingStatus: PPDBPENDINGSTATUS); safecall; - procedure GetRowStatus(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; - rgPendingStatus: PUintArray); safecall; - procedure Undo(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRowsUndone: PUINT; - prgRowsUndone: PPHROW; prgRowStatus: PPDBROWSTATUS); safecall; - procedure Update(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRows: PUINT; - prgRows: PPHROW; prgRowStatus: PPDBROWSTATUS); safecall; - end; - *) - -// *********************************************************************// -// Interface: ICommandProperties -// GUID: {0C733A79-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - - DBPROPID = UINT; - PDBPROPID = ^DBPROPID; - PDBPropIDArray = ^TDBPropIDArray; - TDBPropIDArray = array[0..MAXBOUND] of DBPROPID; - - PDBIDGuid = ^TDBIDGuid; - DBIDGUID = record - case Integer of - 0: (guid: TGUID); - 1: (pguid: ^TGUID); - end; - TDBIDGuid = DBIDGUID; - - PDBIDName = ^TDBIDName; - DBIDNAME = record - case Integer of - 0: (pwszName: PWideChar); - 1: (ulPropid: UINT); - end; - TDBIDName = DBIDNAME; - - DBPROPOPTIONS = UINT; - DBPROPSTATUS = UINT; - PPDBID = ^PDBID; - PDBID = ^DBID; - DBID = packed record - uGuid: DBIDGUID; - eKind: DBKIND; - uName: DBIDNAME; - end; - TDBID = DBID; - - PDBProp = ^TDBProp; - DBPROP = packed record - dwPropertyID: DBPROPID; - dwOptions: DBPROPOPTIONS; - dwStatus: DBPROPSTATUS; - colid: DBID; - vValue: tagVariant; // OleVariant; - end; - TDBProp = DBPROP; - - PDBPropArray = ^TDBPropArray; - TDBPropArray = array[0..MAXBOUND] of TDBProp; - - PPDBPropSet = ^PDBPropSet; - PDBPropSet = ^TDBPropSet; - DBPROPSET = packed record - rgProperties: PDBPropArray; - cProperties: UINT; - guidPropertySet: TGUID; - end; - TDBPropSet = DBPROPSET; - - PDBPropIDSet = ^TDBPropIDSet; - DBPROPIDSET = packed record - rgPropertyIDs: PDBPropIDArray; - cPropertyIDs: UINT; - guidPropertySet: TGUID; - end; - TDBPropIDSet = DBPROPIDSET; - - PDBPropIDSetArray = ^TDBPropIDSetArray; - TDBPropIDSetArray = array[0..MAXBOUND] of TDBPropIDSet; - - PDBPropSetArray = ^TDBPropSetArray; - TDBPropSetArray = array[0..MAXBOUND] of TDBPropSet; - - ICommandProperties = interface(IUnknown) - ['{0C733A79-2A1C-11CE-ADE5-00AA0044773D}'] - function GetProperties(cPropertyIDSets: UINT; rgPropertyIDSets: PDBPropIDSetArray; - var pcPropertySets: UINT; out prgPropertySets: PDBPropSet): HResult; stdcall; - function SetProperties(cPropertySets: UINT; rgPropertySets: PDBPropSetArray): HResult; stdcall; - end; - - (* - { Safecall Version } - ICommandPropertiesSC = interface(IUnknown) - ['{0C733A79-2A1C-11CE-ADE5-00AA0044773D}'] - procedure GetProperties(cPropertyIDSets: UINT; rgPropertyIDSets: PDBPropIDSetArray; - var pcPropertySets: UINT; out prgPropertySets: PDBPropSet); safecall; - procedure SetProperties(cPropertySets: UINT; rgPropertySets: PDBPropSetArray); safecall; - end; - *) - - PDBIDArray = ^TDBIDArray; - TDBIDArray = array[0..MAXBOUND] of TDBID; - - PDBColumnInfo = ^TDBColumnInfo; - DBCOLUMNINFO = packed record - pwszName: PWideChar; - pTypeInfo: ITypeInfo; - iOrdinal: UINT; - dwFlags: DBCOLUMNFLAGS; - ulColumnSize: UINT; - wType: DBTYPE; - bPrecision: Byte; - bScale: Byte; - columnid: DBID; - end; - TDBColumnInfo = DBCOLUMNINFO; - - PColumnInfo = ^TColumnInfoArray; - TColumnInfoArray = array[ 0..MAXBOUND ] of TDBColumnInfo; - -// *********************************************************************// -// Interface: IColumnsInfo -// GUID: {0C733A11-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - IColumnsInfo = interface(IUnknown) - ['{0C733A11-2A1C-11CE-ADE5-00AA0044773D}'] - function GetColumnInfo(var pcColumns: UINT; out prgInfo: PDBColumnInfo; - out ppStringsBuffer: PWideChar): HResult; stdcall; - function MapColumnIDs(cColumnIDs: UINT; rgColumnIDs: PDBIDArray; - rgColumns: PUintArray): HResult; stdcall; - end; - - (* - { Safecall Version } - IColumnsInfoSC = interface(IUnknown) - ['{0C733A11-2A1C-11CE-ADE5-00AA0044773D}'] - procedure GetColumnInfo(var pcColumns: UINT; out prgInfo: PDBColumnInfo; - out ppStringsBuffer: PWideChar); safecall; - procedure MapColumnIDs(cColumnIDs: UINT; rgColumnIDs: PDBIDArray; - rgColumns: PUINTArray); safecall; - end; - *) - - PDBBindExt = ^TDBBindExt; - DBBINDEXT = packed record - pExtension: PByte; - ulExtension: UINT; - end; - TDBBindExt = DBBINDEXT; - - PDBObject = ^TDBObject; - DBOBJECT = packed record - dwFlags: UINT; - iid: TGUID; - end; - TDBObject = DBOBJECT; - - PDBBinding = ^TDBBinding; - DBBINDING = packed record - iOrdinal: UINT; - obValue: UINT; - obLength: UINT; - obStatus: UINT; - pTypeInfo: Pointer; //ITypeInfo; (reserved, should be nil) - pObject: PDBObject; - pBindExt: PDBBindExt; - dwPart: DBPART; - dwMemOwner: DBMEMOWNER; - eParamIO: DBPARAMIO; - cbMaxLen: UINT; - dwFlags: UINT; - wType: DBTYPE; - bPrecision: Byte; - bScale: Byte; - end; - TDBBinding = DBBINDING; - - PDBBindingArray = ^TDBBindingArray; - TDBBindingArray = array[0..MAXBOUND] of TDBBinding; - -const - DBTYPE_EMPTY = $00000000; - DBTYPE_NULL = $00000001; - DBTYPE_I2 = $00000002; - DBTYPE_I4 = $00000003; - DBTYPE_R4 = $00000004; - DBTYPE_R8 = $00000005; - DBTYPE_CY = $00000006; - DBTYPE_DATE = $00000007; - DBTYPE_BSTR = $00000008; - DBTYPE_IDISPATCH = $00000009; - DBTYPE_ERROR = $0000000A; - DBTYPE_BOOL = $0000000B; - DBTYPE_VARIANT = $0000000C; - DBTYPE_IUNKNOWN = $0000000D; - DBTYPE_DECIMAL = $0000000E; - DBTYPE_UI1 = $00000011; - DBTYPE_ARRAY = $00002000; - DBTYPE_BYREF = $00004000; - DBTYPE_I1 = $00000010; - DBTYPE_UI2 = $00000012; - DBTYPE_UI4 = $00000013; - DBTYPE_I8 = $00000014; - DBTYPE_UI8 = $00000015; - DBTYPE_FILETIME = $00000040; - DBTYPE_GUID = $00000048; - DBTYPE_VECTOR = $00001000; - DBTYPE_RESERVED = $00008000; - DBTYPE_BYTES = $00000080; - DBTYPE_STR = $00000081; - DBTYPE_WSTR = $00000082; - DBTYPE_NUMERIC = $00000083; - DBTYPE_UDT = $00000084; - DBTYPE_DBDATE = $00000085; - DBTYPE_DBTIME = $00000086; - DBTYPE_DBTIMESTAMP = $00000087; - DBTYPE_DBFILETIME = $00000089; - DBTYPE_PROPVARIANT = $0000008A; - DBTYPE_VARNUMERIC = $0000008B; - -type -// *********************************************************************// -// Interface: IAccessor -// GUID: {0C733A8C-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - IAccessor = interface(IUnknown) - ['{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}'] - function AddRefAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT): HResult; stdcall; - function CreateAccessor(dwAccessorFlags: UINT; cBindings: UINT; rgBindings: PDBBindingArray; - cbRowSize: UINT; var phAccessor: HACCESSOR; rgStatus: PUintArray): HResult; stdcall; - function GetBindings(HACCESSOR: HACCESSOR; pdwAccessorFlags: PUINT; var pcBindings: UINT; - out prgBindings: PDBBinding): HResult; stdcall; - function ReleaseAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT): HResult; stdcall; - end; - - (* - { Safecall Version } - IAccessorSC = interface(IUnknown) - ['{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}'] - procedure AddRefAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT); safecall; - procedure CreateAccessor(dwAccessorFlags: UINT; cBindings: UINT; rgBindings: PDBBindingArray; - cbRowSize: UINT; var phAccessor: HACCESSOR; rgStatus: PUintArray); safecall; - procedure GetBindings(HACCESSOR: HACCESSOR; pdwAccessorFlags: PUINT; var pcBindings: UINT; - out prgBindings: PDBBinding); safecall; - procedure ReleaseAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT); safecall; - end; - *) - -// Begin Added By ECM !!! ======================================================= - PBoid = ^TBoid; - BOID = packed record - rgb_: array[0..15] of Byte; - end; - TBoid = BOID; - - PXactTransInfo = ^TXactTransInfo; - XACTTRANSINFO = packed record - uow: BOID; - isoLevel: Integer; - isoFlags: UINT; - grfTCSupported: UINT; - grfRMSupported: UINT; - grfTCSupportedRetaining: UINT; - grfRMSupportedRetaining: UINT; - end; - TXactTransInfo = XACTTRANSINFO; - - PXactOpt = ^TXactOpt; - XACTOPT = packed record - ulTimeout: UINT; - szDescription: array[0..39] of Shortint; - end; - TXActOpt = XACTOPT; - -// *********************************************************************// -// Interface: ITransactionOptions -// GUID: {3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD} -// *********************************************************************// - ITransactionOptions = interface(IUnknown) - ['{3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD}'] - function SetOptions(var pOptions: XACTOPT): HResult; stdcall; - function GetOptions(var pOptions: XACTOPT): HResult; stdcall; - end; - -// *********************************************************************// -// Interface: ITransaction -// GUID: {0FB15084-AF41-11CE-BD2B-204C4F4F5020} -// *********************************************************************// - ITransaction = interface(IUnknown) - ['{0FB15084-AF41-11CE-BD2B-204C4F4F5020}'] - function Commit(fRetaining: BOOL; grfTC: UINT; grfRM: UINT): HResult; stdcall; - function Abort(pboidReason: PBOID; fRetaining: BOOL; fAsync: BOOL): HResult; stdcall; - function GetTransactionInfo(out pinfo: XACTTRANSINFO): HResult; stdcall; - end; - -// *********************************************************************// -// Interface: ITransactionLocal -// GUID: {0C733A5F-2A1C-11CE-ADE5-00AA0044773D} -// *********************************************************************// - ITransactionLocal = interface(ITransaction) - ['{0C733A5F-2A1C-11CE-ADE5-00AA0044773D}'] - function GetOptionsObject(out ppOptions: ITransactionOptions): HResult; stdcall; - function StartTransaction(isoLevel: Integer; isoFlags: UINT; - const pOtherOptions: ITransactionOptions; pulTransactionLevel: PUINT): HResult; stdcall; - end; - -const - XACTTC_SYNC_PHASEONE = $00000001; - XACTTC_SYNC_PHASETWO = $00000002; - XACTTC_SYNC = $00000002; - XACTTC_ASYNC_PHASEONE = $00000004; - XACTTC_ASYNC = $00000004; - -// End Added By ECM !!! ========================================================= - -// Begin Added By azsd !!! ====================================================== -(* -type - PDbNumeric = ^tagDB_NUMERIC; - tagDB_NUMERIC = packed record - precision: Byte; - scale: Byte; - sign: Byte; - val: array[0..15] of Byte; - end; -*) -// End Added By azsd !!! ======================================================== - -{============= This part of code is designed by me ================} -type - PDBBINDSTATUSARRAY = ^TDBBINDSTATUSARRAY; - TDBBINDSTATUSARRAY = array[ 0..MAXBOUND ] of DBBINDSTATUS; - -//'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' -// TDataSource - a connection to data base -//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, -type - PDataSource = ^TDataSource; - TDataSource = object( TObj ) - {* This object provides a connection with data base. You create it using - NewDataSource function and passing a connection string to it. The object - is initializing immediately after creating. You can get know if the - connection established successfully reading Intitialized property. } - private - fSessions: PList; - fIDBInitialize: IDBInitialize; - FInitialized: Boolean; - protected - function Initialize( const Params: String ): Boolean; - public - constructor Create; - {* Do not call this constructor. Use function NewDataSource instead. } - destructor Destroy; virtual; - {* Do not call this destructor. Use Free method instead. When TDataSource - object is destroyed, all its sessions (and consequensly, all queries) - are freed automatically. } - property Initialized: Boolean read FInitialized; - {* Returns True, if the connection with database is established. Mainly, - it is not necessary to analizy this flag. If any error occure during - initialization, CheckOle halts further execution. (But You can use - another error handler, which does not stop the application). } - end; - -function NewDataSource( const Params: String ): PDataSource; -{* Creates data source objects and initializes it. Pass a connection - string as a parameter, which determines used provider, database - location, user identification and other parameters. See demo provided - or/and read spicifications from database software vendors, which - parameters to pass. } - -//'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' -// TSession - transaction session in a connection -//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, -type - PSession = ^TSession; - TSession = object( TObj ) - {* This object is intended to provide session transactions. It always - must be created as a "child" of TDataSource object, and it owns by - query objects (of type TQuery). For each TDataSource object, it is - possible to create several TSession objects, and for each session, - several TQuery objects can exist. } - private - fQueryList: PList; - fDataSource: PDataSource; - fCreateCommand: IDBCreateCommand; - - // Added By ECM !!! ================== - fTransaction: ITransaction; - fTransactionLocal: ITransactionLocal; - // =================================== - - protected - public - constructor Create; - {* } - destructor Destroy; virtual; - {* Do not call directly, call Free method instead. When TSession object is - destroyed, all it child queries are freed automatically. } - - // Added By ECM !!! ==================================== - function StartTransaction(isoLevel: Integer): HRESULT; - function Commit(Retaining: BOOL): HRESULT; - function Rollback(Retaining: BOOL): HRESULT; - function Active: Boolean; - // ===================================================== - - property DataSource: PDataSource read fDataSource; - {* Returns a pointer to owner TDataSource object. } - end; - -function NewSession( ADataSource: PDataSource ): PSession; -{* Creates session object owned by ADataSource (this last must exist). } - -//'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' -// TQuery - a command and resulting rowset(s) -//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, -type - TRowsetMode = ( rmUpdateImmediate, rmUpdateDelayed, rmReadOnly ); - TFieldType = ( ftInteger, ftReal, ftString, ftDate, ftLargeInt, ftOther ); - - PQuery = ^TQuery; - TQuery = object( TObj ) - {* This is the most important object to work with database. It is always - must be created as a "child" of TSession object, and allows to perform - commands, open rowsets, scroll it, update and so on. } - private - fSession: PSession; - fText: String; - fCommand: ICommandText; - fCommandProps: ICommandProperties; - fRowsAffected: Integer; - fRowSet: IRowset; - fRowSetChg: IRowsetChange; - fRowSetUpd: IRowsetUpdate; - fColCount: UINT; - fColInfo: PColumnInfo; - fColNames: PWideChar; - fBindings: PDBBindingArray; - fBindStatus: PDBBINDSTATUSARRAY; - fRowSize: Integer; - fAccessor: HACCESSOR; - fRowHandle: THandle; - fRowBuffers: PList; - fEOF: Boolean; - fCurIndex: Integer; - fChanged: Boolean; - fMode: TRowsetMode; - procedure SetText(const Value: String); - function GetRowCount: Integer; - function GetColNames(Idx: Integer): String; - procedure SetCurIndex(const Value: Integer); - function GetRowsKnown: Integer; - function GetStrField(Idx: Integer): String; - procedure SetStrField(Idx: Integer; const Value: String); - function GetIntField(Idx: Integer): Integer; - procedure SetIntField(Idx: Integer; const Value: Integer); - function GetFltField(Idx: Integer): Double; - procedure SetFltField(Idx: Integer; const Value: Double); - function GetDField(Idx: Integer): TDateTime; - procedure SetDField(Idx: Integer; const Value: TDateTime); - function FieldPtr( Idx: Integer ): Pointer; - function Changed( Idx: Integer ): Pointer; - function GetColByName(Name: String): Integer; - function GetSFieldByName(const Name: String): String; - procedure SetSFieldByName(const Name: String; const Value: String); - function GetIFieldByName(const Name: String): Integer; - procedure SetIFieldByName(const Name: String; Value: Integer); - function GetRFieldByName(const Name: String): Double; - procedure SetRFieldByName(const Name: String; const Value: Double); - function GetDFlfByName(const Name: String): TDateTime; - procedure SetDFldByName(const Name: String; const Value: TDateTime); - function GetColType(Idx: Integer): TFieldType; - function GetColTypeByName(const Name: String): TFieldType; - function GetIsNull(Idx: Integer): Boolean; - procedure SetIsNull(Idx: Integer; const Value: Boolean); - function GetIsNullByName(const Name: String): Boolean; - procedure SetIsNullByName(const Name: String; const Value: Boolean); - function GetFByNameAsStr(const Name: String): String; - function GetFieldAsStr(Idx: Integer): String; - procedure SetFByNameFromStr(const Name, Value: String); - procedure SetFieldFromStr(Idx: Integer; const Value: String); - function GetI64Field(Idx: Integer): Int64; - function GetI64FldByName(const Name: String): Int64; - procedure SetI64Field(Idx: Integer; const Value: Int64); - procedure SetI64FldByName(const Name: String; const Value: Int64); - function GetFixupNumeric(Idx: Integer): Int64; //add by azsd - function GetRawType(Idx: Integer): DWORD; - function GetRawTypeByName(const Name: String): DWORD; - function GetFieldAsHex(Idx: Integer): Pointer; - function GetFieldByNameAsHex(const Name: String): Pointer; - protected - fDelList: PList; - procedure ClearRowset; - procedure ReleaseHandle; - procedure FetchData; - procedure NextWOFetch( Skip: Integer ); - public - destructor Destroy; virtual; - {* Do not call the destructor directly, call method Free instead. When - "parent" TSession object is destroyed, all queries owned by the session - are destroyed automatically. } - property Session: PSession read fSession; - {* Returns owner session object. } - property Text: String read FText write SetText; - {* Query command text. When You change it, currently opened rowset (if any) - is closed, so there are no needs to call Close method before preparing - for new command. Current version does not support passing "parameters", - so include all values into Text as a part of string. } - procedure Close; - {* Closes opened rowset if any. It is not necessary to call close after - Execute. Also, rowset is closed automatically when another value is - assigned to Text property. } - procedure Execute; - {* Call this method to execute command (stored in Text), which does not - open a rowset (thus is, "insert", "delete", and "update" SQL statements - do so). } - procedure Open; - {* Call this method for executing command, which opens a rowset (table of - data). This can be "select" SQL statement, or call to stored procedure, - which returns result in a table. } - property RowCount: Integer read GetRowCount; - {* For commands, such as "insert", "delete" or "update" SQL statements, - this property returns number of rows affected by a command. For "select" - statement performed using Open method, this property should return - a number of rows selected. By for (the most) providers, this value is - unknown for first time (-1 is returned). To get know how much rows are - in returned rowset, method Last should be called first. But for large - data returned this is not efficient way, because actually a loop - "while not EOF do Next" is performed to do so. - |
- Tip: to get count of rows, You can call another query, which executes - "select count(*) where..." SQL statement with the same conditions. } - property RowsKnown: Integer read GetRowsKnown; - {* Returns actual number or selected rows, if this is "known" value, or number - of rows already fetched. } - property ColCount: UINT read fColCount; - {* Returns number of columns in opened rowset. } - property ColNames[ Idx: Integer ]: String read GetColNames; - {* Return names of columns. } - property ColByName[ Name: String ]: Integer read GetColByName; - {* Returns column index by name. Comparing of names is ANSI and case insensitive. } - property ColType[ Idx: Integer ]: TFieldType read GetColType; - {* } - property ColTypeByName[ const Name: String ]: TFieldType read GetColTypeByName; - {* } - function FirstColumn: Integer; - {* by Alexander Shakhaylo. To return an index of the first column, - containing actual data. (for .mdb, the first can contain special - control information, but not for .dbf) } - property RawType[ Idx: Integer ]: DWORD read GetRawType; - {*} - property RawTypeByName[ const Name: String ]: DWORD read GetRawTypeByName; - {*} - property EOF: Boolean read fEOF; - {* Returns True, if end of data is achived (usually after calling Next - or Prev method, or immediately after Open, if there are no rows in opened - rowset). } - procedure First; - {* Resets a position to the start of rowset. This method is called - automatically when Open is called successfully. } - procedure Next; - {* Moves position to the next row if possible. If EOF achived, a position - is not changed. } - procedure Prev; - {* Moves position to a previous row (but if CurIndex > 0). } - procedure Last; - {* Moves position to the last row. This method can be unefficient for - large datasets, because implemented as a loop where method Next is - called repeteadly, while EOF is not achieved. } - property Mode: TRowsetMode read fMode write fMode; - {* } - procedure Post; - {* Applyes changes made in a record, writing changed row to database table. } - procedure Delete; - {* Deletes a row. In rmUpdateDelayed Mode, rows are only added to a list - for later deleting it when Update called. } - procedure Update; - {* Allows to apply all updates far later, not when Post method is called. - To use TQuery in this manner, its Mode should be set to rmUpdateDelayed. } - property CurIndex: Integer read fCurIndex write SetCurIndex; - {* Index of current row. It is possible to change it directly even if - specified row is not yet fetched. But check at least what new value is - stored in CurIndex after such assignment. } - property SField[ Idx: Integer ]: String read GetStrField write SetStrField; - {* Access to a string field by index. You should be sure, that a field - has string type. } - property SFieldByName[ const Name: String ]: String read GetSFieldByName write SetSFieldByName; - {* } - property IField[ Idx: Integer ]: Integer read GetIntField write SetIntField; - {* Access to a integer field by index. You should be sure, that a field - has integer type or compatible. } - property IFieldByName[ const Name: String ]: Integer read GetIFieldByName write SetIFieldByName; - {* } - property LField[ Idx: Integer ]: Int64 read GetI64Field write SetI64Field; - {* } - property LFieldByName[ const Name: String ]: Int64 read GetI64FldByName write SetI64FldByName; - {* } - property RField[ Idx: Integer ]: Double read GetFltField write SetFltField; - {* Access to a real (Double) field by index. You should be sure, that a field - has numeric (with floating decimal point) type. } - property RFieldByName[ const Name: String ]: Double read GetRFieldByName write SetRFieldByName; - {* } - property DField[ Idx: Integer ]: TDateTime read GetDField write SetDField; - {* } - property DFieldByName[ const Name: String ]: TDateTime read GetDFlfByName write SetDFldByName; - {* } - property IsNull[ Idx: Integer ]: Boolean read GetIsNull write SetIsNull; - {* } - property IsNullByName[ const Name: String ]: Boolean read GetIsNullByName write SetIsNullByName; - {* } - property FieldAsStr[ Idx: Integer ]: String read GetFieldAsStr write SetFieldFromStr; - {* } - property FieldByNameAsStr[ const Name: String ]: String read GetFByNameAsStr write SetFByNameFromStr; - {* } - property FieldAsHex[ Idx: Integer ]: Pointer read GetFieldAsHex; - {* Access to field data directly. If you change field data inplace, call - MarkRecordChanged by yourself. If field IsNull, data found at the address - provided have no sense. } - property FieldByNameAsHex[ const Name: String ]: Pointer read GetFieldByNameAsHex; - {* See FieldByNameAsHex. } - procedure MarkFieldChanged( Idx: Integer ); - {* See also MarkRecordChangedByName. } - procedure MarkFieldChangedByName( const Name: String ); - {* When record field changed directly (using FieldAsHex property, for ex.), - use this method to signal to record set container, that record is changed, - and to ensure that field no more marked as null. } - end; - -function NewQuery( Session: PSession ): PQuery; -{* Creates query object. } - -// Error handling routines: - -function CheckOLE( Rslt: HResult ): Boolean; -function CheckOLEex( Rslt: HResult; const OKResults: array of HResult ): Boolean; -procedure DummyOleError( Result: HResult ); -var OleError: procedure( Result: HResult ) = DummyOleError; - -implementation - -type - PDBNumeric = ^TDBNumeric; - TDBNUMERIC = packed record - precision: Byte; - scale: Byte; - sign: Byte; - val: array[0..15] of Byte; - end; - - PDBVarNumeric = ^TDBVarNumeric; - TDBVARNUMERIC = packed record - precision: Byte; - scale: ShortInt; - sign: Byte; - val: ^Byte; - end; - - PDBDate = ^TDBDate; - TDBDATE = packed record - year: Smallint; - month: Word; - day: Word; - end; - - PDBTime = ^TDBTIME; - TDBTIME = packed record - hour: Word; - minute: Word; - second: Word; - end; - - PDBTimeStamp = ^TDBTimeStamp; - TDBTIMESTAMP = packed record - year: Smallint; - month: Word; - day: Word; - hour: Word; - minute: Word; - second: Word; - fraction: UINT; - end; - -var fIMalloc: IMalloc = nil; - -(* procedure DummyOleError( Result: HResult ); -begin - MsgOK( 'OLE DB error ' + Int2Hex( Result, 8 ) ); - Halt; -end; *) - -procedure DummyOleError( Result: HResult ); -begin - raise Exception.Create( e_Custom, 'OLE DB error ' + Int2Hex( Result, 8 ) ); -end; - -function CheckOLE( Rslt: HResult ): Boolean; -begin - Result := Rslt = 0; - if not Result then - OleError( Rslt ); -end; - -function CheckOLEex( Rslt: HResult; const OKResults: array of HResult ): Boolean; -var I: Integer; -begin - Result := TRUE; - for I := Low( OKResults ) to High( OKResults ) do - if Rslt = OKResults[ I ] then Exit; - Result := FALSE; - OleError( Rslt ); -end; - -{ TDataSource } - -function NewDataSource( const Params: String ): PDataSource; -begin - new( Result, Create ); - Result.Initialize( Params ); -end; - -constructor TDataSource.Create; -var clsid: TCLSID; -begin - inherited; - fSessions := NewList; - //if CheckOLEex( CoInitialize( nil ), [ S_OK, S_FALSE ] ) then - OleInit; - if CheckOLE( CoGetMalloc( MEMCTX_TASK, fIMalloc ) ) then - if CheckOLE( CLSIDFromProgID( 'SQLOLEDB', clsid ) ) then - CheckOLE( CoCreateInstance( clsid, nil, CLSCTX_INPROC_SERVER, - IID_IDBInitialize, fIDBInitialize ) ); -end; - -destructor TDataSource.Destroy; -var I: Integer; -begin - for I := fSessions.Count - 1 downto 0 do - PObj( fSessions.Items[ I ] ).Free; - fSessions.Free; - if Initialized then - CheckOLE( fIDBInitialize.UnInitialize ); - OleUnInit; - inherited; -end; - -function TDataSource.Initialize( const Params: String ): Boolean; -var DI: IDataInitialize; - Unk: IUnknown; -begin - Result := FALSE; - if Initialized then - begin - Result := TRUE; - Exit; - end; - if CheckOLE( CoCreateInstance( CLSID_MSDAINITIALIZE, nil, - CLSCTX_ALL, IID_IDataInitialize, DI ) ) then - if CheckOLE( DI.GetDataSource( nil, CLSCTX_ALL, StringToOleStr( Params ), - IID_IDBInitialize, Unk ) ) then - if CheckOLE( Unk.QueryInterface( IID_IDBInitialize, fIDBInitialize ) ) then - if CheckOLE( fIDBInitialize.Initialize ) then - begin - Result := TRUE; - FInitialized := Result; - end; -end; - -{ TSession } - -function NewSession( ADataSource: PDataSource ): PSession; -var CreateSession: IDBCreateSession; - Unk: IUnknown; -begin - new( Result, Create ); - Result.fDataSource := ADataSource; - ADataSource.fSessions.Add( Result ); - // Modified by ECM !!! =============================================================================== - if CheckOLE( ADataSource.fIDBInitialize.QueryInterface( IID_IDBCreateSession, CreateSession ) ) then begin - CheckOLE( CreateSession.CreateSession( nil, IID_IDBCreateCommand, - IUnknown( Result.fCreateCommand ) ) ); - - Unk := Result.fCreateCommand; - if Assigned(Unk) then begin - CheckOLE(Unk.QueryInterface(IID_ITransaction,Result.fTransaction)); - CheckOLE(Unk.QueryInterface(IID_ITransactionLocal,Result.fTransactionLocal)); - end; - end; - // ================================================================================================= -end; - -// Added By ECM !!! ============================================== -function TSession.Active: Boolean; -var - xinfo: TXactTransInfo; - Ret: HRESULT; -begin - if not Assigned(fTransaction) then Result := FALSE - else begin - FillChar(xinfo,SizeOf(xinfo),0); - Ret := fTransaction.GetTransactionInfo(xinfo); - Result := Ret = S_OK; - CheckOLE(Ret); - end; -end; - -function TSession.Commit(Retaining: BOOL): HRESULT; -begin - Assert(Assigned(fTransaction)); - Result := fTransaction.Commit(Retaining,XACTTC_SYNC,0); - CheckOLE(Result); -end; -// =============================================================== - -constructor TSession.Create; -begin - inherited; - fQueryList := NewList; -end; - -destructor TSession.Destroy; -var I: Integer; -begin - for I := fQueryList.Count - 1 downto 0 do - PObj( fQueryList.Items[ I ] ).Free; - fQueryList.Free; - I := fDataSource.fSessions.IndexOf( @Self ); - fDataSource.fSessions.Delete( I ); - // Add By ECM !!! ================ - // if Active then Rollback(FALSE); - //================================ - fCreateCommand := nil; - inherited; -end; - -// Added By ECM !!! =============================================== -function TSession.Rollback(Retaining: BOOL): HRESULT; -begin - Assert(Assigned(fTransaction)); - Result := fTransaction.Abort(nil,Retaining,FALSE); - CheckOLE(Result); -end; - -function TSession.StartTransaction(isoLevel: Integer): HRESULT; -begin - Assert(Assigned(fTransactionLocal)); - Result := fTransactionLocal.StartTransaction(isoLevel,0,nil,nil); - CheckOLE(Result); -end; -// ================================================================ - -{ TQuery } - -function NewQuery( Session: PSession ): PQuery; -begin - new( Result, Create ); - Result.fSession := Session; - Session.fQueryList.Add( Result ); - CheckOLE( Session.fCreateCommand.CreateCommand( nil, IID_ICommandText, - IUnknown( Result.fCommand ) ) ); -end; - -function TQuery.Changed( Idx: Integer ): Pointer; -begin - fChanged := TRUE; - Result := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + - fBindings[ Idx ].obStatus ); - PDWORD( Result )^ := 0; // set to NOT NULL -end; - -procedure TQuery.ClearRowset; -var I: Integer; - AccessorIntf: IAccessor; -begin - ReleaseHandle; - - if fAccessor <> 0 then - begin - if CheckOLE( fRowSet.QueryInterface( IID_IAccessor, AccessorIntf ) ) then - AccessorIntf.ReleaseAccessor( fAccessor, nil ); - fAccessor := 0; - end; - - if fRowBuffers <> nil then - begin - for I := fRowBuffers.Count - 1 downto 0 do - FreeMem( fRowBuffers.Items[ I ] ); - fRowBuffers.Free; - fRowBuffers := nil; - end; - fRowSize := 0; - - if fBindings <> nil then - begin - //for I := 0 to fColCount - 1 do - // fBindings[ I ].pTypeInfo := nil; - FreeMem( fBindings ); - fBindings := nil; - FreeMem( fBindStatus ); - fBindStatus := nil; - end; - - if fColInfo <> nil then - fIMalloc.Free( fColInfo ); - fColInfo := nil; - - if fColNames <> nil then - fIMalloc.Free( fColNames ); - fColNames := nil; - - fColCount := 0; - fRowSetUpd := nil; - fRowSet := nil; - fRowSetChg := nil; - fRowsAffected := 0; - - fEOF := TRUE; -end; - -procedure TQuery.Close; -begin - Update; - ClearRowset; -end; - -procedure TQuery.Delete; -var Params, Results: array of DWORD; -begin - //if fRowHandle = 0 then Exit; - CASE fMode OF - rmUpdateImmediate: - begin - SetLength( Results, 1 ); - SetLength( Params, 1 ); - Params[ 0 ] := fRowHandle; - CheckOLE( fRowSetUpd.DeleteRows( 0, 1, @ Params[ 0 ], @ Results[ 0 ] ) ); - end; - rmUpdateDelayed: - begin - if fDelList = nil then - fDelList := NewList; - fDelList.Add( Pointer( fRowHandle ) ); - end; - END; -end; - -destructor TQuery.Destroy; -var I: Integer; -begin - Close; //ClearRowset; - I := fSession.fQueryList.IndexOf( @Self ); - if I >= 0 then - fSession.fQueryList.Delete( I ); - fText := ''; - fCommandProps := nil; - fCommand := nil; - fDelList.Free; - inherited; -end; - -procedure TQuery.Execute; -begin - ClearRowset; - // first set txt to fCommand just before execute - if CheckOLE( fCommand.SetCommandText( @DBGUID_DBSQL, StringToOleStr( fText ) ) ) then - CheckOLE( fCommand.Execute( nil, IID_NULL, nil, @fRowsAffected, nil ) ); -end; - -procedure TQuery.FetchData; -var Buffer: Pointer; -begin - if fRowHandle = 0 then - Exit; - if fRowBuffers.Items[ fCurIndex ] = nil then - begin - GetMem( Buffer, fRowSize ); - FillChar( Buffer^, fRowSize, 0 ); //fixup the varnumberic random bytes by azsd - fRowBuffers.Items[ fCurIndex ] := Buffer; - CheckOLE( fRowSet.GetData( fRowHandle, fAccessor, fRowBuffers.Items[ fCurIndex ] ) ); - end; -end; - -function TQuery.FieldPtr(Idx: Integer): Pointer; -begin - if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then - Result := nil - else - Result := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + - fBindings[ Idx ].obValue ); -end; - -procedure TQuery.First; -begin - if fCurIndex = 0 then Exit; - ReleaseHandle; - fCurIndex := -1; - if CheckOLE( fRowSet.RestartPosition( 0 ) ) then - begin - fEOF := FALSE; - Next; - end; -end; - -function TQuery.FirstColumn: Integer; -var i: integer; -begin - Result := -1; - for i := 0 to fColCount - 1 do begin - if fBindings[i].iOrdinal > 0 then begin - Result := i; - exit; - end; - end; -end; - -function TQuery.GetColByName(Name: String): Integer; -var I: Integer; -begin - Result := -1; - for I := 0 to fColCount - 1 do - begin - if AnsiCompareStrNoCase( Name, ColNames[ I ] ) = 0 then - begin - Result := I; - break; - end; - end; -end; - -function TQuery.GetColNames(Idx: Integer): String; -begin - Result := fColInfo[ Idx ].pwszName; -end; - -function TQuery.GetColType(Idx: Integer): TFieldType; -begin - Result := ftOther; - if fBindings = nil then Exit; - case fBindings[ Idx ].wType of - DBTYPE_I1, DBTYPE_I2, DBTYPE_I4, DBTYPE_BOOL, - DBTYPE_UI1, DBTYPE_UI2, DBTYPE_UI4 : Result := ftInteger; - DBTYPE_I8, DBTYPE_UI8 : Result := ftLargeInt; - DBTYPE_BSTR, DBTYPE_WSTR, DBTYPE_STR: Result := ftString; - DBTYPE_R4, DBTYPE_R8, DBTYPE_CY, - DBTYPE_NUMERIC, DBTYPE_VARNUMERIC, - DBTYPE_DECIMAL : Result := ftReal;// no need new cate here,moved to GetFieldAsStr - DBTYPE_DATE, DBTYPE_FILETIME, //DBTYPE_DBFILETIME, - DBTYPE_DBDATE, DBTYPE_DBTIME, - DBTYPE_DBTIMESTAMP : Result := ftDate; - else Result := ftOther; - end; -end; - -function TQuery.GetColTypeByName(const Name: String): TFieldType; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >= 0, 'Incorrect column name (' + Name + ').' ); - Result := ColType[ Idx ]; -end; - -function TQuery.GetDField(Idx: Integer): TDateTime; -var P: Pointer; - ST: TSystemTime; - pD: PDBDate; - pT: PDBTime; - TS: PDBTimeStamp; - pFT: PFileTime; -begin - P := FieldPtr( Idx ); - if P = nil then - Result := 0.0 - else - begin - FillChar( ST, Sizeof(ST), 0 ); - case fBindings[ Idx ].wType of - DBTYPE_DATE: Result := PDouble( P )^ + VCLDate0; - DBTYPE_DBDATE: - begin - pD := P; - ST.wYear := pD.year; - ST.wMonth := pD.month; - ST.wDay := pD.day; - SystemTime2DateTime( ST, Result ); - end; - DBTYPE_DBTIME: - begin - pT := P; - ST.wYear := 1899; - ST.wMonth := 12; - ST.wDay := 31; - ST.wHour := pT.hour; - ST.wMinute := pT.minute; - ST.wSecond := pT.second; - SystemTime2DateTime( ST, Result ); - Result := Result - VCLDate0; - end; - DBTYPE_DBTIMESTAMP: - begin - TS := P; - ST.wYear := TS.year; - ST.wMonth := TS.month; - ST.wDay := TS.day; - ST.wHour := TS.hour; - ST.wMinute := TS.minute; - ST.wSecond := TS.second; - ST.wMilliseconds := TS.fraction div 1000000; - SystemTime2DateTime( ST, Result ); - end; - DBTYPE_FILETIME: - begin - pFT := P; - FileTimeToSystemTime( pFT^, ST ); - SystemTime2DateTime( ST, Result ); - end; - else Result := 0.0; - end; - end; -end; - -function TQuery.GetDFlfByName(const Name: String): TDateTime; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - Result := DField[ Idx ]; -end; - -function TQuery.GetFByNameAsStr(const Name: String): String; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - Result := FieldAsStr[ Idx ]; -end; - -function TQuery.GetFieldAsHex(Idx: Integer): Pointer; -begin - {if IsNull[ Idx ] then - Result := nil - else} - Result := FieldPtr( Idx ); -end; - -function TQuery.GetFieldAsStr(Idx: Integer): String; -begin - if IsNull[ Idx ] then - Result := '(null)' - else - case ColType[ Idx ] of - ftReal: - //added optimize by azsd - begin - case fBindings[ Idx ].wType of - DBTYPE_NUMERIC,DBTYPE_VARNUMERIC: - if ShortInt(PDBNumeric(FieldPtr(Idx)).scale)<>0 then - Result := Double2Str( RField[ Idx ] ) - else - Result := Int64_2Str( LField[ Idx ] ); - else - Result := Double2Str( RField[ Idx ] ); - end; - end; - ftString: Result := SField[ Idx ]; - ftDate: Result := DateTime2StrShort( DField[ Idx ] ); - ftLargeInt: Result := Int64_2Str( LField[ Idx ] );//add by azsd - //ftInteger: - else Result := Int2Str( IField[ Idx ] ); - //else Result := '(?)'; - end; -end; - -function TQuery.GetFieldByNameAsHex(const Name: String): Pointer; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - Result := FieldAsHex[ Idx ]; -end; - -function TQuery.GetFltField(Idx: Integer): Double; -var P: Pointer; -begin - P := FieldPtr( Idx ); - if P = nil then - Result := 0.0 - else - case fBindings[ Idx ].wType of - DBTYPE_R4: Result := PSingle( P )^; - DBTYPE_R8: Result := PDouble( P )^; - DBTYPE_CY: Result := PInteger( P )^ * 0.0001; - //TODO: DBTYPE_DECIMAL - DBTYPE_NUMERIC, DBTYPE_VARNUMERIC: - begin - Result := Int64_2Double(GetFixupNumeric(Idx)); - if PDBNumeric(P).sign=0 then Result := 0 - Result; - if PDBNumeric(P).scale<>0 then Result := Result * IntPower( 10, 0 - Shortint(PDBNumeric(P).scale)); - end; - else Result := 0.0; - end; -end; - -function TQuery.GetFixupNumeric(Idx: Integer): Int64; -var - P: Pointer; -begin - P := FieldPtr( Idx ); - Result := MakeInt64( 0, 0 ); - if P=nil then Exit; - case fBindings[ Idx ].wType of - DBTYPE_NUMERIC: - Result := PInt64( DWORD(P)+3 )^; //131 filled with 00 - DBTYPE_VARNUMERIC: - begin - Result := PInt64( DWORD(P)+3 )^; //139 containing some shit bytes - //vn := P; - //if vn.precision> then - //fix-up done in Fetchdata - end; - else - Result := MakeInt64( PDWORD( DWORD(P)+3 )^, 0 ); - end; -end; - -function TQuery.GetI64Field(Idx: Integer): Int64; -const His: array[ 0..1 ] of Integer = ( 0, -1 and not 255 ); -var P: Pointer; - B: Byte; -begin - P := FieldPtr( Idx ); - Result := MakeInt64( 0, 0 ); - if P <> nil then - case fBindings[ Idx ].wType of - DBTYPE_I8, DBTYPE_UI8, DBTYPE_CY: - Result := PInt64( P )^; - DBTYPE_I1: - begin - B := PByte( P )^; - Result := Int2Int64( Integer( B ) or His[ B shr 7 ] ); - end; - DBTYPE_UI1: Result := MakeInt64( PByte( P )^, 0 ); - DBTYPE_I2: Result := Int2Int64( PShortInt( P )^ ); - DBTYPE_UI2: Result := MakeInt64( PWord( P )^, 0 ); - DBTYPE_I4: Result := Int2Int64( PInteger( P )^ ); - DBTYPE_NUMERIC, DBTYPE_VARNUMERIC: - begin - if ShortInt(PDBNumeric(P).scale)<>0 then - Result := Double2Int64( RField[Idx] ) - else - Result := GetFixupNumeric(Idx); - end; - //DBTYPE_UI4: - else Result := MakeInt64( PInteger( P )^, 0 ); - end; -end; - -function TQuery.GetI64FldByName(const Name: String): Int64; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - Result := LField[ Idx ]; -end; - -function TQuery.GetIFieldByName(const Name: String): Integer; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - Result := IField[ Idx ]; -end; - -function TQuery.GetIntField(Idx: Integer): Integer; -var P: Pointer; -begin - P := FieldPtr( Idx ); - if P = nil then - Result := 0 - else - case fBindings[ Idx ].wType of - DBTYPE_I1: begin - Result := PByte( P )^; - if LongBool( Result and $80) then - Result := Result or not $7F; - end; - DBTYPE_UI1: Result := PByte( P )^; - DBTYPE_I2, DBTYPE_UI2, DBTYPE_BOOL: Result := PShortInt( P )^; - DBTYPE_NUMERIC, DBTYPE_VARNUMERIC: - begin - if ShortInt(PDBNumeric(P).scale)<>0 then - Result := Round( RField[Idx] ) - else - Result := GetFixupNumeric(Idx).Lo; - end; - //DBTYPE_I4, DBTYPE_UI4, DBTYPE_HCHAPTER: - else Result := PInteger( P )^; - end; -end; - -function TQuery.GetIsNull(Idx: Integer): Boolean; -var P: PDWORD; -begin - Result := TRUE; - if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then - Exit; - P := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + - fBindings[ Idx ].obStatus ); - Result := P^ = DBSTATUS_S_ISNULL; -end; - -function TQuery.GetIsNullByName(const Name: String): Boolean; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - Result := IsNull[ Idx ]; -end; - -function TQuery.GetRawType(Idx: Integer): DWORD; -begin - Result := 0; - if fBindings = nil then Exit; - Result := fBindings[ Idx ].wType; -end; - -function TQuery.GetRawTypeByName(const Name: String): DWORD; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - Result := RawType[ Idx ]; -end; - -function TQuery.GetRFieldByName(const Name: String): Double; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - Result := RField[ Idx ]; -end; - -function TQuery.GetRowCount: Integer; -begin - {if fRowsAffected = DB_S_ASYNCHRONOUS then - begin - // only for asynchronous connections - do not see now - end;} - Result := fRowsAffected; -end; - -function TQuery.GetRowsKnown: Integer; -begin - Result := fRowsAffected; - if Result = 0 then - if fRowBuffers <> nil then - Result := fRowBuffers.Count; -end; - -function TQuery.GetSFieldByName(const Name: String): String; -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - Result := SField[ Idx ]; -end; - -function TQuery.GetStrField(Idx: Integer): String; -var P: Pointer; -begin - P := FieldPtr( Idx ); - if P = nil then - Result := '' - else - if fBindings[ Idx ].wType = DBTYPE_STR then - Result := PChar( P ) - else - Result := PWideChar( P ); -end; - -procedure TQuery.Last; -begin - while not EOF do - Next; //WOFetch( 0 ); - if RowsKnown > 0 then - fCurIndex := RowsKnown; - Prev; - //FetchData; - fEOF := FALSE; -end; - -procedure TQuery.MarkFieldChanged(Idx: Integer); -begin - Changed( Idx ); -end; - -procedure TQuery.MarkFieldChangedByName(const Name: String); -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - MarkFieldChanged( Idx ); -end; - -procedure TQuery.Next; -begin - NextWOFetch( 0 ); - FetchData; -end; - -procedure TQuery.NextWOFetch( Skip: Integer ); -var Obtained: UINT; - PHandle: Pointer; - hr: HResult; -begin - ReleaseHandle; - PHandle := @fRowHandle; - if (fCurIndex = fRowsAffected) and (Skip = -2) then - hr := fRowSet.GetNextRows( 0, -1, 1, Obtained, @PHandle ) - else - hr := fRowSet.GetNextRows( 0, Skip, 1, Obtained, @PHandle ); - if hr <> DB_S_ENDOFROWSET then - CheckOLE( hr ); - Inc( fCurIndex, Skip + 1 ); - if Obtained = 0 then - begin - fEOF := TRUE; - if fRowBuffers <> nil then - fRowsAffected := fRowBuffers.Count; - end - else - begin - if fRowBuffers = nil then - fRowBuffers := NewList; - if fCurIndex >= fRowBuffers.Count then - fRowBuffers.Add( nil ); - end; -end; - -procedure TQuery.Open; -const - DB_NULLID: DBID = (uguid: (guid: (D1: 0; D2: 0; D3:0; D4: (0, 0, 0, 0, 0, 0, 0, 0))); - ekind: 1 {DBKIND_GUID_PROPID}; uname: (ulpropid:0)); - -var ColInfo: IColumnsInfo; - AccessorIntf: IAccessor; - I: Integer; - OK: Boolean; - - PropSets: array[0..0] of TDBPropset; - Props: array[ 0..0 ] of TDBProp; -begin - ClearRowset; - if CheckOLE( fCommand.SetCommandText( @DBGUID_DBSQL, StringToOleStr( fText ) ) ) then - begin - if Mode = rmReadOnly then - begin - if not CheckOLE( fCommand.Execute( nil, IID_IROWSET, nil, @fRowsAffected, PIUnknown( @fRowSet ) ) ) then - Exit; - end - else - begin - // Add by ECM !!! - {$IFNDEF IBPROVIDER} - if fCommandProps = nil then - begin - if CheckOLE( fCommand.QueryInterface( IID_ICommandProperties, fCommandProps ) ) then - begin - PropSets[0].rgProperties := @ Props[ 0 ]; - PropSets[0].cProperties := 1; - PropSets[0].guidPropertySet := DBPROPSET_ROWSET; - - Props[0].dwPropertyID := $00000075; //DBPROP_UPDATABILITY - Props[0].dwOptions := 0; //DBPROPOPTIONS_REQUIRED; - Props[0].dwStatus := 0; //DBPROPSTATUS_OK; - Props[0].colid := DB_NULLID; - Props[0].vValue.vt := VT_I4; - Props[0].vValue.lVal := 1; //DBPROPVAL_UP_CHANGE; - end; - end; - CheckOLE( fCommandProps.SetProperties( 1, @ PropSets[ 0 ] ) ); - {$ENDIF} - if not CheckOLE( fCommand.Execute( nil, IID_IROWSETCHANGE, nil, nil, PIUnknown( @ fRowSetChg ) ) ) then - Exit; - if not CheckOLE( fRowSetChg.QueryInterface( IID_IROWSET, fRowSet ) ) then - Exit; - if Mode = rmUpdateDelayed then - CheckOLE( fRowSetChg.QueryInterface( IID_IROWSETUPDATE, fRowSetUpd ) ); - end; - - if fRowsAffected = 0 then - Dec( fRowsAffected ); // RowCount = -1 means that RowCount is an unknown value - if fRowSetChg <> nil then - begin - OK := CheckOLE( fRowSetChg.QueryInterface( IID_IColumnsInfo, ColInfo ) ); - end - else - begin - OK := CheckOLE( fRowSet.QueryInterface( IID_IColumnsInfo, ColInfo ) ); - end; - if OK then - if CheckOLE( ColInfo.GetColumnInfo( fColCount, PDBColumnInfo( fColInfo ), fColNames ) ) then - begin - fBindings := AllocMem( Sizeof( TDBBinding ) * fColCount); - for I := 0 to fColCount - 1 do - begin - fBindings[ I ].iOrdinal := fColInfo[ I ].iOrdinal; - fBindings[ I ].obValue := fRowSize + 4; - // fBindings[ I ].obLength := 0; - fBindings[ I ].obStatus := fRowSize; - // fBindings[ I ].pTypeInfo := nil; - // fBindings[ I ].pObject := nil; - // fBindings[ I ].pBindExt := nil; - fBindings[ I ].dwPart := 1 + 4; //DBPART_VALUE + DBPART_STATUS; - // fBindings[ I ].dwMemOwner := 0; //DBMEMOWNER_CLIENTOWNED; - // fBindings[ I ].eParamIO := 0; //DBPARAMIO_NOTPARAM; - fBindings[ I ].cbMaxLen := fColInfo[ I ].ulColumnSize; - case fColInfo[ I ].wType of - DBTYPE_BSTR: Inc( fBindings[ I ].cbMaxLen, 1 ); - DBTYPE_WSTR: fBindings[ I ].cbMaxLen := fBindings[ I ].cbMaxLen * 2 + 2; - end; - fBindings[ I ].cbMaxLen := (fBindings[ I ].cbMaxLen + 3) and not 3; - // fBindings[ I ].dwFlags := 0; - fBindings[ I ].wType := fColInfo[ I ].wType; - fBindings[ I ].bPrecision := fColInfo[ I ].bPrecision; - fBindings[ I ].bScale := fColInfo[ I ].bScale; - Inc( fRowSize, fBindings[ I ].cbMaxLen + 4 ); - end; - fBindStatus := AllocMem( Sizeof( DBBINDSTATUS ) * fColCount ); - if fRowSetChg <> nil then - begin - OK := CheckOLE( fRowSetChg.QueryInterface( IID_IAccessor, AccessorIntf ) ); - end - else - begin - OK := CheckOLE( fRowSet.QueryInterface( IID_IAccessor, AccessorIntf ) ); - end; - if OK then - CheckOLE( - AccessorIntf.CreateAccessor( - 2, //DBACCESSOR_ROWDATA, // Accessor will be used to retrieve row data - fColCount, // Number of columns being bound - fBindings, // Structure containing bind info - 0, // Not used for row accessors - fAccessor, // Returned accessor handle - PUIntArray( fBindStatus ) // Information about binding validity - ) - ); - fEOF := FALSE; - fCurIndex := -1; - First; - end; - end; -end; - -procedure TQuery.Post; -var R: HResult; - {P: PChar; - I: Integer;} -begin - if not fChanged then Exit; - if fRowSetChg = nil then Exit; - R := fRowSetChg.SetData( fRowHandle, fAccessor, fRowBuffers.Items[ fCurIndex ] ); - if R <> HResult( $00040EDA {DB_S_ERRORSOCCURED} ) then - CheckOLE( R ) - { // я вижу только статус DBSTATUS_E_INTEGRITYVIOLATION касательно 0-й колонки, - // которую никто не просил добавлять во время выборки. - else - begin - asm - int 3 - end; - for I := 0 to fColCount-1 do - begin - P := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + - fBindings[ I ].obStatus ); - ShowMessage( fColInfo[I].pwszName + '.Status=' + Int2Hex( PDWORD( P )^, 8 ) ); - end; - end}; - fChanged := FALSE; -end; - -procedure TQuery.Prev; -begin - if CurIndex > 0 then - begin - NextWOFetch( -2 ); //*** - //Dec( fCurIndex ); - fEOF := FALSE; - FetchData; //*** - end; -end; - -procedure TQuery.ReleaseHandle; -begin - if fRowHandle <> 0 then - CheckOLE( fRowSet.ReleaseRows( 1, @fRowHandle, nil, nil, nil ) ); - fRowHandle := 0; -end; - -procedure TQuery.SetCurIndex(const Value: Integer); -var OldCurIndex: Integer; -begin - OldCurIndex := fCurIndex; - if fCurIndex = Value then - begin - if fRowHandle = 0 then - FetchData; - if fRowHandle <> 0 then - Exit; - end; - if Value = 0 then - First - else - if Value >= fRowsAffected - 1 then - Last; - - fEOF := FALSE; - while (fCurIndex < Value) and not EOF do - Next; - while (fCurIndex > Value) and not EOF do - Prev; - - if fCurIndex = Value then - FetchData - else - fCurIndex := OldCurIndex; -end; - -procedure TQuery.SetDField(Idx: Integer; const Value: TDateTime); -var P: Pointer; - ST: TSystemTime; - pD: PDBDate; - pT: PDBTime; - TS: PDBTimeStamp; - pFT: PFileTime; -begin - P := FieldPtr( Idx ); - if P = nil then Exit; - case fBindings[ Idx ].wType of - DBTYPE_DATE: PDouble( P )^ := Value - VCLDate0; - DBTYPE_DBDATE: - begin - pD := P; - DateTime2SystemTime( Value, ST ); - pD.year := ST.wYear; - pD.month := ST.wMonth; - pD.day := ST.wDay; - end; - DBTYPE_DBTIME: - begin - pT := P; - DateTime2SystemTime( Value, ST ); - pT.hour := ST.wHour; - pT.minute := ST.wMinute; - pT.second := ST.wSecond; - end; - DBTYPE_DBTIMESTAMP: - begin - TS := P; - DateTime2SystemTime( Value, ST ); - TS.year := ST.wYear; - TS.month := ST.wMonth; - TS.day := ST.wDay; - TS.hour := ST.wHour; - TS.minute := ST.wMinute; - TS.second := ST.wSecond; - TS.fraction := ST.wMilliseconds * 1000; - end; - DBTYPE_FILETIME: - begin - pFT := P; - DateTime2SystemTime( Value, ST ); - SystemTimeToFileTime( ST, pFT^ ); - end; - else Exit; - end; - Changed( Idx ); -end; - -procedure TQuery.SetDFldByName(const Name: String; const Value: TDateTime); -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - DField[ Idx ] := Value; -end; - -procedure TQuery.SetFByNameFromStr(const Name, Value: String); -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - FieldAsStr[ Idx ] := Value; -end; - -procedure TQuery.SetFieldFromStr(Idx: Integer; const Value: String); -begin - if StrEq( Value, '(null)' ) and (ColType[ Idx ] <> ftString) then - IsNull[ Idx ] := TRUE - else - case ColType[ Idx ] of - ftInteger: IField[ Idx ] := Str2Int( Value ); - ftReal: RField[ Idx ] := Str2Double( Value ); - ftString: SField[ Idx ] := Value; - ftDate: DField[ Idx ] := Str2DateTimeShort( Value ); - end; -end; - -procedure TQuery.SetFltField(Idx: Integer; const Value: Double); -var P: Pointer; -begin - P := FieldPtr( Idx ); - if P = nil then - Exit; - case fBindings[ Idx ].wType of - DBTYPE_R4: PExtended( P )^ := Value; - DBTYPE_R8: PDouble( P )^ := Value; - DBTYPE_CY: PInteger( P )^ := Round( Value * 10000 ); - //TODO: DBTYPE_NUMERIC, DBTYPE_VARNUMERIC, DBTYPE_DECIMAL - else Exit; - end; - Changed( Idx ); -end; - -procedure TQuery.SetI64Field(Idx: Integer; const Value: Int64); -begin - -end; - -procedure TQuery.SetI64FldByName(const Name: String; const Value: Int64); -begin - -end; - -procedure TQuery.SetIFieldByName(const Name: String; Value: Integer); -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - IField[ Idx ] := Value; -end; - -procedure TQuery.SetIntField(Idx: Integer; const Value: Integer); -var P: Pointer; -begin - P := FieldPtr( Idx ); - if P = nil then - Exit; - case fBindings[ Idx ].wType of - DBTYPE_I1, DBTYPE_UI1: PByte( P )^ := Byte( Value ); - DBTYPE_I2, DBTYPE_UI2: PShortInt( P )^ := Value; - DBTYPE_BOOL: if Value <> 0 then PShortInt( P )^ := -1 - else PShortInt( P )^ := 0; - else PInteger( P )^ := Value; - end; - Changed( Idx ); -end; - -procedure TQuery.SetIsNull(Idx: Integer; const Value: Boolean); -var P: PDWORD; -begin - if not Value then Exit; - if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then - Exit; - P := Changed( Idx ); - P^ := DBSTATUS_S_ISNULL; -end; - -procedure TQuery.SetIsNullByName(const Name: String; const Value: Boolean); -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - IsNull[ Idx ] := Value; -end; - -procedure TQuery.SetRFieldByName(const Name: String; const Value: Double); -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - RField[ Idx ] := Value; -end; - -procedure TQuery.SetSFieldByName(const Name: String; const Value: String); -var Idx: Integer; -begin - Idx := ColByName[ Name ]; - Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); - SField[ Idx ] := Value; -end; - -procedure TQuery.SetStrField(Idx: Integer; const Value: String); -var P: Pointer; -begin - P := FieldPtr( Idx ); - if P = nil then - Exit; - if fBindings[ Idx ].wType = DBTYPE_STR then - StrLCopy( PChar( P ), @ Value[ 1 ], fBindings[ Idx ].cbMaxLen ) - else - StringToWideChar( Value, PWideChar( P ), fBindings[ Idx ].cbMaxLen ); - Changed( Idx ); -end; - -procedure TQuery.SetText(const Value: String); -begin - // clear here current rowset if any: - ClearRowset; - {// set txt to fCommand -- do this at the last moment just before execute - CheckOLE( fCommand.SetCommandText( DBGUID_DBSQL, StringToOleStr( Value ) ) );} - FText := Value; -end; - -procedure TQuery.Update; -var Params, Results: array of DWORD; - I: Integer; -begin - if Mode <> rmUpdateDelayed then Exit; - if (fDelList <> nil) and (fDelList.Count > 0) then - begin - SetLength( Params, fDelList.Count ); - SetLength( Results, fDelList.Count ); - for I := 0 to fDelList.Count-1 do - Params[ I ] := DWORD( fDelList.Items[ I ] ); - CheckOLE( fRowSetUpd.DeleteRows( 0, fDelList.Count, @ Params[ 0 ], @ Results[ 0 ] ) ); - Free_And_Nil( fDelList ); - end; - if fRowSetUpd = nil then Exit; - CheckOLE( fRowSetUpd.Update( 0, 0, nil, nil, nil, nil ) ); -end; - -end. diff --git a/plugins/ImportTXT/kol/KOLMHTooltip_implem.inc b/plugins/ImportTXT/kol/KOLMHTooltip_implem.inc deleted file mode 100644 index 869ba0233d..0000000000 --- a/plugins/ImportTXT/kol/KOLMHTooltip_implem.inc +++ /dev/null @@ -1,437 +0,0 @@ -// part of KOLMHToolTip -- interface_part. -// Moved to separate inc-file still Delphi20XX does not allow compile -// in DEBUG mode. - -const - Dummy1 = 1; - - TTDT_AUTOMATIC = 0; - TTDT_RESHOW = 1; - TTDT_AUTOPOP = 2; - TTDT_INITIAL = 3; - -function NewMHToolTip(AParent: PControl): PMHToolTip; -const - CS_DROPSHADOW = $00020000; -begin - DoInitCommonControls(ICC_BAR_CLASSES); - New(Result, Create); - - Result.fHandle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, '', 0, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, AParent.GetWindowHandle, 0, HInstance, nil); -end; - -function TMHToolTip.GetDelay(const Index: Integer): Integer; -begin - Result := SendMessage(fHandle, TTM_GETDELAYTIME, Index, 0); -end; - - -procedure TMHToolTip.SetDelay(const Index, Value: Integer); -begin - SendMessage(handle, TTM_SETDELAYTIME, Index, MAKELONG(Value, 0)); -end; - - -function TMHToolTip.GetColor(const Index: Integer): TColor; -begin - Result := SendMessage(handle, TTM_GETTIPBKCOLOR + Index, 0, 0); -end; - -procedure TMHToolTip.SetColor(const Index: Integer; const Value: TColor); -begin - SendMessage(handle, TTM_SETTIPBKCOLOR + Index, Value, 0); -end; - -function TMHToolTip.GetMaxWidth: Integer; -begin - Result := SendMessage(fHandle, TTM_GETMAXTIPWIDTH, 0, 0); -end; - -procedure TMHToolTip.SetMaxWidth(const Value: Integer); -begin - SendMessage(fHandle, TTM_SETMAXTIPWIDTH, 0, Value); -end; - -function TMHToolTip.GetMargin: TRect; -begin - SendMessage(fHandle, TTM_GETMARGIN, 0, DWord(@Result)); -end; - -procedure TMHToolTip.SetMargin(const Value: TRect); -begin - SendMessage(fHandle, TTM_SETMARGIN, 0, DWord(@Value)); -end; - -function TMHToolTip.GetActivate: Boolean; -begin - // ?????? - Result := False; -end; - -procedure TMHToolTip.SetActivate(const Value: Boolean); -begin - SendMessage(fHandle, TTM_ACTIVATE, DWord(Value), 0); -end; - -procedure TMHToolTip.Pop; -begin - SendMessage(fHandle, TTM_POP, 0, 0); -end; - -procedure TMHToolTip.Popup; -begin - SendMessage(fHandle, $0422 {TTM_POPUP}, 0, 0); -end; - -procedure TMHToolTip.Update; -begin - inherited; // ??? - SendMessage(fHandle, TTM_UPDATE, 0, 0); -end; - -function NewHint(A: PControl): PMHHint; -begin - New(Result, Create); - - with Result^ do - begin - Parent := A; - ToolTip := nil; // ??? - HasTool := False; // ??? - end; - A.Add2AutoFree(Result); -end; - -function NewManager: PMHToolTipManager; -begin - New(Result, Create); -end; - -{ TMHHint } - -function TMHHint.GetDelay(const Index: Integer): Integer; -begin -// CreateToolTip; - Result := 0; - if Assigned(ToolTip) then - Result := ToolTip.GetDelay(Index); -end; - -function TMHHint.GetFI: TFI; -begin - /// !!! DANGER-WITH !!! - with Result, ToolTip^ do - begin - FE := FE + [eTextColor]; - Colors[1] := TextColor; - - FE := FE + [eBkColor]; - Colors[0] := BkColor; - - FE := FE + [eAPDelay]; - Delays[TTDT_AUTOPOP] := AutoPopDelay; - - FE := FE + [eRDelay]; - Delays[TTDT_RESHOW] := ReshowDelay; - - FE := FE + [eIDelay]; - Delays[TTDT_INITIAL] := InitialDelay; - end; -end; - -procedure TMHHint.ReConnect(FI: TFI); -var - TMP: PMHToolTip; -begin - with GetManager^ do - begin - TMP := FindNeed(FI); - if not Assigned(TMP) then - TMP := CreateNeed(FI); - if Assigned(ToolTip) and HasTool then - MoveTool(TMP); - ToolTip := TMP; - end; -end; - -procedure TMHHint.MoveTool(T1: PMHToolTip); -var - TI: TToolInfo; - TextL: array[0..255] of KOLChar; -begin - if T1 = ToolTip then - Exit; - with TI do - begin - cbSize := SizeOf(TI); - hWnd := Parent.GetWindowHandle; - uId := Parent.GetWindowHandle; - lpszText := @TextL[0]; - end; - - SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); - SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI)); - ToolTip.Count := ToolTip.Count - 1; - SendMessage(T1.handle, TTM_ADDTOOL, 0, DWORD(@TI)); - T1.Count := T1.Count - 1; - - HasTool := True; - -end; - -procedure TMHHint.SetColor(const Index: Integer; const Value: TColor); -var - FI: TFI; -begin - if Assigned(ToolTip) then - begin - if ToolTip.Count + Byte(not HasTool) = 1 then - begin - ToolTip.SetColor(Index, Value); - Exit; - end; - FI := GetFI; - end; - - case Index of - 0: FI.FE := FI.FE + [eBkColor]; - 1: FI.FE := FI.FE + [eTextColor]; - end; - FI.Colors[Index] := Value; - - ReConnect(FI); -end; - -function TMHHint.GetColor(const Index: Integer): TColor; -begin - Result := 0; - if Assigned(ToolTip) then - Result := ToolTip.GetColor(Index); -end; - -procedure TMHHint.SetDelay(const Index, Value: Integer); -var - FI: TFI; -begin - if Assigned(ToolTip) then - begin - if ToolTip.Count + Byte(not HasTool) = 1 then - begin - ToolTip.SetDelay(Index, Value); - Exit; - end; - FI := GetFI; - end; - - case Index of - TTDT_AUTOPOP: FI.FE := FI.FE + [eAPDelay]; // Spec - TTDT_INITIAL: FI.FE := FI.FE + [eIDelay]; // Spec - TTDT_RESHOW: FI.FE := FI.FE + [eRDelay]; // Spec - end; //case - - FI.Delays[Index] := Value; //Spec - - ReConnect(FI); -end; - -procedure TMHHint.SetText(Value: KOLString); -var - TI: TToolInfo; -begin - ProcBegin(TI); - - with TI do - begin - uFlags := TTF_SUBCLASS or TTF_IDISHWND; // Spec - lpszText := PKOLChar(Value); // Spec - end; - - procEnd(TI); - - if HasTool then - begin - TI.lpszText := PKOLChar(Value); - SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); - end; - -end; - -{ TMHToolTipManager } - -function TMHToolTipManager.AddTip: Integer; -begin - SetLength(TTT, Length(TTT) + 1); - TTT[Length(TTT) - 1] := NewMHToolTip(Applet); - Result := Length(TTT) - 1; -end; - -function TMHToolTipManager.FindNeed(FI: TFI): PMHToolTip; -var - i: Integer; -begin - Result := nil; - for i := 0 to length(TTT) - 1 do - begin - if ((eTextColor in FI.FE) and (not (FI.Colors[1] = TTT[i].TextColor))) or - ((eBkColor in FI.FE) and (not (FI.Colors[0] = TTT[i].BkColor))) or - ((eAPDelay in FI.FE) and (not (FI.Delays[TTDT_AUTOPOP] = TTT[i].AutoPopDelay))) or - ((eIDelay in FI.FE) and (not (FI.Delays[TTDT_INITIAL] = TTT[i].InitialDelay))) or - ((eRDelay in FI.FE) and (not (FI.Delays[TTDT_RESHOW] = TTT[i].ReshowDelay))) then - Continue; - Result := TTT[i]; - Break; - end; -end; - -function TMHToolTipManager.CreateNeed(FI: TFI): PMHToolTip; - -begin - Setlength(TTT, length(TTT) + 1); - TTT[length(TTT) - 1] := NewMHToolTip(Applet); - with TTT[length(TTT) - 1]^ do - begin - if (eTextColor in FI.FE) then - TextColor := FI.Colors[1]; - if (eBkColor in FI.FE) then - BkColor := FI.Colors[0]; - if (eAPDelay in FI.FE) then - AutoPopDelay := FI.Delays[TTDT_AUTOPOP]; - if (eIDelay in FI.FE) then - InitialDelay := FI.Delays[TTDT_INITIAL]; - if (eRDelay in FI.FE) then - ReshowDelay := FI.Delays[TTDT_RESHOW]; - end; - Result := TTT[length(TTT) - 1]; -end; - -procedure TMHHint.ProcBegin(var TI: TToolInfo); -begin - CreateToolTip; - - with TI do - begin - cbSize := SizeOf(TI); - hWnd := Parent.GetWindowHandle; - uId := Parent.GetWindowHandle; - hInst := 0; - end; -end; - -procedure TMHHint.ProcEnd(var TI: TToolInfo); -var - TextLine: array[0..255] of KOLChar; -begin - if not HasTool then - begin - SendMessage(ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI)); - HasTool := True; - ToolTip.Count := ToolTip.Count + 1; - end - else - begin - with TI do - begin - lpszText := @TextLine[0]; - end; - SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); - end; -end; - -destructor TMHToolTipManager.Destroy; -var - i: Integer; -begin - for i := 0 to Length(TTT) - 1 do - TTT[i].Free; - SetLength(TTT, 0); - inherited; -end; - -procedure TMHHint.Pop; -begin - if Assigned(ToolTip) and (HasTool) then - begin // ^^^^^^^^^^^^ ??? -// CreateToolTip; - ToolTip.Pop; - end; -end; - -procedure TMHHint.Popup; -begin - if Assigned(ToolTip) and (HasTool) then - begin // ^^^^^^^^^^^^ ??? -// CreateToolTip; - ToolTip.Popup; - end; -end; - -destructor TMHHint.Destroy; -var - TI: TToolInfo; - i: integer; -begin - with TI do - begin - cbSize := SizeOf(TI); - hWnd := Parent.GetWindowHandle; - uId := Parent.GetWindowHandle; - end; - - SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI)); - ToolTip.Count := ToolTip.Count - 1; - if ToolTip.Count <= 0 then begin - i:=Length(Manager.TTT); - if i > 1 then begin - Manager.TTT[i - 1].Free; - SetLength(Manager.TTT, i - 1); - end - else - Free_And_Nil(Manager); - end; - inherited; -end; - -destructor TMHToolTip.Destroy; -begin - inherited; -end; - -procedure TMHHint.CreateToolTip; -begin - if not Assigned(ToolTip) then - begin - if Length(GetManager.TTT) = 0 then - GetManager.AddTip; - ToolTip := GetManager.TTT[0]; - end; -end; - -function TMHHint.GetText: KOLString; -var - TI: TToolInfo; - TextL: array[0..255] of KOLChar; -begin - if Assigned(ToolTip) and (HasTool) then - begin - // !!! - with TI do - begin - // ???? -// FillChar(TI, SizeOf(TI), 0); - cbSize := SizeOf(TI); - hWnd := Parent.GetWindowHandle; - uId := Parent.GetWindowHandle; - lpszText := @TextL[0]; - end; - SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); - Result := TextL; //TI.lpszText;// := PChar(Value); - end; -end; - -function TMHHint.GetManager: PMHToolTipManager; -begin - if Manager=nil then - Manager:=NewManager; - Result:=Manager; -end; - diff --git a/plugins/ImportTXT/kol/KOLMHTooltip_interface.inc b/plugins/ImportTXT/kol/KOLMHTooltip_interface.inc deleted file mode 100644 index 0e2e9d0d83..0000000000 --- a/plugins/ImportTXT/kol/KOLMHTooltip_interface.inc +++ /dev/null @@ -1,95 +0,0 @@ -// part of KOLMHToolTip -- interface_part. -// Moved to separate inc-file still Delphi20XX does not allow compile -// in DEBUG mode. - - TFE = (eTextColor, eBkColor, eAPDelay, eRDelay, eIDelay); - - TFI = record - FE: set of TFE; - Colors: array[0..1] of TColor; - Delays: array[0..3] of Integer; - end; - - PMHToolTipManager = ^TMHToolTipManager; - TKOLMHToolTipManager = PMHToolTipManager; - - PMHToolTip = ^TMHToolTip; - TKOLMHToolTip = PMHToolTip; - - TMHToolTipManager = object(TObj) - protected - destructor Destroy; virtual; - public - TTT: array of PMHToolTip; - function AddTip: Integer; - function FindNeed(FI: TFI): PMHToolTip; - function CreateNeed(FI: TFI): PMHToolTip; - end; - - //P_MHHint = ^TMHHint; - TMHHint = object(TObj) - private - function GetManager:PMHToolTipManager; - // Spec - procedure ProcBegin(var TI: TToolInfo); - procedure ProcEnd(var TI: TToolInfo); - procedure ReConnect(FI: TFI); - procedure MoveTool(T1: PMHToolTip); - procedure CreateToolTip; - function GetFI: TFI; - - // Group - function GetDelay(const Index: Integer): Integer; - procedure SetDelay(const Index: Integer; const Value: Integer); - function GetColor(const Index: Integer): TColor; - procedure SetColor(const Index: Integer; const Value: TColor); - - // Local - procedure SetText(Value: KOLString); - function GetText: KOLString; - public - ToolTip: PMHToolTip; - HasTool: Boolean; - Parent: PControl; - destructor Destroy; virtual; - procedure Pop; - procedure Popup; - - property AutoPopDelay: Integer index 2 read GetDelay write SetDelay; - property InitialDelay: Integer index 3 read GetDelay write SetDelay; - property ReshowDelay: Integer index 1 read GetDelay write SetDelay; - - property TextColor: TColor index 1 read GetColor write SetColor; - property BkColor: TColor index 0 read GetColor write SetColor; - property Text: KOLString read GetText write SetText; - end; - - TMHToolTip = object(TObj) - private - fHandle: THandle; - Count: Integer; - function GetDelay(const Index: Integer): Integer; - procedure SetDelay(const Index: Integer; const Value: Integer); - function GetColor(const Index: Integer): TColor; - procedure SetColor(const Index: Integer; const Value: TColor); - function GetMaxWidth: Integer; - procedure SetMaxWidth(const Value: Integer); - function GetMargin: TRect; - procedure SetMargin(const Value: TRect); - function GetActivate: Boolean; - procedure SetActivate(const Value: Boolean); - public - destructor Destroy; virtual; - procedure Pop; - procedure Popup; - procedure Update; - property AutoPopDelay: Integer index 2 read GetDelay write SetDelay; - property InitialDelay: Integer index 3 read GetDelay write SetDelay; - property ReshowDelay: Integer index 1 read GetDelay write SetDelay; - property TextColor: TColor index 1 read GetColor write SetColor; - property BkColor: TColor index 0 read GetColor write SetColor; - property MaxWidth: Integer read GetMaxWidth write SetMaxWidth; - property Margin: TRect read GetMargin write SetMargin; - property Activate: Boolean read GetActivate write SetActivate; - property Handle: THandle read fHandle; - end; diff --git a/plugins/ImportTXT/kol/KOLMHTooltip_intf2.inc b/plugins/ImportTXT/kol/KOLMHTooltip_intf2.inc deleted file mode 100644 index 3478eab17a..0000000000 --- a/plugins/ImportTXT/kol/KOLMHTooltip_intf2.inc +++ /dev/null @@ -1,13 +0,0 @@ -// part of KOLMHToolTip -- interface_part. -// Moved to separate inc-file still Delphi20XX does not allow compile -// in DEBUG mode. -const - Dummy = 0; - - -function NewHint(A: PControl): PMHHint; -function NewManager: PMHToolTipManager; -function NewMHToolTip(AParent: PControl): PMHToolTip; - -var - Manager: PMHToolTipManager; diff --git a/plugins/ImportTXT/kol/KOL_ASM.inc b/plugins/ImportTXT/kol/KOL_ASM.inc deleted file mode 100644 index ee2e1aa97f..0000000000 --- a/plugins/ImportTXT/kol/KOL_ASM.inc +++ /dev/null @@ -1,15855 +0,0 @@ -//------------------------------------------------------------------------------ -// KOL_ASM.inc (to inlude in KOL.pas) -// v 3.17 - -function MsgBox( const S: KOLString; Flags: DWORD ): DWORD; -asm - PUSH EDX - PUSH EAX - - MOV ECX, [Applet] - XOR EAX, EAX - {$IFDEF SAFE_CODE} - JECXZ @@1 - {$ENDIF} - {$IFDEF SNAPMOUSE2DFLTBTN} - PUSHAD - XCHG EAX, ECX - XOR EDX, EDX - PUSH EDX - PUSH EDX - PUSH EDX - PUSH EAX - MOV EDX, offset[WndProcSnapMouse2DfltBtn] - CALL TControl.AttachProc - CALL TControl.Postmsg - POPAD - {$ENDIF} - - MOV EAX, [ECX].TControl.fCaption - {$IFDEF SNAPMOUSE2DFLTBTN} - MOV ECX, [ECX].TControl.fHandle - {$ENDIF} -@@1: - XCHG EAX, [ESP] - PUSH EAX - PUSH 0 - {$IFDEF UNICODE_CTRLS} - CALL MessageBoxW - {$ELSE} - CALL MessageBox - {$ENDIF} - {$IFDEF SNAPMOUSE2DFLTBTN} - MOV ECX, [Applet] - {$IFDEF SAFE_CODE} - JECXZ @@2 - {$ENDIF} - PUSH EAX - XCHG EAX, ECX - MOV EDX, offset[WndProcSnapMouse2DfltBtn] - CALL TControl.DetachProc - POP EAX -@@2: - {$ENDIF} -end; - -function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; stdcall; -asm - PUSH ESI - PUSH EDI - - MOV EDI, @Result - LEA ESI, [Left] - - MOVSD - MOVSD - MOVSD - MOVSD - - POP EDI - POP ESI -end; - -function RectsEqual( const R1, R2: TRect ): Boolean; -asm - //LEA EAX, [R1] - //LEA EDX, [R2] - MOV ECX, size_TRect - CALL CompareMem -end; - -function PointInRect( const P: TPoint; const R: TRect ): Boolean; -asm - PUSH ESI - MOV ECX, EAX - MOV ESI, EDX - LODSD - CMP EAX, [ECX] - JG @@fail - LODSD - CMP EAX, [ECX+4] - JG @@fail - LODSD - CMP [ECX], EAX - JG @@fail - LODSD - CMP [ECX+4], EAX -@@fail: SETLE AL - POP ESI -end; - -function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint; -asm - ADD EDX, [EAX].TPoint.X - ADD ECX, [EAX].TPoint.Y - MOV EAX, [Result] - MOV [EAX].TPoint.X, EDX - MOV [EAX].TPoint.Y, ECX -end; - -function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint; -asm - SHL EDX, 16 - SHLD ECX, EDX, 16 - CALL @@1 -@@1: - ROL EAX, 16 - ROL ECX, 16 - ADD AX, CX -end; - -function Point2SmallPoint( const T: TPoint ): TSmallPoint; -asm - XCHG EDX, EAX - MOV EAX, [EDX].TPoint.Y-2 - MOV AX, word ptr [EDX].TPoint.X -end; - -function SmallPoint2Point( const T: TSmallPoint ): TPoint; -asm - MOVSX ECX, AX - MOV [EDX].TPoint.X, ECX - SAR EAX, 16 - MOV [EDX].TPoint.Y, EAX -end; - -function MakePoint( X, Y: Integer ): TPoint; -asm - MOV ECX, @Result - MOV [ECX].TPoint.x, EAX - MOV [ECX].TPoint.y, EDX -end; - -function MakeSmallPoint( X, Y: Integer ): TSmallPoint; -asm - SHL EAX, 16 - SHRD EAX, EDX, 16 -end; - -function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer; -asm - PUSH EBX - PUSH ESI - MOV EBX, [EAX] - MOV ESI, EDX - XOR EDX, EDX - INC ECX - JZ @@exit -@@loo: - LODSD - TEST EAX, EAX - JGE @@ge - NOT EAX - TEST BL, 1 - JZ @@or - DEC EBX -@@ge: - TEST BL, 1 - JZ @@nx -@@or: - OR EDX, EAX -@@nx: - SHR EBX, 1 - LOOP @@loo - -@@exit: - XCHG EAX, EDX - POP ESI - POP EBX -end; - -constructor TObj.Create; -asm - //CALL System.@ObjSetup - Generated always by compiler - //JZ @@exit - - PUSH EAX - MOV EDX, [EAX] - CALL dword ptr [EDX] - POP EAX - -@@exit: -end; - -{$IFDEF OLD_REFCOUNT} -procedure TObj.DoDestroy; -asm - MOV EDX, [EAX].fRefCount - SAR EDX, 1 - JZ @@1 - JC @@exit - DEC [EAX].fRefCount - STC - -@@1: JC @@exit - MOV EDX, [EAX] - CALL dword ptr [EDX + 4] -@@exit: -end; -{$ENDIF OLD_REFCOUNT} - -function TObj.RefDec: Integer; -asm - TEST EAX, EAX - JZ @@exit - - SUB [EAX].fRefCount, 2 - JGE @@exit - {$IFDEF OLD_REFCOUNT} - TEST [EAX].fRefCount, 1 - JZ @@exit - MOV EDX, [EAX] - {$ENDIF} - MOV EDX, [EAX] - PUSH dword ptr [EDX+4] -@@exit: -end; - -{$IFDEF OLD_FREE} -procedure TObj.Free; -asm - //TEST EAX,EAX - JMP RefDec -end; -{$ENDIF OLD_FREE} - -{$IFNDEF CRASH_DEBUG} -destructor TObj.Destroy; -asm - PUSH EAX - CALL Final - POP EAX - {$IFDEF USE_NAMES} - PUSH EAX - XOR EDX, EDX - XOR ECX, ECX - CALL SetName - POP EAX - PUSH EAX - XOR ECX, ECX - XCHG ECX, [EAX].fNamedObjList - XCHG EAX, ECX - CALL TObj.RefDec - POP EAX - {$ENDIF} - XOR EDX, EDX - CALL System.@FreeMem - //CALL System.@Dispose -end; -{$ENDIF} - -procedure TObj.Add2AutoFree(Obj: PObj); -asm //cmd //opd - PUSH EBX - PUSH EDX - XCHG EBX, EAX - MOV EAX, [EBX].fAutoFree - TEST EAX, EAX - JNZ @@1 - CALL NewList - MOV [EBX].fAutoFree, EAX -@@1: MOV EBX, EAX - XOR EDX, EDX - POP ECX - CALL TList.Insert - XCHG EAX, EBX - XOR EDX, EDX - MOV ECX, offset TObj.RefDec - //XOR ECX, ECX - CALL TList.Insert - POP EBX -end; - -procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod ); -asm //cmd //opd - PUSH EBX - XCHG EAX, EBX - MOV EAX, [EBX].fAutoFree - TEST EAX, EAX - JNZ @@1 - CALL NewList - MOV [EBX].fAutoFree, EAX -@@1: XOR EDX, EDX - MOV ECX, [EBP+12] // Data - MOV EBX, EAX - CALL TList.Insert - XCHG EAX, EBX - XOR EDX, EDX - MOV ECX, [EBP+8] // Code - CALL TList.Insert - POP EBX -end; - -procedure TObj.RemoveFromAutoFree(Obj: PObj); -asm - PUSH EBX - XCHG EBX, EAX - MOV ECX, [EBX].fAutoFree - JECXZ @@exit - XCHG EAX, ECX - PUSH EAX - CALL TList.IndexOf - TEST EAX, EAX - POP EDX - XCHG EDX, EAX - JL @@exit - PUSH EAX - AND EDX, not 1 - XOR ECX, ECX - MOV CL, 2 - CALL TList.DeleteRange - POP EAX - MOV ECX, [EAX].TList.fCount - INC ECX - LOOP @@exit - LEA EAX, [EBX].fAutoFree - CALL Free_And_Nil -@@exit: - POP EBX -end; - -destructor TList.Destroy; -asm - PUSH EAX - CALL TList.Clear - POP EAX - CALL TObj.Destroy -end; - -procedure TList.SetCapacity( Value: Integer ); -asm - {$IFDEF TLIST_FAST} - CMP [EAX].fUseBlocks, 0 - JZ @@old - CMP [EAX].fBlockList, 0 - JZ @@old - - XOR ECX, ECX - MOV CH, 1 - CMP EDX, ECX - JLE @@256 - MOV EDX, ECX -@@256: - -@@just_set: - MOV [EAX].fCapacity, EDX - RET -@@old: - {$ENDIF} - CMP EDX, [EAX].fCount - {$IFDEF USE_CMOV} - CMOVL EDX, [EAX].fCount - {$ELSE} - JGE @@1 - MOV EDX, [EAX].fCount -@@1: {$ENDIF} - CMP EDX, [EAX].fCapacity - JE @@exit - - MOV [EAX].fCapacity, EDX - SAL EDX, 2 - LEA EAX, [EAX].fItems - CALL System.@ReallocMem -@@exit: -end; - -procedure TList.Clear; -asm - {$IFDEF TLIST_FAST} - PUSH EAX - MOV ECX, [EAX].fBlockList - JECXZ @@1 - MOV EDX, [ECX].fItems - MOV ECX, [ECX].fCount - SHR ECX, 1 - JZ @@1 -@@0: - MOV EAX, [EDX] - ADD EDX, 8 - PUSH EDX - PUSH ECX - CALL System.@FreeMem - POP ECX - POP EDX - LOOP @@0 -@@1: - POP EAX - PUSH EAX - XOR EDX, EDX - MOV [EAX].fLastKnownBlockIdx, EDX - LEA EAX, [EAX].fBlockList - CALL Free_And_Nil - POP EAX - {$ENDIF} - PUSH [EAX].fItems - XOR EDX, EDX - MOV [EAX].fItems, EDX - MOV [EAX].fCount, EDX - MOV [EAX].fCapacity, EDX - POP EAX - CALL System.@FreeMem -end; - -{$IFDEF ASM_NO_VERSION} -procedure TList.Add( Value: Pointer ); -asm - PUSH EDX - {$IFDEF TLIST_FAST} - //if fUseBlocks and ((fCount >= 256) or Assigned( fBlockList )) then - CMP [EAX].fUseBlocks, 0 - JZ @@old - MOV ECX, [EAX].fBlockList - CMP [EAX].fCount, 256 - JGE @@1 - JECXZ @@old -@@1: - PUSH EBX - PUSH ESI - XCHG EBX, EAX // EBX == @Self - MOV ESI, ECX - //if fBlockList = nil then - INC ECX - LOOP @@2 - CALL NewList - XCHG ESI, EAX // ESI == fBlockList - MOV [EBX].fBlockList, ESI //fBlockList := NewList; - MOV [ESI].fUseBlocks, 0 //fBlockList.fUseBlocks := FALSE; - XOR EDX, EDX - XCHG EDX, [EBX].fItems //fItems := nil; - MOV EAX, ESI - CALL TList.Add //fBlockList.Add( fItems ); - MOV EDX, [EBX].fCount - MOV EAX, ESI - CALL TList.Add //fBlockList.Add( Pointer( fCount ) ); -@@2: - //if fBlockList.fCount = 0 then - MOV ECX, [ESI].fCount - JECXZ @@2A - //LastBlockCount := Integer( fBlockList.fItems[ fBlockList.fCount-1 ] ); - MOV EDX, [ESI].fItems - MOV EAX, [EDX+ECX*4-4] - //if LastBlockCount >= 256 then - CMP EAX, 256 - JL @@3 -@@2A: - MOV EAX, ESI - XOR EDX, EDX - CALL TList.Add //fBlockList.Add( nil ); - MOV EAX, ESI - XOR EDX, EDX - CALL TList.Add //fBlockList.Add( nil ); - XOR EAX, EAX //LastBlockCount := 0; -@@3: - PUSH EAX - //LastBlockStart := fBlockList.Items[ fBlockList.fCount-2 ]; - MOV ECX, [ESI].fCount - MOV EDX, [ESI].fItems - LEA EDX, [EDX+ECX*4-8] - MOV EAX, [EDX] - //if LastBlockStart = nil then - TEST EAX, EAX - JNZ @@4 - //GetMem( LastBlockStart, 256 * Sizeof( Pointer ) ); - PUSH EDX - //MOV EAX, 1024 - XOR EAX, EAX - MOV AH, 4 - CALL System.@GetMem - POP EDX - //fBlockList.Items[ fBlockList.fCount-2 ] := LastBlockStart; - MOV [EDX], EAX -@@4: - //fBlockList.Items[ fBlockList.fCount-1 ] := Pointer( LastBlockCount+1 ); - INC dword ptr[EDX+4] - POP ECX // ECX == LastBlockCount - - //inc( fCount ); - INC [EBX].fCount - //PDWORD( Integer(LastBlockStart) + Sizeof(Pointer)*LastBlockCount )^ := - // DWORD( Value ); - - POP ESI - POP EBX - POP EDX // EDX == Value - MOV [EAX+ECX*4], EDX - RET -@@old: - {$ENDIF TLIST_FAST} - LEA ECX, [EAX].fCount - MOV EDX, [ECX] - INC dword ptr [ECX] - PUSH EDX - CMP EDX, [EAX].fCapacity - PUSH EAX - JL @@ok - - MOV ECX, [EAX].fAddBy - TEST ECX, ECX - JNZ @@add - MOV ECX, EDX - SHR ECX, 2 - INC ECX - @@add: - ADD EDX, ECX - CALL TList.SetCapacity -@@ok: - POP ECX // ECX = Self - POP EAX // EAX = fCount -> Result (for TList.Insert) - POP EDX // EDX = Value - - MOV ECX, [ECX].fItems - MOV [ECX + EAX*4], EDX -end; -{$ENDIF} - -{$IFDEF MoveItem_ASM} -procedure TList.MoveItem(OldIdx, NewIdx: Integer); -asm - CMP EDX, ECX - JE @@exit - - CMP ECX, [EAX].fCount - JGE @@exit - - PUSH EDI - - MOV EDI, [EAX].fItems - PUSH dword ptr [EDI + EDX*4] - PUSH ECX - PUSH EAX - CALL TList.Delete - POP EAX - POP EDX - POP ECX - - POP EDI - CALL TList.Insert -@@exit: -end; -{$ENDIF} - -procedure TList.Put( Idx: Integer; Value: Pointer ); -asm - TEST EDX, EDX - JL @@exit - CMP EDX, [EAX].fCount - JGE @@exit - PUSH ESI - MOV ESI, ECX - {$IFDEF TLIST_FAST} - CMP [EAX].fUseBlocks, 0 - JZ @@old - MOV ECX, [EAX].fBlockList - JECXZ @@old - PUSH EBX - PUSH ESI - PUSH EDI - PUSH EBP - XCHG EBX, EAX // EBX == @Self - XOR ECX, ECX // CountBefore := 0; - XOR EAX, EAX // i := 0; - CMP [EBX].fLastKnownBlockIdx, 0 - JLE @@1 - CMP EDX, [EBX].fLastKnownCountBefore - JL @@1 - MOV ECX, [EBX].fLastKnownCountBefore - MOV EAX, [EBX].fLastKnownBlockIdx -@@1: - MOV ESI, [EBX].fBlockList - MOV ESI, [ESI].fItems - MOV EDI, [ESI+EAX*8] // EDI = BlockStart - MOV ESI, [ESI+EAX*8+4] // ESI = CountCurrent - CMP ECX, EDX - JG @@next - LEA EBP, [ECX+ESI] - CMP EDX, EBP - JGE @@next - MOV [EBX].fLastKnownBlockIdx, EAX - MOV [EBX].fLastKnownCountBefore, ECX - SUB EDX, ECX - LEA EAX, [EDI+EDX*4] - POP EBP - POP EDI - POP ESI - POP EBX - MOV [EAX], ESI - POP ESI - RET -@@next: - ADD ECX, ESI - INC EAX - JMP @@1 -@@old: - {$ENDIF} - MOV EAX, [EAX].fItems - MOV [EAX+EDX*4], ESI - POP ESI -@@exit: -end; - -function TList.Get( Idx: Integer ): Pointer; -asm - TEST EDX, EDX - JL @@ret_nil - CMP EDX, [EAX].fCount - JGE @@ret_nil - {$IFDEF TLIST_FAST} - CMP [EAX].fUseBlocks, 0 - JZ @@old - CMP [EAX].fNotOptimized, 0 - JNZ @@slow - - MOV ECX, [EAX].fBlockList - JECXZ @@old - MOV ECX, [ECX].fItems - MOV EAX, EDX - SHR EAX, 8 - MOV ECX, dword ptr [ECX+EAX*8] - MOVZX EAX, DL - MOV EAX, dword ptr [ECX+EAX*4] - RET - -@@slow: - MOV ECX, [EAX].fBlockList - JECXZ @@old - PUSH EBX - PUSH ESI - PUSH EDI - PUSH EBP - XCHG EBX, EAX // EBX == @Self - XOR ECX, ECX // CountBefore := 0; - XOR EAX, EAX // i := 0; - CMP [EBX].fLastKnownBlockIdx, 0 - JLE @@1 - CMP EDX, [EBX].fLastKnownCountBefore - JL @@1 - MOV ECX, [EBX].fLastKnownCountBefore - MOV EAX, [EBX].fLastKnownBlockIdx -@@1: - MOV ESI, [EBX].fBlockList - MOV ESI, [ESI].fItems - MOV EDI, [ESI+EAX*8] // EDI = BlockStart - MOV ESI, [ESI+EAX*8+4] // ESI = CountCurrent - CMP ECX, EDX - JG @@next - LEA EBP, [ECX+ESI] - CMP EDX, EBP - JGE @@next - MOV [EBX].fLastKnownBlockIdx, EAX - MOV [EBX].fLastKnownCountBefore, ECX - SUB EDX, ECX - MOV EAX, [EDI+EDX*4] - POP EBP - POP EDI - POP ESI - POP EBX - RET -@@next: - ADD ECX, ESI - INC EAX - JMP @@1 -@@old: - {$ENDIF} - MOV EAX, [EAX].fItems - MOV EAX, [EAX+EDX*4] - RET -@@ret_nil: - XOR EAX, EAX -end; - -procedure TerminateExecution( var AppletCtl: PControl ); -asm - PUSH EBX - PUSH ESI - MOV BX, $0100 - XCHG BX, word ptr [AppletRunning] - XOR ECX, ECX - XCHG ECX, [Applet] - JECXZ @@exit - - PUSH EAX - - XCHG EAX, ECX - MOV ESI, EAX - CALL TObj.RefInc - - TEST BH, BH - JNZ @@closed - - MOV EAX, ESI - CALL TControl.ProcessMessages - PUSH 0 - PUSH 0 - PUSH WM_CLOSE - PUSH ESI - CALL TControl.Perform -@@closed: - POP EAX - XOR ECX, ECX - MOV dword ptr [EAX], ECX - MOV EAX, ESI - CALL TObj.RefDec - XCHG EAX, ESI - CALL TObj.RefDec -@@exit: - POP ESI - POP EBX -end; - -procedure Run( var AppletCtl: PControl ); -asm - CMP EAX, 0 - JZ @@exit - PUSH EBX - XCHG EBX, EAX - INC [AppletRunning] - MOV EAX, [EBX] - MOV [Applet], EAX - CALL CallTControlCreateWindow - JMP @@2 -@@1: - CALL WaitMessage - MOV EAX, [EBX] - CALL TControl.ProcessMessages - {$IFDEF USE_OnIdle} - MOV EAX, [EBX] - CALL [ProcessIdle] - {$ENDIF} -@@2: - MOVZX ECX, [AppletTerminated] - JECXZ @@1 - - MOV ECX, [EBX] - XCHG EAX, EBX - POP EBX - JECXZ @@exit - CALL TerminateExecution -@@exit: -end; - -function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush; -asm // // - {$IFDEF SMALLEST_CODE} - PUSH COLOR_BTNFACE - CALL GetSysColorBrush - {$ELSE} -@@1: MOV ECX, [EAX].TControl.fParent - JECXZ @@2 - MOV EDX, [EAX].TControl.fColor - CMP EDX, [ECX].TControl.fColor - XCHG EAX, ECX - JE @@1 - XCHG EAX, ECX -@@2: {$IFDEF STORE_fTmpBrushColorRGB} - PUSH EBX - XCHG EBX, EAX - MOV ECX, [EBX].TControl.fTmpBrush - JECXZ @@3 - MOV EAX, [EBX].TControl.fColor - CALL Color2RGB - CMP EAX, [EBX].TControl.fTmpBrushColorRGB - JE @@3 - XOR EAX, EAX - XCHG [EBX].TControl.fTmpBrush, EAX - PUSH EAX - CALL DeleteObject -@@3: MOV EAX, [EBX].TControl.fTmpBrush - TEST EAX, EAX - JNE @@4 - MOV EAX, [EBX].TControl.fColor - CALL Color2RGB - MOV [EBX].TControl.fTmpBrushColorRGB, EAX - PUSH EAX - CALL CreateSolidBrush - MOV [EBX].TControl.fTmpBrush, EAX -@@4: POP EBX - {$ELSE} - XCHG ECX, EAX - MOV EAX, [ECX].TControl.fTmpBrush - TEST EAX, EAX - JNZ @@ret_EAX - PUSH ECX - MOV EAX, [ECX].TControl.fColor - CALL Color2RGB - PUSH EAX - CALL CreateSolidBrush - POP ECX - MOV [ECX].TControl.fTmpBrush, EAX -@@ret_EAX: - {$ENDIF not STORE_fTmpBrushColorRGB} - {$ENDIF not SMALLEST_CODE} -end; - -function NormalGetCtlBrushHandle( Sender: PControl ): HBrush; -asm - PUSH ESI - PUSH [EAX].TControl.fParent - CALL TControl.GetBrush - XCHG ESI, EAX // ESI = Sender.Brush - POP ECX - JECXZ @@retHandle - XCHG EAX, ECX - CALL TControl.GetBrush - MOV [ESI].TGraphicTool.fParentGDITool, EAX -@@retHandle: - XCHG EAX, ESI - CALL TGraphicTool.GetHandle - POP ESI -end; - -function NewBrush: PGraphicTool; -asm - MOV [Global_GetCtlBrushHandle], offset NormalGetCtlBrushHandle - CALL _NewGraphicTool - MOV [EAX].TGraphicTool.fNewProc, offset[NewBrush] - MOV [EAX].TGraphicTool.fType, gttBrush - MOV [EAX].TGraphicTool.fMakeHandleProc, offset[MakeBrushHandle] - MOV [EAX].TGraphicTool.fData.Color, clBtnFace -end; - -function NewFont: PGraphicTool; -const FontDtSz = sizeof( TGDIFont ); -asm - MOV EAX, offset[DoApplyFont2Wnd] - MOV [ApplyFont2Wnd_Proc], EAX - CALL _NewGraphicTool - MOV [EAX].TGraphicTool.fNewProc, offset[NewFont] - MOV [EAX].TGraphicTool.fType, gttFont - MOV [EAX].TGraphicTool.fMakeHandleProc, offset[MakeFontHandle] - MOV EDX, [DefFontColor] - MOV [EAX].TGraphicTool.fData.Color, EDX - - PUSH EAX - LEA EDX, [EAX].TGraphicTool.fData.Font - MOV EAX, offset[ DefFont ] - XOR ECX, ECX - MOV CL, FontDtSz - CALL System.Move - POP EAX -end; - -function NewPen: PGraphicTool; -asm - CALL _NewGraphicTool - MOV [EAX].TGraphicTool.fNewProc, offset[NewPen] - MOV [EAX].TGraphicTool.fType, gttPen - MOV [EAX].TGraphicTool.fMakeHandleProc, offset[MakePenHandle] - MOV [EAX].TGraphicTool.fData.Pen.Mode, pmCopy -end; - -function Color2RGB( Color: TColor ): TColor; -asm - BTR EAX, 31 - JNC @@exit - AND EAX , $7F // <- a Fix Hallif - PUSH EAX - CALL GetSysColor -@@exit: -end; - -function Color2RGBQuad( Color: TColor ): TRGBQuad; -asm - CALL Color2RGB - // code by bart: - xchg ah,al // xxRRGGBB - ror eax,16 // BBGGxxRR - xchg ah,al // BBGGRRxx - shr eax,8 // 00BBGGRR -end; - -function Color2Color16( Color: TColor ): WORD; -asm - MOV EDX, EAX - SHR EDX, 19 - AND EDX, $1F - MOV ECX, EAX - SHR ECX, 5 - AND ECX, $7E0; - MOV AH, AL - AND EAX, $F800 - OR EAX, EDX - OR EAX, ECX -end; - -function TGraphicTool.Assign(Value: PGraphicTool): PGraphicTool; -const SzfData = sizeof( fData ); -asm // // - TEST EDX, EDX - JNZ @@1 - {$IFDEF OLD_REFCOUNT} - TEST EAX, EAX - JZ @@0 - CALL TObj.DoDestroy - {$ELSE} - CALL TObj.RefDec - {$ENDIF} - XOR EAX, EAX -@@0: RET -@@1: PUSH EDI - MOV EDI, EDX - TEST EAX, EAX - JNZ @@2 - XCHG EAX, EDX - CALL dword ptr[EAX].TGraphicTool.fNewProc -@@2: CMP EAX, EDI - JE @@exit - PUSH EBX - XCHG EBX, EAX - - MOV ECX, [EBX].TGraphicTool.fHandle - JECXZ @@3 - CMP ECX, [EDI].TGraphicTool.fHandle - JE @@exit1 -@@3: - MOV EAX, EBX - CALL TGraphicTool.Changed - LEA EDX, [EBX].TGraphicTool.fData - LEA EAX, [EDI].TGraphicTool.fData - MOV ECX, SzfData - CALL System.Move - MOV EAX, EBX - CALL TGraphicTool.Changed - -@@exit1: - XCHG EAX, EBX - POP EBX -@@exit: POP EDI -end; - -procedure TGraphicTool.Changed; -asm - XOR ECX, ECX - XCHG ECX, [EAX].fHandle - JECXZ @@exit - PUSH EAX - PUSH ECX - - CALL @@CallOnChange - - CALL DeleteObject - POP EAX -@@exit: - -@@CallOnChange: - MOV ECX, [EAX].fOnGTChange.TMethod.Code - JECXZ @@no_onChange - PUSH EAX - XCHG EDX, EAX - MOV EAX, [EDX].fOnGTChange.TMethod.Data - CALL ECX - POP EAX -@@no_onChange: -end; - -destructor TGraphicTool.Destroy; -asm - PUSH EAX - CMP [EAX].fType, gttFont - JE @@0 - MOV ECX, [EAX].fData.Brush.Bitmap - JECXZ @@0 - PUSH ECX - CALL DeleteObject - POP EAX - PUSH EAX -@@0: - MOV ECX, [EAX].fHandle - JECXZ @@1 - PUSH ECX - CALL DeleteObject -@@1: - POP EAX - CALL TObj.Destroy -end; - -function TGraphicTool.ReleaseHandle: Integer; -asm // // - PUSH EAX - CALL Changed - POP EDX - XOR EAX, EAX - XCHG [EDX].fHandle, EAX -end; - -procedure TGraphicTool.SetInt( const Index: Integer; Value: Integer ); -asm - LEA EDX, [EDX+EAX].fData - CMP [EDX], ECX - JE @@exit - MOV [EDX], ECX - CALL Changed -@@exit: -end; - -function TGraphicTool.IsFontTrueType: Boolean; -asm - CALL GetHandle - TEST EAX, EAX - JZ @@exit - - PUSH EBX - - PUSH EAX // fHandle - - PUSH 0 - CALL GetDC - - PUSH EAX // DC - MOV EBX, EAX - CALL SelectObject - PUSH EAX - - XOR ECX, ECX - PUSH ECX - PUSH ECX - PUSH ECX - PUSH ECX - PUSH EBX - CALL GetFontData - - XCHG EAX, [ESP] - - PUSH EAX - PUSH EBX - CALL SelectObject - - PUSH EBX - PUSH 0 - CALL ReleaseDC - - POP EAX - INC EAX - SETNZ AL - - POP EBX -@@exit: -end; - -procedure TextAreaEx( Sender: PCanvas; var Sz : TSize; var Pt : TPoint ); -asm - PUSH EBX - PUSH ESI - PUSH EDI - PUSH EBP - MOV EBP, ESP - PUSH EDX // [EBP-4] = @Sz - PUSH ECX // [EBP-8] = @Pt - MOV EBX, EAX - CALL TCanvas.GetFont - MOV ESI, [EAX].TGraphicTool.fData.Font.Orientation - CALL TGraphicTool.IsFontTrueType - TEST AL, AL - JZ @@exit - - MOV EDI, [EBP-8] - XOR EAX, EAX - STOSD - STOSD - TEST ESI, ESI - JZ @@exit - - PUSH EAX // Pts[1].x - PUSH EAX // Pts[1].y - - PUSH ESI - FILD dword ptr [ESP] - POP EDX - - FILD word ptr [@@1800] - FDIV - //FWAIT - FLDPI - FMUL - //FWAIT - - FLD ST(0) - FSINCOS - FWAIT - - MOV ESI, [EBP-4] - LODSD // Sz.cx - PUSH EAX - FILD dword ptr [ESP] - FMUL - FISTP dword ptr [ESP] // Pts[2].x - FWAIT - NEG EAX - PUSH EAX - FILD dword ptr [ESP] - FMUL - FISTP dword ptr [ESP] // Pts[2].y - FWAIT - - FLDPI - FLD1 - FLD1 - FADD - FDIV - FADD - FSINCOS - FWAIT - - LODSD - NEG EAX - PUSH EAX - FILD dword ptr [ESP] - FMUL - FISTP dword ptr [ESP] // Pts[4].x - FWAIT - NEG EAX - PUSH EAX - FILD dword ptr [ESP] - FMUL - FISTP dword ptr [ESP] // Pts[4].y - FWAIT - - POP ECX - POP EDX - PUSH EDX - PUSH ECX - ADD EDX, [ESP+12] - ADD ECX, [ESP+8] - PUSH EDX - PUSH ECX - - MOV ESI, ESP - XOR EDX, EDX // MinX - XOR EDI, EDI // MinY - XOR ECX, ECX - MOV CL, 3 - -@@loo1: LODSD - CMP EAX, EDI - JGE @@1 - XCHG EDI, EAX -@@1: LODSD - CMP EAX, EDX - JGE @@2 - XCHG EDX, EAX -@@2: LOOP @@loo1 - - MOV ESI, [EBP-4] - MOV [ESI], ECX - MOV [ESI+4], ECX - MOV CL, 4 -@@loo2: - POP EBX - SUB EBX, EDI - CMP EBX, [ESI+4] - JLE @@3 - MOV [ESI+4], EBX -@@3: - POP EAX - SUB EAX, EDX - CMP EAX, [ESI] - JLE @@4 - MOV [ESI], EAX -@@4: - LOOP @@loo2 - - MOV EDI, [EBP-8] - STOSD - XCHG EAX, EBX - STOSD - JMP @@exit - -@@1800: DW 1800 - -@@exit: - MOV ESP, EBP - POP EBP - POP EDI - POP ESI - POP EBX -end; - -procedure TGraphicTool.SetFontOrientation(Value: Integer); -asm - MOV byte ptr [GlobalGraphics_UseFontOrient], 1 - MOV [GlobalCanvas_OnTextArea], offset[TextAreaEx] - - PUSH EAX - XCHG EAX, EDX - MOV ECX, 3600 - CDQ - IDIV ECX // EDX = Value mod 3600 - POP EAX - - MOV [EAX].fData.Font.Escapement, EDX - MOV ECX, EDX - XOR EDX, EDX - MOV DL, go_FontOrientation - CALL SetInt -end; - -function TGraphicTool.GetFontStyle: TFontStyle; -asm - MOV EDX, dword ptr [EAX].fData.Font.Italic - AND EDX, $010101 - MOV EAX, [EAX].fData.Font.Weight - CMP EAX, 700 - SETGE AL //AL:1 = fsBold - ADD EDX, EDX - OR EAX, EDX //AL:2 = fsItalic - SHR EDX, 7 - OR EAX, EDX //AL:3 = fsUnderline - SHR EDX, 7 - OR EAX, EDX //AL:4 = fsStrikeOut -end; - -procedure TGraphicTool.SetFontStyle(const Value: TFontStyle); -asm - PUSH EDI - MOV EDI, EAX - PUSH EDX - CALL GetFontStyle - POP EDX - CMP AL, DL - JE @@exit - PUSH EDI - - LEA EDI, [EDI].fData.Font.Weight - MOV ECX, [EDI] - SHR EDX, 1 - JNC @@1 - CMP ECX, 700 - JGE @@2 - MOV ECX, 700 - JMP @@2 -@@1: CMP ECX, 700 - JL @@2 - XOR ECX, ECX -@@2: XCHG EAX, ECX - STOSD // change Weight - SHR EDX, 1 - SETC AL - STOSB // change Italic - SHR EDX, 1 - SETC AL - STOSB // change Underline - SHR EDX, 1 - SETC AL - STOSB // change StrikeOut - POP EAX - CALL Changed -@@exit: POP EDI -end; - -function TGraphicTool.GetHandle: THandle; -const DataSz = sizeof( TGDIToolData ); -asm - PUSH EBX -@@start: - XCHG EBX, EAX - MOV ECX, [EBX].fHandle - JECXZ @@1 - - MOV EAX, [EBX].fData.Color - CALL Color2RGB - CMP EAX, [EBX].fColorRGB - JE @@1 - - MOV EAX, EBX - CALL ReleaseHandle - PUSH EAX - CALL DeleteObject - -@@1: MOV ECX, [EBX].fHandle - INC ECX - LOOP @@exit - - MOV ECX, [EBX].fParentGDITool - JECXZ @@2 - LEA EDX, [ECX].fData - LEA EAX, [EBX].fData - MOV ECX, DataSz - CALL CompareMem - TEST AL, AL - MOV EAX, [EBX].fParentGDITool - JNZ @@start - -@@2: MOV EAX, [EBX].fData.Color - CALL Color2RGB - MOV [EBX].fColorRGB, EAX - XCHG EAX, EBX - CALL dword ptr [EAX].fMakeHandleProc - XCHG ECX, EAX - -@@exit: XCHG EAX, ECX - POP EBX -end; - -function MakeBrushHandle( Self_: PGraphicTool ): THandle; -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, [EBX].TGraphicTool.fHandle - TEST EAX, EAX - JNZ @@exit - - MOV EAX, [EBX].TGraphicTool.fData.Color - CALL Color2RGB // EAX = ColorRef - - XOR EDX, EDX - - MOV ECX, [EBX].TGraphicTool.fData.Brush.Bitmap - PUSH ECX - JECXZ @@1 - - MOV DL, BS_PATTERN - JMP @@2 - -@@1: - MOV CL, [EBX].TGraphicTool.fData.Brush.Style - MOV DL, CL - SUB CL, 2 - JL @@2 - - XCHG ECX, [ESP] - MOV EAX, [EBX].TGraphicTool.fData.Brush.LineColor - CALL Color2RGB - XOR EDX, EDX - MOV DL, BS_HATCHED - -@@2: PUSH EAX - PUSH EDX - - PUSH ESP - CALL CreateBrushIndirect - MOV [EBX].TGraphicTool.fHandle, EAX - - ADD ESP, 12 - -@@exit: - POP EBX -end; - -function MakePenHandle( Self_: PGraphicTool ): THandle; -asm - PUSH EBX - MOV EBX, EAX - - MOV EAX, [EBX].TGraphicTool.fHandle - TEST EAX, EAX - JNZ @@exit - - MOV EAX, [EBX].TGraphicTool.fData.Color - CALL Color2RGB - PUSH EAX - PUSH EAX - PUSH [EBX].TGraphicTool.fData.Pen.Width - MOVZX EAX, [EBX].TGraphicTool.fData.Pen.Style - PUSH EAX - PUSH ESP - CALL CreatePenIndirect - MOV [EBX].TGraphicTool.fHandle, EAX - ADD ESP, 16 -@@exit: - POP EBX -end; - -function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle; -asm - MOV ECX, [EAX].TGraphicTool.fHandle - INC ECX - LOOP @@exit - - PUSH EBX - XCHG EBX, EAX - MOV EAX, [EBX].TGraphicTool.fData.Color - CALL Color2RGB // EAX = Color2RGB( fColor ) - CDQ // EDX = lbHatch (0) - MOV ECX, [EBX].TGraphicTool.fData.Pen.BrushBitmap - JECXZ @@no_brush_bitmap - - XCHG EDX, ECX // lbHatch = fPenBrushBitmap - MOV CL, BS_PATTERN // = 3 - JMP @@create_pen - -@@no_brush_bitmap: - MOVZX ECX, [EBX].TGraphicTool.fData.Pen.BrushStyle - CMP CL, 1 - JLE @@create_pen - MOV EDX, ECX - MOV CL, 2 - SUB EDX, ECX - -@@create_pen: - PUSH EDX - PUSH EAX - PUSH ECX - MOV ECX, ESP - - CDQ - PUSH EDX - PUSH EDX - PUSH ECX - PUSH [EBX].TGraphicTool.fData.Pen.Width - MOVZX ECX, [EBX].TGraphicTool.fData.Pen.Join - SHL ECX, 12 - MOVZX EDX, [EBX].TGraphicTool.fData.Pen.EndCap - SHL EDX, 8 - OR EDX, ECX - OR DL, byte ptr [EBX].TGraphicTool.fData.Pen.Style - OR EDX, PS_GEOMETRIC - PUSH EDX - CALL ExtCreatePen - - POP ECX - POP ECX - POP ECX - - MOV [EBX].TGraphicTool.fHandle, EAX - POP EBX - RET -@@exit: - XCHG EAX, ECX -end; - -function TCanvas.Assign(SrcCanvas: PCanvas): Boolean; -asm - PUSH EBX - PUSH ESI - XCHG EBX, EAX - MOV ESI, EDX - - MOV EAX, [EBX].fFont - MOV EDX, [ESI].fFont - CALL TGraphicTool.Assign - MOV [EBX].fFont, EAX - - MOV EAX, [EBX].fBrush - MOV EDX, [ESI].fBrush - CALL TGraphicTool.Assign - MOV [EBX].fBrush, EAX - - MOV EAX, [EBX].fPen - MOV EDX, [ESI].fPen - CALL TGraphicTool.Assign - MOV [EBX].fPen, EAX - - CALL AssignChangeEvents - - MOV ECX, [EBX].fFont - OR ECX, [EBX].fBrush - OR ECX, [EBX].fPen - SETNZ AL - - MOV EDX, [ESI].fPenPos.x - MOV ECX, [ESI].fPenPos.y - CMP EDX, [EBX].fPenPos.x - JNE @@chg_penpos - CMP ECX, [EBX].fPenPos.y - JE @@1 -@@chg_penpos: - MOV AL, 1 - MOV [EBX].fPenPos.x, EDX - MOV [EBX].fPenPos.y, ECX -@@1: - MOV EDX, [ESI].fCopyMode - CMP EDX, [EBX].fCopyMode - JE @@2 - MOV [EBX].fCopyMode, EDX - MOV AL, 1 -@@2: - POP ESI - POP EBX -end; - -procedure TCanvas.CreateBrush; -asm - PUSH EBX - MOV EBX, EAX - - MOV ECX, [EAX].fBrush - JECXZ @@chk_owner - - MOV EAX, ECX - CALL TGraphicTool.GetHandle - PUSH EAX - - MOV EAX, EBX - CALL AssignChangeEvents - - MOV EAX, EBX - CALL TCanvas.GetHandle - PUSH EAX - - CALL SelectObject - - MOV EDX, [EBX].TCanvas.fBrush - CMP [EDX].TGraphicTool.fData.Brush.Style, bsSolid - - MOV EAX, [EDX].TGraphicTool.fData.Color -@@0: - MOV EBX, [EBX].TCanvas.fHandle - MOV ECX, offset[Color2RGB] - JNZ @@1 - - PUSH OPAQUE - PUSH EBX - - CALL ECX //Color2RGB - PUSH EAX - PUSH EBX - JMP @@2 -@@1: - PUSH TRANSPARENT - PUSH EBX - - CALL ECX //Color2RGB - NOT EAX - PUSH EAX - PUSH EBX -@@2: - CALL SetBkColor - CALL SetBkMode -@@exit: - POP EBX - RET - -@@chk_owner: - MOV ECX, [EBX].fOwnerControl - JECXZ @@exit - - MOV EAX, [ECX].TControl.fColor - XOR ECX, ECX - JMP @@0 -end; - -procedure TCanvas.CreateFont; -asm - PUSH EBX - MOV EBX, EAX - - MOV ECX, [EAX].TCanvas.fFont - JECXZ @@chk_owner - - MOV EAX, [ECX].TGraphicTool.fData.Color - PUSH ECX - CALL Color2RGB - XCHG EAX, [ESP] - - CALL TGraphicTool.GetHandle - PUSH EAX - - MOV EAX, EBX - CALL AssignChangeEvents; - - MOV EAX, EBX - CALL TCanvas.GetHandle - PUSH EAX - MOV EBX, EAX - - CALL SelectObject - -@@set_txcolor: - PUSH EBX - CALL SetTextColor - -@@exit: - POP EBX - RET - -@@chk_owner: - MOV ECX, [EBX].fOwnerControl - JECXZ @@exit - - MOV EBX, [EBX].fHandle - MOV EAX, [ECX].TControl.fTextColor - CALL Color2RGB - PUSH EAX - JMP @@set_txcolor -end; - -procedure TCanvas.CreatePen; -asm - MOV ECX, [EAX].TCanvas.fPen - JECXZ @@exit - - PUSH EBX - MOV EBX, EAX - - MOV DL, [ECX].TGraphicTool.fData.Pen.Mode - MOVZX EDX, DL - INC EDX - PUSH EDX - - MOV EAX, ECX - CALL TGraphicTool.GetHandle - PUSH EAX - - MOV EAX, EBX - CALL AssignChangeEvents - - MOV EAX, EBX - CALL TCanvas.GetHandle - PUSH EAX - MOV EBX, EAX - - CALL SelectObject - PUSH EBX - CALL SetROP2 - - POP EBX -@@exit: -end; - -procedure TCanvas.DeselectHandles; -asm - PUSH EBX - PUSH ESI - PUSH EDI - LEA EBX, [EAX].TCanvas.fState - //CALL TCanvas.GetHandle - MOV EAX, [EAX].TCanvas.fHandle - TEST EAX, EAX - JZ @@exit - - MOVZX EDX, byte ptr[EBX] - AND DL, PenValid or BrushValid or FontValid - JZ @@exit - - PUSH EAX - LEA EDI, [Stock] - - MOV ECX, [EDI] - INC ECX - LOOP @@1 - - MOV ESI, offset[ GetStockObject ] - - PUSH BLACK_PEN - CALL ESI - STOSD - - PUSH HOLLOW_BRUSH - CALL ESI - STOSD - - PUSH SYSTEM_FONT - CALL ESI - STOSD - -@@1: - LEA ESI, [Stock] - POP EDX - - LODSD - PUSH EAX - PUSH EDX - - LODSD - PUSH EAX - PUSH EDX - - LODSD - PUSH EAX - PUSH EDX - - MOV ESI, offset[ SelectObject ] - CALL ESI - CALL ESI - CALL ESI - - AND byte ptr [EBX], not( PenValid or BrushValid or FontValid ) -@@exit: - POP EDI - POP ESI - POP EBX -end; - -function TCanvas.RequiredState(ReqState: DWORD): HDC; stdcall; -asm - PUSH EBX - PUSH ESI - MOV EBX, ReqState - MOV ESI, [EBP+8] //Self - MOV EAX, ESI - TEST BL, ChangingCanvas - JZ @@1 - CALL Changing -@@1: AND BL, 0Fh - - TEST BL, HandleValid - JZ @@2 - CALL TCanvas.GetHandle - TEST EAX, EAX - JZ @@ret_0 -@@2: - MOV AL, [ESI].TCanvas.fState - NOT EAX - AND BL, AL - JZ @@ret_handle - - TEST BL, FontValid - JZ @@3 - MOV EAX, ESI - CALL CreateFont -@@3: TEST BL, PenValid - JZ @@5 - MOV EAX, ESI - CALL CreatePen - MOV ECX, [ESI].TCanvas.fPen - JCXZ @@5 - MOV AL, [ECX].TGraphicTool.fData.Pen.Style - DEC AL - {$IFDEF PARANOIA} DB $2C, 3 {$ELSE} SUB AL, 3 {$ENDIF} - JB @@6 -@@5: TEST BL, BrushValid - JZ @@7 -@@6: MOV EAX, ESI - CALL CreateBrush -@@7: OR [ESI].TCanvas.fState, BL -@@ret_handle: - MOV EAX, [ESI].TCanvas.fHandle -@@ret_0: - POP ESI - POP EBX -end; - -procedure TCanvas.SetHandle(Value: HDC); -asm - PUSH EBX - PUSH ESI - MOV ESI, EDX // ESI = Value - MOV EBX, EAX // EAX = @ Self - MOV ECX, [EBX].fHandle // ECX = fHandle (before) - CMP ECX, ESI // compare with new Value in EDX - JZ @@exit // equal? -> nothing to do - JECXZ @@chk_val // fHandle = 0? -> check new value in EDX - - PUSH ECX // fHandle - CALL DeselectHandles - POP EDX // fHandle - - MOV ECX, [EBX].fOwnerControl - JECXZ @@chk_Release - CMP [ECX].TControl.fPaintDC, EDX - JE @@clr_Handle - -@@chk_Release: - CMP [EBX].fOnGetHandle.TMethod.Code, offset[TControl.DC2Canvas] - JNE @@deldc - PUSH EDX // fHandle - PUSH [ECX].TControl.fHandle - CALL ReleaseDC - JMP @@clr_Handle -@@deldc: - CMP WORD PTR [EBX].fIsPaintDC, 0 - JNZ @@clr_Handle - PUSH EDX // fHandle - CALL DeleteDC - -@@clr_Handle: - XOR ECX, ECX - MOV [EBX].TCanvas.fHandle, ECX - MOV [EBX].TCanvas.fIsPaintDC, CL - AND [EBX].TCanvas.fState, not HandleValid - -@@chk_val: - TEST ESI, ESI - JZ @@exit - - OR [EBX].TCanvas.fState, HandleValid - MOV [EBX].TCanvas.fHandle, ESI - LEA EDX, [EBX].TCanvas.fPenPos - MOV EAX, EBX - CALL SetPenPos - -@@exit: POP ESI - POP EBX -end; - -procedure TCanvas.SetPenPos(const Value: TPoint); -asm - MOV ECX, [EDX].TPoint.y - MOV EDX, [EDX].TPoint.x - MOV [EAX].fPenPos.x, EDX - MOV [EAX].fPenPos.y, ECX - CALL MoveTo -end; - -procedure TCanvas.Changing; -asm - PUSHAD - MOV ECX, [EAX].fOnChangeCanvas.TMethod.Code - JECXZ @@exit - XCHG EDX, EAX - MOV EAX, [EDX].fOnChangeCanvas.TMethod.Data - CALL ECX -@@exit: - POPAD -end; - -procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall; -asm - PUSH ESI - - PUSH HandleValid or PenValid or ChangingCanvas - PUSH dword ptr [EBP+8] - CALL RequiredState - - MOV EDX, EAX - - LEA ESI, [Y4] - STD - - XOR ECX, ECX - MOV CL, 8 -@@1: - LODSD - PUSH EAX - - LOOP @@1 - - CLD - PUSH EDX //Canvas.fHandle - CALL Windows.Arc - POP ESI -end; - -procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall; -asm - PUSH HandleValid or PenValid or BrushValid or ChangingCanvas - PUSH dword ptr [EBP + 8] - CALL RequiredState - - MOV EDX, EAX - - PUSH ESI - LEA ESI, [Y4] - STD - - XOR ECX, ECX - MOV CL, 8 -@@1: - LODSD - PUSH EAX - - LOOP @@1 - - CLD - PUSH EDX //Canvas.fHandle - CALL Chord - POP ESI -end; - -procedure TCanvas.CopyRect(const DstRect: TRect; SrcCanvas: PCanvas; - const SrcRect: TRect); -asm - PUSH ESI - PUSH EDI - - PUSH [EAX].fCopyMode - - PUSH EDX - - PUSH HandleValid or BrushValid - PUSH ECX - - PUSH HandleValid or FontValid or BrushValid or ChangingCanvas - PUSH EAX - MOV ESI, offset[ RequiredState ] - CALL ESI - MOV EDI, EAX // EDI = @Self.fHandle - - CALL ESI - MOV EDX, EAX // EDX = SrcCanvas.fHandle - - POP ECX // ECX = @DstRect - - MOV ESI, [SrcRect] - - MOV EAX, [ESI].TRect.Bottom - SUB EAX, [ESI].TRect.Top - PUSH EAX - - MOV EAX, [ESI].TRect.Right - SUB EAX, [ESI].TRect.Left - PUSH EAX - - PUSH [ESI].TRect.Top - - LODSD - PUSH EAX - - PUSH EDX - - MOV EAX, [ECX].TRect.Bottom - MOV EDX, [ECX].TRect.Top - SUB EAX, EDX - PUSH EAX - - MOV EAX, [ECX].TRect.Right - MOV ESI, [ECX].TRect.Left - SUB EAX, ESI - PUSH EAX - - PUSH EDX - - PUSH ESI - - PUSH EDI - - CALL StretchBlt - - POP EDI - POP ESI -end; - -procedure TCanvas.DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); -asm - PUSH EDX - - PUSH HandleValid or BrushValid or FontValid or ChangingCanvas - PUSH EAX - CALL RequiredState - - PUSH EAX - CALL Windows.DrawFocusRect -end; - -procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer); -asm - PUSH [Y2] - PUSH [X2] - PUSH ECX - PUSH EDX - - PUSH HandleValid or PenValid or BrushValid or ChangingCanvas - PUSH EAX - CALL RequiredState - - PUSH EAX - CALL Windows.Ellipse -end; - -procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); -asm - PUSH EBX - XCHG EBX, EAX - PUSH EDX - PUSH HandleValid or BrushValid or ChangingCanvas - PUSH EBX - CALL RequiredState - MOV ECX, [EBX].fBrush - JECXZ @@chk_ctl - -@@fill_with_Brush: - XCHG EAX, ECX - CALL TGraphicTool.GetHandle - POP EDX - PUSH EAX - JMP @@fin -@@chk_ctl: - MOV ECX, [EBX].fOwnerControl - JECXZ @@dflt_fill - XCHG EAX, ECX - MOV ECX, [EAX].TControl.fBrush - INC ECX - LOOP @@fill_with_Brush - MOV EAX, [EAX].TControl.fColor - CALL Color2RGB - PUSH EAX - CALL CreateSolidBrush - POP EDX - PUSH EAX - PUSH EAX - PUSH EDX - PUSH [EBX].fHandle - CALL Windows.FillRect - CALL DeleteObject - POP EBX - RET -@@dflt_fill: - POP EDX - PUSH COLOR_WINDOW + 1 -@@fin: - PUSH EDX - PUSH [EBX].fHandle - CALL Windows.FillRect - POP EBX -end; - -procedure TCanvas.FillRgn(const Rgn: HRgn); -asm - PUSH EBX - XCHG EBX, EAX - PUSH EDX - - PUSH HandleValid or BrushValid or ChangingCanvas - PUSH EBX - CALL RequiredState - - MOV ECX, [EBX].TCanvas.fBrush - JECXZ @@1 - -@@fill_rgn_using_Brush: - XCHG EAX, ECX - CALL TGraphicTool.GetHandle - POP EDX - PUSH EAX - PUSH EDX - PUSH [EBX].fHandle - CALL Windows.FillRgn - JMP @@fin - -@@1: MOV ECX, [EBX].TCanvas.fOwnerControl - MOV EAX, -1 // clWhite - JECXZ @@2 - - XCHG EAX, ECX - MOV ECX, [EAX].TControl.fBrush - INC ECX - LOOP @@fill_rgn_using_Brush - - MOV EAX, [EAX].TControl.fColor -@@2: - CALL Color2RGB - PUSH EAX - CALL CreateSolidBrush // EAX = Br - - POP EDX // Rgn - - PUSH EAX //-------------------// - PUSH EAX // Br - PUSH EDX // Rgn - PUSH [EBX].FHandle // fHandle - CALL Windows.FillRgn - - CALL DeleteObject - -@@fin: - POP EBX -end; - -procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor; - FillStyle: TFillStyle); -asm - PUSH EBX - MOV EBX, EAX - - MOVZX EAX, [FillStyle] - TEST EAX, EAX - MOV EAX, FLOODFILLSURFACE // = 1 - JZ @@1 - //MOV EAX, FLOODFILLBORDER // = 0 - DEC EAX -@@1: - PUSH EAX - PUSH [Color] - PUSH ECX - PUSH EDX - - PUSH HandleValid or BrushValid or ChangingCanvas - PUSH EBX - CALL RequiredState - PUSH EAX - CALL Windows.ExtFloodFill - - POP EBX -end; - -procedure TCanvas.FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); -asm - PUSH EBX - XCHG EBX, EAX - PUSH EDX - - MOV ECX, [EBX].TCanvas.fBrush - JECXZ @@1 - - PUSH [ECX].TGraphicTool.fData.Color - JMP @@cr_br - -@@1: MOV ECX, [EBX].TCanvas.fOwnerControl - JECXZ @@2 - - PUSH [ECX].TControl.fColor - JMP @@cr_br - -@@2: PUSH clWhite -@@cr_br:POP EAX // @Rect - CALL Color2RGB - PUSH EAX - CALL CreateSolidBrush - POP EDX - PUSH EAX - PUSH EAX - PUSH EDX - - PUSH HandleValid or ChangingCanvas - PUSH EBX - CALL RequiredState - - PUSH EAX - CALL Windows.FrameRect - - CALL DeleteObject - - POP EBX -end; - -procedure TCanvas.LineTo(X, Y: Integer); -asm - PUSH ECX - PUSH EDX - PUSH HandleValid or PenValid or BrushValid or ChangingCanvas - PUSH EAX - CALL RequiredState - PUSH EAX //Canvas.fHandle - CALL Windows.LineTo -end; - -procedure TCanvas.MoveTo(X, Y: Integer); -asm - PUSH 0 - PUSH ECX - PUSH EDX - PUSH HandleValid - PUSH EAX - CALL RequiredState - PUSH EAX //Canvas.fHandle - CALL Windows.MoveToEx -end; - -procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall; -asm - PUSH HandleValid or PenValid or BrushValid or ChangingCanvas - PUSH dword ptr [EBP + 8] - CALL RequiredState - - MOV EDX, EAX - - PUSH ESI - LEA ESI, [Y4] - STD - - XOR ECX, ECX - MOV CL, 8 -@@1: - LODSD - PUSH EAX - - LOOP @@1 - - CLD - PUSH EDX //Canvas.fHandle - CALL Windows.Pie - POP ESI -end; - -procedure TCanvas.Polygon(const Points: array of TPoint); -asm - INC ECX - PUSH ECX - PUSH EDX - - PUSH HandleValid or PenValid or BrushValid or ChangingCanvas - PUSH EAX - CALL RequiredState - - PUSH EAX - CALL Windows.Polygon -end; - -procedure TCanvas.Polyline(const Points: array of TPoint); -asm - INC ECX - PUSH ECX - PUSH EDX - - PUSH HandleValid or PenValid or BrushValid or ChangingCanvas - PUSH EAX - CALL RequiredState - - PUSH EAX - CALL Windows.Polyline -end; - -procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer); -asm - PUSH [Y2] - PUSH [X2] - PUSH ECX - PUSH EDX - - PUSH HandleValid or BrushValid or PenValid or ChangingCanvas - PUSH EAX - CALL RequiredState - - PUSH EAX - CALL Windows.Rectangle -end; - -procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer); -asm - PUSH [Y3] - PUSH [X3] - PUSH [Y2] - PUSH [X2] - PUSH ECX - PUSH EDX - - PUSH HandleValid or BrushValid or PenValid or ChangingCanvas - PUSH EAX - CALL RequiredState - - PUSH EAX - CALL Windows.RoundRect -end; - -procedure TCanvas.TextArea(const Text: KOLString; var Sz: TSize; - var P0: TPoint); -asm - PUSH EBX - MOV EBX, EAX - - PUSH ECX - CALL TextExtent - POP EDX - - MOV ECX, [P0] - XOR EAX, EAX - MOV [ECX].TPoint.x, EAX - MOV [ECX].TPoint.y, EAX - - CMP [GlobalCanvas_OnTextArea], EAX - JZ @@exit - MOV EAX, EBX - CALL [GlobalCanvas_OnTextArea] - -@@exit: - POP EBX -end; - -procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: Ansistring); -asm - PUSH EBX - XCHG EBX, EAX - - PUSH 0 // prepare 0 - - PUSH EDX - PUSH ECX - - MOV EAX, [Text] - PUSH EAX - CALL System.@LStrLen - - POP ECX // ECX = @Text[1] - POP EDX // EDX = X - XCHG EAX, [ESP] // prepare Length(Text), EAX = @Rect - PUSH ECX // prepare PChar(Text) - PUSH EAX // prepare @Rect - - XOR EAX, EAX - MOV AL, ETO_CLIPPED // = 4 - MOV ECX, [EBX].fBrush - JECXZ @@opaque - - CMP [ECX].TGraphicTool.fData.Brush.Style, bsClear - JZ @@txtout - -@@opaque: - DB $0C, ETO_OPAQUE //OR AL, ETO_OPAQUE -@@txtout: - PUSH EAX // prepare Options - PUSH [Y] // prepare Y - PUSH EDX // prepare X - - PUSH HandleValid or FontValid or BrushValid or ChangingCanvas - PUSH EBX - CALL RequiredState // EAX = fHandle - PUSH EAX // prepare fHandle - - CALL Windows.ExtTextOutA // KOL_ANSI - - POP EBX -end; - -procedure TCanvas.DrawText(Text: AnsiString; var Rect:TRect; Flags:DWord); -asm - PUSH [Flags] - PUSH ECX - PUSH -1 - CALL EDX2PChar - PUSH EDX - - PUSH HandleValid or FontValid or BrushValid or ChangingCanvas - PUSH EAX - CALL RequiredState - PUSH EAX - CALL Windows.DrawTextA -end; - -function TCanvas.GetBrush: PGraphicTool; -asm - MOV ECX, [EAX].fBrush - INC ECX - LOOP @@exit - - PUSH EAX - CALL NewBrush - POP EDX - PUSH EAX - - MOV [EDX].fBrush, EAX - - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Code, Offset[TCanvas.ObjectChanged] - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Data, EDX - MOV ECX, [EDX].fOwnerControl - JECXZ @@1 - - PUSH [ECX].TControl.fBrush - MOV ECX, [ECX].TControl.fColor - MOV [EAX].TGraphicTool.fData.Color, ECX - POP EDX - TEST EDX, EDX - JZ @@1 - - CALL TGraphicTool.Assign - -@@1: POP ECX - -@@exit: XCHG EAX, ECX -end; - -function TCanvas.GetFont: PGraphicTool; -asm - MOV ECX, [EAX].TCanvas.fFont - INC ECX - LOOP @@exit - - PUSH EAX - CALL NewFont - POP EDX - PUSH EAX - - MOV [EDX].TCanvas.fFont, EAX - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Code, Offset[TCanvas.ObjectChanged] - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Data, EDX - - MOV ECX, [EDX].fOwnerControl - JECXZ @@1 - - PUSH [ECX].TControl.fFont - MOV ECX, [ECX].TControl.fTextColor - MOV [EAX].TGraphicTool.fData.Color, ECX - POP EDX - TEST EDX, EDX - JZ @@1 - - CALL TGraphicTool.Assign - -@@1: POP ECX - -@@exit: MOV EAX, ECX -end; - -function TCanvas.GetPen: PGraphicTool; -asm - MOV ECX, [EAX].TCanvas.fPen - INC ECX - LOOP @@exit - - PUSH EAX - CALL NewPen - POP EDX - MOV [EDX].fPen, EAX - PUSH EAX - MOV EAX, EDX - CALL AssignChangeEvents - POP ECX - -@@exit: MOV EAX, ECX -end; - -function TCanvas.GetHandle: HDC; -asm - CMP word ptr[EAX].fOnGetHandle.TMethod.Code+2, 0 - MOV EDX, EAX - MOV EAX, [EDX].fHandle - JZ @@exit - MOV EAX, [EDX].fOnGetHandle.TMethod.Data - PUSH EDX - CALL [EDX].fOnGetHandle.TMethod.Code - XCHG EAX, [ESP] - POP EDX - PUSH EDX - CALL SetHandle - POP EAX -@@exit: -end; - -procedure TCanvas.AssignChangeEvents; -asm - PUSH ESI - LEA ESI, [EAX].fBrush - MOV CL, 3 - MOV EDX, EAX -@@1: LODSD - TEST EAX, EAX - JZ @@nxt - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Data, EDX - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Code, offset[ ObjectChanged ] -@@nxt: DEC CL - JNZ @@1 - POP ESI -end; - -function Mul64i( const X: I64; Mul: Integer ): I64; -asm //cmd //opd - TEST EDX, EDX - PUSHFD - JGE @@1 - NEG EDX -@@1: PUSH ECX - CALL Mul64EDX - POP EAX - POPFD - JGE @@2 - MOV EDX, EAX - CALL Neg64 -@@2: -end; - -function Div64i( const X: I64; D: Integer ): I64; -asm //cmd //opd - PUSH EBX - XOR EBX, EBX - PUSH ESI - XCHG ESI, EAX - LODSD - MOV [ECX], EAX - LODSD - MOV [ECX+4], EAX - MOV ESI, ECX - PUSH EDX - XCHG EAX, ECX - CALL Sgn64 - TEST EAX, EAX - JGE @@1 - INC EBX - MOV EAX, ESI - MOV EDX, ESI - CALL Neg64 -@@1: POP EDX - TEST EDX, EDX - JGE @@2 - XOR EBX, 1 - NEG EDX -@@2: MOV EAX, ESI - MOV ECX, ESI - CALL Div64EDX - DEC EBX - JNZ @@3 - MOV EDX, ESI - XCHG EAX, ESI - CALL Neg64 -@@3: POP ESI - POP EBX -end; - -function cHex2Int( const Value : KOLString) : Integer; -asm - TEST EAX, EAX - JZ @@exit - CMP word ptr [EAX], '0x' - JZ @@skip_2_chars - CMP word ptr [EAX], '0X' - JNZ @@2Hex2Int -@@skip_2_chars: - INC EAX - INC EAX -@@2Hex2Int: - JMP Hex2Int -@@exit: -end; - -function Trim( const S : KOLString): KOLString; -asm - PUSH EDX - CALL TrimRight - POP EDX - MOV EAX, [EDX] - CALL TrimLeft -end; - -function LowerCase(const S: Ansistring): Ansistring; -asm - PUSH ESI - XCHG EAX, EDX - PUSH EAX - CALL System.@LStrAsg - POP EAX - - CALL UniqueString - - PUSH EAX - CALL System.@LStrLen - POP ESI - - XCHG ECX, EAX - - JECXZ @@exit - -@@go: - LODSB - {$IFDEF PARANOIA} DB $2C, 'A' {$ELSE} SUB AL, 'A' {$ENDIF} - {$IFDEF PARANOIA} DB $3C, 26 {$ELSE} CMP AL, 'Z'-'A'+1 {$ENDIF} - JNB @@1 - - ADD byte ptr [ESI - 1], 20h -@@1: - LOOP @@go -@@exit: - POP ESI -end; - -function UpperCase(const S: Ansistring): Ansistring; -asm - PUSH ESI - XCHG EAX, EDX - PUSH EAX - CALL System.@LStrAsg - POP EAX - - CALL UniqueString - - PUSH EAX - CALL System.@LStrLen - POP ESI - - XCHG ECX, EAX - - JECXZ @@exit - -@@go: - LODSB - {$IFDEF PARANOIA} DB $2C, 'a' {$ELSE} SUB AL, 'a' {$ENDIF} - {$IFDEF PARANOIA} DB $3C, $1A {$ELSE} CMP AL, 'z'-'a'+1 {$ENDIF} - JNB @@1 - - SUB byte ptr [ESI - 1], 20h -@@1: - LOOP @@go -@@exit: - POP ESI -end; - -function AllocMem( Size : Integer ) : Pointer; -asm //cmd //opd - TEST EAX, EAX - JZ @@exit - PUSH EAX - CALL System.@GetMem - POP EDX - PUSH EAX - //MOV CL, 0 - CALL ZeroMemory - POP EAX -@@exit: -end; - -function _WStrComp(S1, S2: PWideChar): Integer; -asm - PUSH ESI - XCHG ESI, EAX - XOR EAX, EAX -@@1: - LODSW - MOV ECX, EAX - SUB AX, word ptr [EDX] - JNZ @@exit - JECXZ @@exit - INC EDX - INC EDX - JMP @@1 -@@exit: - MOVSX EAX, AX - POP ESI -end; - -function _AnsiCompareStrA_Fast2(S1, S2: PAnsiChar): Integer; -asm - CALL EAX2PChar - CALL EDX2PChar - PUSH ESI - XCHG ESI, EAX - XOR EAX, EAX -@@1: - LODSB - MOV CX, word ptr [EAX*2 + SortAnsiOrder] - MOV AL, [EDX] - SUB CX, word ptr [EAX*2 + SortAnsiOrder] - JNZ @@retCL - INC EDX - TEST AL, AL - JNZ @@1 -@@retCL: - MOVSX EAX, CX - POP ESI -end; - -function _AnsiCompareStrNoCaseA_Fast2(S1, S2: PAnsiChar): Integer; -asm - CALL EAX2PChar - CALL EDX2PChar - PUSH ESI - XCHG ESI, EAX - XOR EAX, EAX -@@1: - LODSB - MOV CX, word ptr [EAX*2 + SortAnsiOrderNoCase] - MOV AL, [EDX] - SUB CX, word ptr [EAX*2 + SortAnsiOrderNoCase] - JNZ @@retCL - INC EDX - TEST AL, AL - JNZ @@1 -@@retCL: - MOVSX EAX, CX - POP ESI -end; - -function StrPCopy(Dest: PAnsiChar; const Source: Ansistring): PAnsiChar; -asm - PUSH EAX - MOV EAX, EDX - CALL System.@LStrLen - MOV ECX, EAX - POP EAX - CALL EDX2PChar - CALL StrLCopy -end; - -function StrEq( const S1, S2 : AnsiString ) : Boolean; -asm - TEST EDX, EDX - JNZ @@1 -@@0: CMP EAX, EDX - JMP @@exit -@@1: TEST EAX, EAX - JZ @@0 - MOV ECX, [EAX-4] - CMP ECX, [EDX-4] - JNE @@exit - PUSH EAX - PUSH EDX - PUSH 0 - MOV EDX, ESP - CALL LowerCase - PUSH 0 - MOV EAX, [ESP + 8] - MOV EDX, ESP - CALL LowerCase - POP EAX - POP EDX - PUSH EDX - PUSH EAX - CALL System.@LStrCmp - MOV EAX, ESP - PUSHFD - XOR EDX, EDX - MOV DL, 2 - CALL System.@LStrArrayClr - POPFD - POP EDX - POP EDX - POP EDX - POP EDX -@@exit: - SETZ AL -end; - -function AnsiEq( const S1, S2 : KOLString ) : Boolean; -asm - CALL AnsiCompareStrNoCase - TEST EAX, EAX - SETZ AL -end; - -function StrIn(const S: AnsiString; const A: array of AnsiString): Boolean; -asm -@@1: - TEST ECX, ECX - JL @@ret_0 - - PUSH EDX - MOV EDX, [EDX+ECX*4] - DEC ECX - - PUSH ECX - PUSH EAX - CALL StrEq - DEC AL - POP EAX - POP ECX - - POP EDX - JNZ @@1 - - MOV AL, 1 - RET - -@@ret_0:XOR EAX, EAX -end; - -{$IFDEF ASM_no} -procedure NormalizeUnixText( var S: AnsiString ); -asm //cmd //opd - CMP dword ptr [EAX], 0 - JZ @@exit - PUSH EBX - PUSH EDI - MOV EBX, EAX - CALL UniqueString - MOV EDI, [EBX] -@@1: MOV EAX, EDI - CALL System.@LStrLen - XCHG ECX, EAX - MOV AX, $0D0A - - CMP byte ptr [EDI], AL - JNE @@loo - MOV byte ptr [EDI], AH -@@loo: - TEST ECX, ECX - JZ @@fin -@@loo1: - REPNZ SCASB - JNZ @@fin - CMP byte ptr [EDI-2], AH - JE @@loo - MOV byte ptr [EDI-1], AH - JNE @@loo1 -@@fin: POP EDI - POP EBX -@@exit: -end; -{$ENDIF} - -function FileCreate( const FileName: KOLString; OpenFlags: DWord): THandle; -asm - XOR ECX, ECX - PUSH ECX - MOV ECX, EDX - SHR ECX, 16 - AND CX, $1FFF - JNZ @@1 - MOV CL, FILE_ATTRIBUTE_NORMAL -@@1: PUSH ECX - MOV CL, DH - PUSH ECX // CreationMode - PUSH 0 - MOV CL, DL - PUSH ECX // ShareMode - MOV DX, 0 - PUSH EDX // AccessMode - //CALL System.@LStrToPChar // FileName must not be '' - PUSH EAX - CALL CreateFile -end; - -function FileClose( Handle: THandle): Boolean; -asm - PUSH EAX - CALL CloseHandle - TEST EAX, EAX - SETNZ AL -end; - -function FileRead( Handle: THandle; var Buffer; Count: DWord): DWord; -asm - PUSH EBP - PUSH 0 - MOV EBP, ESP - PUSH 0 - PUSH EBP - PUSH ECX - PUSH EDX - PUSH EAX - CALL ReadFile - TEST EAX, EAX - POP EAX - JNZ @@exit - XOR EAX, EAX -@@exit: - POP EBP -end; - -function File2Str( Handle: THandle): AnsiString; -asm - PUSH EDX - TEST EAX, EAX - JZ @@exit // return '' - - PUSH EBX - MOV EBX, EAX // EBX = Handle - XOR EDX, EDX - XOR ECX, ECX - INC ECX - CALL FileSeek - PUSH EAX // Pos - PUSH 0 - PUSH EBX - CALL GetFileSize - POP EDX - SUB EAX, EDX // EAX = Size - Pos - JZ @@exitEBX - - PUSH EAX - CALL System.@GetMem - XCHG EAX, EBX - MOV EDX, EBX - POP ECX - PUSH ECX - CALL FileRead - POP ECX - MOV EDX, EBX - POP EBX - POP EAX - PUSH EDX - {$IFDEF _D2} - CALL _LStrFromPCharLen - {$ELSE} - {$IFDEF _D2009orHigher} - PUSH ECX // TODO: check to remove - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPCharLen - {$IFDEF _D2009orHigher} - POP ECX - {$ENDIF} - - {$ENDIF} - JMP @@freebuf - -@@exitEBX: - POP EBX -@@exit: - XCHG EDX, EAX - POP EAX // @Result - PUSH EDX - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: confirm not need push - {$ENDIF} - CALL System.@LStrFromPChar -@@freebuf: - POP EAX - TEST EAX, EAX - JZ @@fin - CALL System.@FreeMem -@@fin: -end; - -function FileWrite( Handle: THandle; const Buffer; Count: DWord): DWord; -asm - PUSH EBP - PUSH EBP - MOV EBP, ESP - PUSH 0 - PUSH EBP - PUSH ECX - PUSH EDX - PUSH EAX - CALL WriteFile - TEST EAX, EAX - POP EAX - JNZ @@exit - XOR EAX, EAX -@@exit: - POP EBP -end; - -function FileEOF( Handle: THandle ) : Boolean; -asm - PUSH EAX - - PUSH 0 - PUSH EAX - CALL GetFileSize - - XCHG EAX, [ESP] - - MOV CL, spCurrent - XOR EDX, EDX - CALL FileSeek - - POP EDX - CMP EAX, EDX - SETGE AL -end; - -procedure FileTime( const Path: KOLString; - CreateTime, LastAccessTime, LastModifyTime: PFileTime ); stdcall; -const Size_TFindFileData = (sizeof(TFindFileData) + 3) and not 3; -asm - PUSH ESI - PUSH EDI - SUB ESP, Size_TFindFileData - MOV EDX, ESP - MOV EAX, [Path] - CALL Find_First - TEST AL, AL - JZ @@exit - MOV EAX, ESP - CALL Find_Close - XOR ECX, ECX - MOV CL, 3 -@@loop: LEA ESI, [ESP+ECX*8-8].TFindFileData.ftCreationTime - MOV EDI, [ECX*4+EBP+8] - TEST EDI, EDI - JZ @@e_loop - MOVSD - MOVSD -@@e_loop: LOOP @@loop -@@exit: ADD ESP, Size_TFindFileData - POP EDI - POP ESI -end; - -function CompareSystemTime( const D1, D2 : TSystemTime) : Integer; assembler; -asm - PUSH ESI - PUSH EBX - MOV ESI, EAX - XOR EAX, EAX - XOR ECX, ECX - MOV CL, 8 // 8 words: wYear, wMonth,..., wMilliseconds -@@loo: - LODSW - MOV BX, [EDX] - INC EDX - INC EDX - - CMP CL, 6 - JE @@cont // skip compare DayOfWeek - - SUB AX, BX - JNE @@calc - -@@cont: - LOOP @@loo - JMP @@exit - -@@calc: - SBB EAX, EAX - {$IFDEF PARANOIA} DB $0C, 1 {$ELSE} OR AL, 1 {$ENDIF} - -@@exit: - POP EBX - POP ESI -end; - -function DirectoryExists( const Name: KOLString): Boolean; -asm - PUSH EBX - //CALL System.@LStrToPChar // Name must not be '' - PUSH EAX - PUSH SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS - CALL SetErrorMode - XCHG EBX, EAX - CALL GetFileAttributes - INC EAX - JZ @@exit - DEC EAX - {$IFDEF PARANOIA} DB $24, FILE_ATTRIBUTE_DIRECTORY {$ELSE} AND AL, FILE_ATTRIBUTE_DIRECTORY {$ENDIF} - SETNZ AL -@@exit: - XCHG EAX, EBX - PUSH EAX - CALL SetErrorMode - XCHG EAX, EBX - POP EBX -end; - -procedure TDirList.Clear; -asm - LEA EDX, [EAX].FListPositions - CALL @@clear - ADD EDX, 4 // fStoreFiles -- order of fields is important!!! -@@clear: - PUSHAD - XOR EAX, EAX - XCHG EAX, dword ptr [EDX] - CALL TObj.RefDec - POPAD -@@exit: -end; - -destructor TDirList.Destroy; -asm - PUSH EBX - MOV EBX, EAX - CALL Clear - LEA EAX, [EBX].FPath - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrClr - {$ELSE} - CALL System.@LStrClr - {$ENDIF} - XCHG EAX, EBX - CALL TObj.Destroy - POP EBX -end; - -function TDirList.GetCount: Integer; -asm - {CMP EAX, 0 - JNZ @@1 - NOP -@@1: } - MOV ECX, [EAX].FListPositions - JECXZ @@retECX - MOV ECX, [ECX].TList.fCount -@@retECX: - XCHG EAX, ECX -end; - -procedure SwapDirItems( Data : PSortDirData; const e1, e2 : DWORD ); -asm - MOV EAX, [EAX].TSortDirData.Dir - MOV EAX, [EAX].TDirList.FListPositions - {$IFDEF xxSPEED_FASTER} //||||||||||||||||||||||||||||||||||||||||||||| - MOV EAX, [EAX].TList.fItems - LEA EDX, [EAX+EDX*4] - LEA ECX, [EAX+ECX*4] - MOV EAX, [EDX] - XCHG EAX, [ECX] - MOV [EDX], EAX - {$ELSE} - CALL TList.Swap - {$ENDIF} -end; - -destructor TThread.Destroy; -asm - PUSH EBX - MOV EBX, EAX - CALL RefInc - MOV EAX, EBX - CMP [EBX].FTerminated, 0 - JNZ @@1 - CALL Terminate - MOV EAX, EBX - CALL WaitFor -@@1: MOV ECX, [EBX].FHandle - JECXZ @@2 - PUSH ECX - CALL CloseHandle -@@2: POP EAX - XCHG EBX, EAX - JMP TObj.Destroy -end; - -destructor TStream.Destroy; -asm - PUSH EAX - PUSH [EAX].fData.fThread - CALL [EAX].fMethods.fClose - POP EAX - CALL TObj.RefDec - POP EAX - CALL TObj.Destroy -end; - -procedure CloseMemStream( Strm: PStream ); -asm - XOR ECX, ECX - XCHG ECX, [EAX].TStream.fMemory - JECXZ @@exit - XCHG EAX, ECX - CALL System.@FreeMem -@@exit: -end; - -function NewReadFileStream( const FileName: KOLString ): PStream; -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, offset[BaseFileMethods] - CALL _NewStream - MOV EDX, [ReadFileStreamProc] - MOV [EAX].TStream.fMethods.fRead, EDX - XCHG EBX, EAX - MOV EDX, ofOpenRead or ofOpenExisting or ofShareDenyWrite - CALL FileCreate - MOV [EBX].TStream.fData.fHandle, EAX - XCHG EAX, EBX - POP EBX -end; - -function NewWriteFileStream( const FileName: KOLString ): PStream; -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, offset[BaseFileMethods] - CALL _NewStream - MOV [EAX].TStream.fMethods.fWrite, offset[WriteFileStreamEOF] - MOV [EAX].TStream.fMethods.fSetSiz, offset[SetSizeFileStream] - XCHG EBX, EAX - MOV EDX, ofOpenWrite or ofCreateAlways or ofShareDenyWrite - CALL FileCreate - MOV [EBX].TStream.fData.fHandle, EAX - XCHG EAX, EBX - POP EBX -end; - -destructor TIniFile.Destroy; -asm //cmd //opd - PUSH EAX - LEA EDX, [EAX].fFileName - PUSH EDX - LEA EAX, [EAX].fSection - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrClr - {$ELSE} - CALL System.@LStrClr - {$ENDIF} - POP EAX - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrClr - {$ELSE} - CALL System.@LStrClr - {$ENDIF} - POP EAX - CALL TObj.Destroy -end; - -function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator; -asm - MOVZX EAX, AL - PUSH EAX - MOV [ESP+1], DX - POP EAX -end; - -function NewCommandActionsObj_Packed( fromPack: PAnsiChar ): PCommandActionsObj; -asm - PUSH ESI - PUSH EDI - PUSH EAX - CALL NewCommandActionsObj - POP ESI - CMP ESI, 120 - MOV [EAX].TCommandActionsObj.fIndexInActions, ESI - JB @@exit - PUSH EAX - LEA EDI, [EAX].TCommandActionsObj.aClick - XOR EAX, EAX - LODSB - MOV dword ptr [EDI + 76], EAX // Result.fIndexInActions := fromPack[0] - XOR ECX, ECX - MOV CL, 38 -@@loop: - CMP byte ptr[ESI], 200 - JB @@copy_word - JA @@clear_words - INC ESI -@@copy_word: - MOVSW - LOOP @@loop - JMP @@fin -@@clear_words: - LODSB - SUB AL, 200 - SUB CL, AL - PUSH ECX - MOVZX ECX, AL - XOR EAX, EAX - REP STOSW - POP ECX - INC ECX - LOOP @@loop -@@fin: - POP EAX -@@exit: - POP EDI - POP ESI -end; - -function _NewTControl( AParent: PControl ): PControl; -begin - New( Result, CreateParented( AParent ) ); -end; - -function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar; - Ctl3D: Boolean; ACommandActions: TCommandActionsParam ): PControl; -const Sz_TCommandActions = Sizeof(TCommandActions); -asm - PUSH EBX - PUSH ESI - PUSH EDI - MOV EDI, ACommandActions - MOV [ACommandActions], ECX // Ctl3D -> ACommandActions - - PUSH EDX // ControlClassName - - MOV ESI, EAX // ESI = AParent - CALL _NewTControl - XCHG EBX, EAX // EBX = Result - POP [EBX].TControl.fControlClassName - //INC [EBX].TControl.fWindowed // set in TControl.Init - - {$IFDEF COMMANDACTIONS_OBJ} - MOV EAX, EDI - CMP EAX, 120 - JB @@IdxActions_Loaded - MOVZX EAX, byte ptr[EDI] -@@IdxActions_Loaded: - PUSH EAX - MOV ECX, dword ptr [AllActions_Objs + EAX*4] - JECXZ @@create_new_action - XCHG EAX, ECX - PUSH EAX - CALL TObj.RefInc - POP EAX - JMP @@action_assign - -@@create_new_action: - {$IFDEF PACK_COMMANDACTIONS} - MOV EAX, EDI - CALL NewCommandActionsObj_Packed - {$ELSE not PACK_COMMANDACTIONS} - CALL NewCommandActionsObj - - TEST EDI, EDI - JZ @@no_actions - - PUSH EAX - LEA EDX, [EAX].TCommandActionsObj.aClear - XCHG EAX, EDI - XOR ECX, ECX - MOV CL, Sz_TCommandActions - CALL Move - POP EAX - JMP @@action_assign - @@no_actions: - {$ENDIF not PACK_COMMANDACTIONS} - MOV [EAX].TCommandActionsObj.aClear, offset[ClearText] - -@@action_assign: - POP EDX - MOV dword ptr [AllActions_Objs + EDX*4], EAX - - MOV [EBX].TControl.fCommandActions, EAX - XCHG EDX, EAX - MOV EAX, EBX - CALL TControl.Add2AutoFree - - {$ELSE} - TEST EDI, EDI - JZ @@no_actions2 - PUSH ESI - MOV ESI, EDI - LEA EDI, [EBX].TControl.fCommandActions - XOR ECX, ECX - MOV CL, Sz_TCommandActions - REP MOVSB - POP ESI - JMP @@actions_created -@@no_actions2: - MOV [EBX].TControl.fCommandActions.TCommandActions.aClear, offset[ClearText] - {$ENDIF} -@@actions_created: - - TEST ESI, ESI - JZ @@no_parent - - MOV EAX, [ESI].TControl.PP.fGotoControl - MOV [EBX].TControl.PP.fGotoControl, EAX - - LEA ESI, [ESI].TControl.fTextColor - LEA EDI, [EBX].TControl.fTextColor - MOVSD // fTextColor - MOVSD // fColor - - {$IFDEF SMALLEST_CODE} - {$IFDEF SMALLEST_CODE_PARENTFONT} - LODSD - XCHG EDX, EAX - XOR EAX, EAX - CALL TGraphicTool.Assign - STOSD // fFont - {$ELSE} - LODSD - XOR EAX, EAX - STOSD // fFont = nil - {$ENDIF} - {$ELSE} - LODSD - XCHG EDX, EAX - XOR EAX, EAX - PUSH EDX - CALL TGraphicTool.Assign - STOSD // fFont - POP EDX - XCHG ECX, EAX - JECXZ @@no_font - MOV [ECX].TGraphicTool.fParentGDITool, EDX - MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Code, offset[TControl.FontChanged] - MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Data, EBX - MOV EAX, EBX - MOV EDX, ECX - CALL TControl.FontChanged - {$IFDEF USE_AUTOFREE4CONTROLS} - MOV EAX, EBX - MOV EDX, [EBX].TControl.fFont - CALL TControl.Add2AutoFree - {$ENDIF} -@@no_font: - {$ENDIF} - - {$IFDEF SMALLEST_CODE} - LODSD - XOR EAX, EAX - STOSD - {$ELSE} - LODSD - XCHG EDX, EAX - XOR EAX, EAX - PUSH EDX - CALL TGraphicTool.Assign - STOSD // fBrush - POP EDX - XCHG ECX, EAX - JECXZ @@no_brush - MOV [ECX].TGraphicTool.fParentGDITool, EDX - MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Code, offset[TControl.BrushChanged] - MOV [ECX].TGraphicTool.fOnGTChange.TMethod.Data, EBX - MOV EAX, EBX - MOV EDX, ECX - CALL TControl.BrushChanged - {$IFDEF USE_AUTOFREE4CONTROLS} - MOV EAX, EBX - MOV EDX, [EBX].TControl.fBrush - CALL TControl.Add2AutoFree - {$ENDIF} -@@no_brush: - {$ENDIF} - - MOVSB // fMargin - LODSD // skip fClientXXXXX - ADD EDI, 4 - - LODSB // fCtl3D_child - TEST AL, 2 - JZ @@passed3D - MOV EDX, [ACommandActions] // DL <- Ctl3D !!! - AND AL, not 1 - AND DL, 1 - OR EAX, EDX -@@passed3D: - STOSB // fCtl3D_child - -@@no_parent: - XCHG EAX, EBX - POP EDI - POP ESI - POP EBX - {$IFDEF DUMP_WINDOWED} - CALL DumpWindowed - {$ENDIF} -end; - -function NewForm( AParent: PControl; const Caption: KOLString ): PControl; -const FormClass: array[ 0..4 ] of KOLChar = ( 'F', 'o', 'r', 'm', #0 ); -asm - PUSH EBX - PUSH EDX - MOV EDX, offset[FormClass] - MOV CL, 1 - {$IFDEF COMMANDACTIONS_OBJ} - PUSH OTHER_ACTIONS - {$ELSE} - PUSH 0 - {$ENDIF} - CALL _NewWindowed - MOV EBX, EAX - OR byte ptr [EBX].TControl.fClsStyle, CS_DBLCLKS - MOV EDX, offset[WndProcForm] - CALL TControl.AttachProc - MOV EDX, offset[WndProcDoEraseBkgnd] - MOV EAX, EBX - CALL TControl.AttachProc - POP EDX - MOV EAX, EBX - CALL TControl.SetCaption - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG3, (1 shl G3_IsForm) or (1 shl G3_SizeGrip) - {$ELSE} - INC [EBX].TControl.fSizeGrip - DEC WORD PTR [EBX].TControl.fIsForm // why word? - {$ENDIF} - XCHG EAX, EBX - POP EBX -end; - -function NewButton( AParent: PControl; const Caption: KOLString ): PControl; -const szActions = sizeof(TCommandActions); -asm - PUSH EBX - PUSH EDX - - PUSH 0 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [ButtonActions_Packed] - {$ELSE} - PUSH offset[ButtonActions] - {$ENDIF} - MOV EDX, offset[ButtonClass] - MOV ECX, WS_VISIBLE or WS_CHILD or BS_PUSHLIKE or WS_TABSTOP or BS_NOTIFY - CALL _NewControl - XCHG EBX, EAX - //MOV Byte Ptr[EBX].TControl.aAutoSzX, 14 - //MOV Byte Ptr[EBX].TControl.aAutoSzY, 6 - MOV word ptr [EBX].TControl.aAutoSzX, 6 shl 8 + 14 - MOV EDX, [EBX].TControl.fBoundsRect.Top - ADD EDX, 22 - MOV [EBX].TControl.fBoundsRect.Bottom, EDX - MOV [EBX].TControl.fTextAlign, taCenter - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG5, (1 shl G5_IsButton) or (1 shl G5_IgnoreDefault) - {$ELSE} - INC [EBX].TControl.fIsButton - INC [EBX].TControl.fIgnoreDefault - {$ENDIF} - POP EDX - MOV EAX, EBX - CALL TControl.SetCaption - {$IFNDEF SMALLEST_CODE} - {$IFNDEF BUTTON_DBLCLICK} - MOV EAX, EBX - MOV EDX, offset[WndProcBtnDblClkAsClk] - CALL TControl.AttachProc - {$ENDIF} - {$ENDIF SMALLEST_CODE} - {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} - MOV EAX, EBX - MOV EDX, offset[WndProcBtnReturnClick] - CALL TControl.AttachProc - {$ENDIF} - XCHG EAX, EBX - POP EBX - -{$IFDEF GRAPHCTL_XPSTYLES} - PUSH EAX - MOV EDX, offset[XP_Themes_For_BitBtn] - CALL Attach_WM_THEMECHANGED - POP EAX -{$ENDIF} -end; - -function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; -asm //cmd //opd - CMP word ptr [EDX].TMsg.message, WM_DRAWITEM - JNZ @@ret_false - MOV EAX, [EDX].TMsg.lParam - MOV ECX, [EAX].TDrawItemStruct.hwndItem - JECXZ @@ret_false - PUSH EDX - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] - PUSH ECX - CALL GetProp - {$ELSE} - PUSH GWL_USERDATA - PUSH ECX - CALL GetWindowLong - {$ENDIF} - POP EDX - TEST EAX, EAX - JZ @@ret_false - PUSH [EDX].TMsg.lParam - PUSH [EDX].TMsg.wParam - PUSH CN_DRAWITEM - PUSH EAX - CALL TControl.Perform - MOV AL, 1 - RET -@@ret_false: - XOR EAX, EAX -end; - -{$IFDEF BITBTN_ASM} -function NewBitBtn( AParent: PControl; const Caption: KOLString; - Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl; -const szBitmapInfo = sizeof(TBitmapInfo); -asm - PUSH EBX - PUSH EDX - PUSH ECX - - PUSH 0 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [ButtonActions_Packed] - {$ELSE} - PUSH offset[ButtonActions] - {$ENDIF} - MOV EDX, offset[ButtonClass] - MOV ECX, WS_VISIBLE or WS_CHILD or WS_TABSTOP or BS_OWNERDRAW or BS_NOTIFY - CALL _NewControl - XCHG EBX, EAX - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG5, (1 shl G5_IgnoreDefault)or(1 shl G5_IsButton)or(1 shl G5_IsBitBtn) - {$ELSE} - INC [EBX].TControl.fIgnoreDefault - INC [EBX].TControl.fIsButton - INC [EBX].TControl.fIsBitBtn - {$ENDIF} - //MOV byte ptr [EBX].TControl.fCommandActions.aAutoSzX, 8 - //MOV byte ptr [EBX].TControl.fCommandActions.aAutoSzY, 8 - MOV word ptr [EBX].TControl.fCommandActions.aAutoSzY, $808 - POP EAX - MOV [EBX].TControl.fBitBtnOptions, AL - MOVZX EDX, Layout - MOV [EBX].TControl.fGlyphLayout, DL - MOV ECX, GlyphBitmap - MOV [EBX].TControl.fGlyphBitmap, ECX - MOV EDX, [EBX].TControl.fBoundsRect.Top - ADD EDX, 22 - MOV [EBX].TControl.fBoundsRect.Bottom, EDX - TEST ECX, ECX - JZ @@noGlyphWH - {$IFDEF PARANOIA} DB $A8, 01 {$ELSE} TEST AL, bboImageList {$ENDIF} - JZ @@getBmpWH - PUSH EAX - MOV EAX, ESP - PUSH EAX - MOV EDX, ESP - PUSH EAX - PUSH EDX - PUSH ECX - CALL ImageList_GetIconSize - POP EAX - POP EDX - MOV ECX, GlyphCount - JMP @@WHready -@@getBmpWH: - ADD ESP, -szBitmapInfo - PUSH ESP - PUSH szBitmapInfo - PUSH ECX - CALL GetObject - XCHG ECX, EAX - POP EAX - POP EAX - POP EDX - ADD ESP, szBitmapInfo-12 - TEST ECX, ECX - JZ @@noGlyphWH - MOV ECX, GlyphCount - INC ECX - LOOP @@GlyphCountOK - PUSH EAX - PUSH EDX - XCHG EDX, ECX - DIV ECX - XCHG ECX, EAX - POP EDX - POP EAX -@@GlyphCountOK: - CMP ECX, 1 - JLE @@WHReady - PUSH EDX - CDQ - IDIV ECX - POP EDX -@@WHReady: - MOV [EBX].TControl.fGlyphWidth, EAX - MOV [EBX].TControl.fGlyphHeight, EDX - MOV [EBX].TControl.fGlyphCount, ECX - POP ECX // ECX = @ Caption[ 1 ] - PUSH ECX - PUSH EDX - PUSH EAX - TEST EAX, EAX - JLE @@noWidthResize - JECXZ @@addWLeft - CMP [Layout], glyphOver - JE @@addWLeft - MOVZX ECX, byte ptr[ECX] - JECXZ @@addWLeft - // else - CMP [Layout], glyphLeft - JZ @@addWRight - CMP [Layout], glyphRight - JNZ @@noWidthResize -@@addWRight: - ADD [EBX].TControl.fBoundsRect.Right, EAX - ADD byte ptr [EBX].TControl.aAutoSzX, AL - JMP @@noWidthResize -@@addWLeft: - // then - ADD EAX, [EBX].TControl.fBoundsRect.Left - MOV [EBX].TControl.fBoundsRect.Right, EAX - MOV byte ptr [EBX].TControl.aAutoSzX, 0 -@@noWidthResize: - TEST EDX, EDX - JLE @@noHeightResize - CMP [Layout], glyphTop - JE @@addHBottom - CMP [Layout], glyphBottom - JNE @@addHTop -@@addHBottom: - ADD [EBX].TControl.fBoundsRect.Bottom, EDX - ADD byte ptr [EBX].TControl.aAutoSzY, DL - JMP @@noHeightResize -@@addHTop: - ADD EDX, [EBX].TControl.fBoundsRect.Top - MOV [EBX].TControl.fBoundsRect.Bottom, EDX - MOV byte ptr [EBX].TControl.aAutoSzY, 0 -@@noHeightResize: - POP ECX - POP EAX - CDQ - MOV DL, 4 - TEST [EBX].TControl.fBitBtnOptions, 2 //1 shl bboNoBorder - JNZ @@noBorderResize - JECXZ @@noBorderWinc - ADD [EBX].TControl.fBoundsRect.Right, EDX - CMP [EBX].TControl.aAutoSzX, 0 - JZ @@noBorderWinc - ADD [EBX].TControl.aAutoSzX, DL -@@noBorderWinc: - TEST EAX, EAX - JLE @@noBorderResize - ADD [EBX].TControl.fBoundsRect.Bottom, EDX - CMP [EBX].TControl.aAutoSzY, 0 - JZ @@noBorderResize - ADD [EBX].TControl.aAutoSzY, DL -@@noBorderResize: -@@noGlyphWH: - MOV ECX, [EBX].TControl.fParent - JECXZ @@notAttach2Parent - XCHG EAX, ECX - MOV EDX, offset[WndProc_DrawItem] - CALL TControl.AttachProc -@@notAttach2Parent: - MOV EAX, EBX - MOV EDX, offset[WndProcBitBtn] - CALL TControl.AttachProc - MOV EAX, EBX - POP EDX - CALL TControl.SetCaption - MOV [EBX].TControl.fTextAlign, taCenter - {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} - MOV EAX, EBX - MOV EDX, offset[WndProcBtnReturnClick] - CALL TControl.AttachProc - {$ENDIF} - XCHG EAX, EBX - POP EBX - -{$IFDEF GRAPHCTL_XPSTYLES} - PUSH EAX - MOV EDX, offset[XP_Themes_For_BitBtn] - CALL Attach_WM_THEMECHANGED - POP EAX - {$ENDIF} -end; -{$ENDIF BITBTN_ASM} - -function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl; -asm - CALL NewButton - MOV EDX, [EAX].TControl.fBoundsRect.Left - ADD EDX, 72 - MOV [EAX].TControl.fBoundsRect.Right, EDX - MOV [EAX].TControl.fStyle, WS_VISIBLE or WS_CHILD or BS_AUTOCHECKBOX or WS_TABSTOP or BS_NOTIFY - MOV [EAX].TControl.aAutoSzX, 24 - -{$IFDEF GRAPHCTL_XPSTYLES} - PUSH EAX - MOV EDX, offset[XP_Themes_For_CheckBox] - CALL Attach_WM_THEMECHANGED - POP EAX -{$ENDIF} -end; - -procedure ClickRadio( Sender:PObj ); -asm - PUSH EBX - MOV EBX, [EAX].TControl.fParent - TEST EBX, EBX - JZ @@exit - {$IFDEF USE_FLAGS} - PUSH ESI - PUSH EDI - XCHG ESI, EAX - OR EDI, -1 -@@cont_loop: - INC EDI - MOV EAX, [EBX].TControl.fChildren - CMP EDI, [EAX].TList.fCount - JGE @@e_loop - MOV EDX, EDI - CALL TList.Get - TEST [EAX].TControl.fFlagsG5, 1 shl G5_IsButton - JZ @@cont_loop - TEST [EAX].TControl.fStyle.f0_Style, BS_RADIOBUTTON - JZ @@cont_loop - CMP EAX, ESI - PUSH EAX - SETZ DL - PUSH EDX - CALL TControl.GetChecked - POP EDX - CMP DL, AL - POP EAX - JZ @@cont_loop - CALL TControl.SetChecked - JMP @@cont_loop -@@e_loop: - POP EDI - POP ESI - {$ELSE not USE_FLAGS} - PUSH [EAX].TControl.fMenu - MOV EAX, EBX - MOV EDX, offset[RADIO_LAST] - CALL TControl.Get_Prop_Int - PUSH EAX - MOV EAX, EBX - MOV EDX, offset[RADIO_1ST] - CALL TControl.Get_Prop_Int - PUSH EAX - PUSH [EBX].TControl.fHandle - CALL CheckRadioButton - {$ENDIF USE_FLAGS} -@@exit: - POP EBX -end; - -function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl; -const - RadioboxStyles = WS_VISIBLE or WS_CHILD or BS_RADIOBUTTON or - WS_TABSTOP or WS_GROUP or BS_NOTIFY; -asm - PUSH EBX - PUSH ESI - MOV ESI, EAX - CALL NewCheckbox - XCHG EBX, EAX - MOV [EBX].TControl.fStyle, RadioboxStyles - MOV [EBX].TControl.PP.fControlClick, offset[ClickRadio] - TEST ESI, ESI - JZ @@exit - {$IFDEF USE_FLAGS} - BTS DWORD PTR [ESI].TControl.fFlagsG1, 1 shl G1_HasRadio - JNZ @@exit - MOV EAX, EBX - CALL TControl.SetRadioChecked - {$ELSE} - MOV ECX, [EBX].TControl.fMenu - PUSH ECX - MOV EDX, offset[RADIO_LAST] - MOV EAX, ESI - CALL TControl.Set_Prop_Int - MOV EDX, offset[RADIO_1ST] - PUSH EDX - MOV EAX, ESI - CALL TControl.Get_Prop_Int - TEST EAX, EAX - POP EDX - POP ECX - JNZ @@exit - MOV EAX, ESI - CALL TControl.Set_Prop_Int - MOV EAX, EBX - CALL TControl.SetRadioChecked - {$ENDIF} -@@exit: XCHG EAX, EBX - POP ESI - POP EBX - -{$IFDEF GRAPHCTL_XPSTYLES} - PUSH EAX - MOV EDX, offset[XP_Themes_For_RadioBox] - CALL Attach_WM_THEMECHANGED - POP EAX -{$ENDIF} -end; - -function NewWordWrapLabel( AParent: PControl; const Caption: KOLString ): PControl; -asm - CALL NewLabel - MOV EDX, [EAX].TControl.fBoundsRect.Top - ADD EDX, 44 - MOV [EAX].TControl.fBoundsRect.Bottom, EDX - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG1, (1 shl G1_WordWrap) - {$ELSE} - INC [EAX].TControl.fWordWrap - {$ENDIF} - AND byte ptr [EAX].TControl.fStyle, not SS_LEFTNOWORDWRAP -end; - -function NewLabelEffect( AParent: PControl; const Caption: KOLString; ShadowDeep: Integer ): PControl; -asm - PUSH EBX - - PUSH ECX - PUSH EDX - XOR EDX, EDX - CALL NewLabel - MOV EBX, EAX - {$IFDEF USE_FLAGS} - AND [EBX].TControl.fFlagsG1, not(1 shl G1_IsStaticControl) - {$ELSE} - DEC [EBX].TControl.fIsStaticControl // снова 0 ! - {$ENDIF USE_FLAGS} - MOV EDX, offset[WndProcLabelEffect] - CALL TControl.AttachProc - - POP EDX - MOV EAX, EBX - CALL TControl.SetCaption - - MOV EDX, offset[WndProcDoEraseBkgnd] - MOV EAX,EBX - CALL TControl.AttachProc - MOV [EBX].TControl.fTextAlign, taCenter - MOV [EBX].TControl.fTextColor, clWindowText - POP [EBX].TControl.DF.fShadowDeep - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG1, (1 shl G1_IgnoreWndCaption) - {$ELSE} - INC [EBX].TControl.fIgnoreWndCaption - {$ENDIF USE_FLAGS} - ADD [EBX].TControl.fBoundsRect.Bottom, 40 - 22 - MOV [EBX].TControl.DF.fColor2, clNone - - XCHG EAX, EBX - POP EBX -end; - -function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm // // - CMP word ptr [EDX].TMsg.message, WM_ERASEBKGND - JNE @@ret_false - MOV byte ptr [ECX], 1 - PUSH EBX - PUSH EDI - MOV EBX, EAX - MOV EDI, [EDX].TMsg.wParam - - {$IFDEF SMALLEST_CODE} - {$ELSE} - CALL TControl.CreateChildWindows - {$IFDEF USE_FLAGS} - TEST [EBX].TControl.fFlagsG2, (1 shl G2_Transparent) - {$ELSE} - CMP [EBX].TControl.fTransparent, 0 - {$ENDIF USE_FLAGS} - JNE @@exit - {$ENDIF} - - {$IFDEF SMALLEST_CODE} - {$ELSE} - PUSH OPAQUE - PUSH EDI - CALL SetBkMode - MOV EAX, [EBX].TControl.fColor - CALL Color2RGB - PUSH EAX - PUSH EDI - CALL SetBkColor - XOR EAX, EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EDI - CALL SetBrushOrgEx - {$ENDIF} - SUB ESP, 16 - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL GetClientRect - MOV EAX, EBX - CALL dword ptr[Global_GetCtlBrushHandle] - MOV EDX, ESP - PUSH EAX - PUSH EDX - PUSH EDI - CALL Windows.FillRect - ADD ESP, 16 -@@exit: POP EDI - POP EBX -@@ret_false: - XOR EAX, EAX -end; - -function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - CMP word ptr [EDX].TMsg.message, WM_NCHITTEST - JNE @@noWM_NCHITTEST - PUSH ECX - PUSH [EDX].TMsg.lParam - PUSH [EDX].TMsg.wParam - PUSH [EDX].TMsg.message - PUSH [EAX].TControl.fHandle - CALL DefWindowProc - TEST EAX, EAX - JLE @@htReady - XOR EAX, EAX - INC EAX -@@htReady: - POP ECX - MOV [ECX], EAX - MOV AL, 1 - RET - -@@noWM_NCHITTEST: - PUSH EBX - XCHG EBX, EAX - CMP word ptr [EDX].TMsg.message, WM_MOUSEMOVE - JNE @@noWM_MOUSEMOVE - - PUSH [EBX].TControl.fCursor - CALL Windows.SetCursor - - XOR EDX, EDX - - {$IFDEF USE_ASM_DODRAG} - CALL @@DoDrag - {$ELSE} - MOV EAX, EBX - CALL DoDrag - {$ENDIF} - - POP EBX - RET - -{$IFDEF USE_ASM_DODRAG} -@@DoDrag: - PUSHAD - MOVZX EDI, DL // EDI = 1 if Cancel, 0 otherwise - CMP [EBX].TControl.fDragging, 0 - JZ @@e_DoDrag - MOV EAX, [EBX].TControl.fParent - MOV EAX, [EAX].TControl.fChildren - PUSH EAX - MOV EDX, EBX - CALL TList.IndexOf - POP EDX // EDX = Self_.fParent.fChildren:PList - MOV EBP, EBX // Prev := Self_; - TEST EAX, EAX - JLE @@noPrev - MOV EDX, [EDX].TList.fItems - MOV EBP, [EDX+EAX*4-4] // Prev = Self_.fParent.fChildren.fItems[I-1] - PUSH EBP // push Prev -@@noPrev: - PUSH EDX - PUSH EDX - PUSH ESP - CALL GetCursorPos - DEC EDI - JNZ @@noCancel - POP EDX - POP EDX - PUSH [EBX].TControl.fSplitStartPos.y - PUSH [EBX].TControl.fSplitStartPos.x -@@noCancel: - OR EDI, -1 - MOV CL, [EBX].TControl.fAlign - MOV AL, 1 - SHL EAX, CL - {$IFDEF PARANOIA} DB $A8, chkRight or chkBott {$ELSE} TEST AL, chkRight or chkBott {$ENDIF} //fAlign in [ caRight, caBottom ] ? - JNZ @@mReady - INC EDI - INC EDI -@@mReady: - MOV EDX, [EBX].TControl.fParent - MOVSX EBP, [EDX].TControl.fMargin - NEG EBP - {$IFDEF PARANOIA} DB $A8, chkTop or chkBott {$ELSE} TEST AL, chkTop or chkBott {$ENDIF} // fAlign in [ caTop, caBottom ] ? - XCHG EAX, EDX - JZ @@noTopBottom - - CALL TControl.GetClientHeight - XCHG EDX, EAX - - POP EAX - POP ESI // MousePos.y - MOV EAX, ESI - PUSH EDX // Self_.fParent.ClientHeight - SUB EAX, [EBX].TControl.fSplitStartPos.y - IMUL EAX, EDI - ADD EAX, [EBX].TControl.fSplitStartSize // EAX = NewSize1 - - POP EDX - SUB EDX, EAX - SUB EDX, [EBX].TControl.fBoundsRect.Bottom - ADD EDX, [EBX].TControl.fBoundsRect.Top - LEA EDX, [EDX+EBP*4] - - MOV ECX, [EBX].TControl.fSecondControl - JECXZ @@noSecondControl - MOV EDX, [ECX].TControl.fBoundsRect.Bottom - SUB EDX, [ECX].TControl.fBoundsRect.Top - CMP [ECX].TControl.fAlign, caClient - JNZ @@noSecondControl - - PUSH EAX - MOV EAX, [EBX].TControl.fSplitStartPos.y - SUB EAX, ESI - IMUL EAX, EDI - ADD EAX, [EBX].TControl.fSplitStartPos2.y - LEA EDX, [EAX+EBP*4] - POP EAX - -@@noSecondControl: - JMP @@newSizesReady - -@@noTopBottom: - CALL TControl.GetClientWidth - XCHG EDX, EAX - - POP ESI // MousePos.x - POP ECX - MOV EAX, ESI - PUSH EDX // Self_.fParent.ClientWidth - SUB EAX, [EBX].TControl.fSplitStartPos.x - IMUL EAX, EDI - ADD EAX, [EBX].TControl.fSplitStartSize // EAX = NewSize1 - - POP EDX - SUB EDX, EAX - SUB EDX, [EBX].TControl.fBoundsRect.Right - ADD EDX, [EBX].TControl.fBoundsRect.Left - LEA EDX, [EDX+EBP*4] - - MOV ECX, [EBX].TControl.fSecondControl - JECXZ @@newSizesReady - MOV EDX, [ECX].TControl.fBoundsRect.Right - SUB EDX, [ECX].TControl.fBoundsRect.Left - CMP [ECX].TControl.fAlign, caClient - JNZ @@noSecondControl - - PUSH EAX - MOV EAX, [EBX].TControl.fSplitStartPos.x - SUB EAX, ESI - IMUL EAX, EDI - ADD EAX, [EBX].TControl.fSplitStartPos2.x - LEA EDX, [EAX+EBP*4] - POP EAX - -@@newSizesReady: - MOV ECX, [EBX].TControl.fSplitMinSize1 - SUB ECX, EAX - JLE @@noCheckMinSize1 - SUB EDX, ECX - ADD EAX, ECX - -@@noCheckMinSize1: - MOV ECX, [EBX].TControl.fSplitMinSize2 - SUB ECX, EDX - JLE @@noCheckMinSize2 - SUB EAX, ECX - ADD EDX, ECX - -@@noCheckMinSize2: - MOV ECX, [EBX].TControl.fOnSplit.TMethod.Code - JECXZ @@noOnSplit - PUSHAD - PUSH EDX - MOV ESI, ECX - XCHG ECX, EAX - MOV EDX, EBX - MOV EAX, [EBX].TControl.fOnSplit.TMethod.Data - CALL ESI - TEST AL, AL - POPAD - JZ @@e_DoDrag - -@@noOnSplit: - XCHG ESI, EAX // NewSize1 -> ESI - POP EBP - ADD ESP, -16 - MOV EAX, EBP - MOV EDX, ESP - CALL TControl.GetBoundsRect - MOVZX ECX, [EBX].TControl.fAlign - LOOP @@noPrev_caLeft - ADD ESI, [ESP].TRect.Left - MOV [ESP].TRect.Right, ESI -@@noPrev_caLeft: - LOOP @@noPrev_caTop - ADD ESI, [ESP].TRect.Top - MOV [ESP].TRect.Bottom, ESI -@@noPrev_caTop: - LOOP @@noPrev_caRight - MOV EAX, [ESP].TRect.Right - SUB EAX, ESI - MOV [ESP].TRect.Left, EAX -@@noPrev_caRight: - LOOP @@noPrev_caBottom - MOV EAX, [ESP].TRect.Bottom - SUB EAX, ESI - MOV [ESP].TRect.Top, EAX -@@noPrev_caBottom: - MOV EAX, EBP - MOV EDX, ESP - CALL TControl.SetBoundsRect - ADD ESP, 16 - {$IFDEF OLD_ALIGN} - MOV EAX, [EBX].TControl.fParent - {$ELSE NEW_ALIGN} - MOV EAX, EBX - {$ENDIF} - CALL dword ptr[Global_Align] - -@@e_DoDrag: - POPAD - RET -{$ENDIF USE_ASM_DODRAG} - -@@noWM_MOUSEMOVE: - CMP word ptr [EDX].TMsg.message, WM_LBUTTONDOWN - JNE @@noWM_LBUTTONDOWN - MOV ECX, [EBX].TControl.fParent - TEST ECX, ECX - JZ @@noWM_LBUTTONDOWN - - MOV EAX, [ECX].TControl.fChildren - PUSH EAX - MOV EDX, EBX - CALL TList.IndexOf - POP ECX - MOV EDX, EBX - TEST EAX, EAX - JLE @@noParent1 - MOV ECX, [ECX].TList.fItems - MOV EDX, [ECX+EAX*4-4] -@@noParent1: - - MOV CL, [EBX].TControl.fAlign - MOV AL, 1 - SHL EAX, CL - {$IFDEF PARANOIA} DB $A8, chkTop or chkBott {$ELSE} TEST AL, chkTop or chkBott {$ENDIF} // fAlign in [caTop,caBottom] ? - XCHG EAX, EDX - JZ @@no_caTop_caBottom - CALL TControl.GetHeight - JMP @@caTop_caBottom -@@no_caTop_caBottom: - CALL TControl.GetWidth -@@caTop_caBottom: - MOV [EBX].TControl.DF.fSplitStartSize, EAX - MOV ECX, [EBX].TControl.DF.fSecondControl - JECXZ @@noSecondControl1 - XCHG EAX, ECX - PUSH EAX - CALL TControl.GetWidth - MOV [EBX].TControl.DF.fSplitStartPos2.x, EAX - POP EAX - CALL TControl.GetHeight - MOV [EBX].TControl.DF.fSplitStartPos2.y, EAX -@@noSecondControl1: - PUSH [EBX].TControl.fHandle - CALL SetCapture - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG6, 1 shl G6_Dragging - {$ELSE} - OR [EBX].TControl.fDragging, 1 - {$ENDIF} - PUSH 0 - PUSH 100 - PUSH $7B - PUSH [EBX].TControl.fHandle - CALL SetTimer - LEA EAX, [EBX].TControl.DF.fSplitStartPos - PUSH EAX - CALL GetCursorPos - JMP @@exit - -@@noWM_LBUTTONDOWN: - CMP word ptr [EDX].TMsg.message, WM_LBUTTONUP - JNE @@noWM_LBUTTONUP - XOR EDX, EDX - - {$IFDEF USE_ASM_DODRAG} - CALL @@DoDrag - {$ELSE} - MOV EAX, EBX - CALL DoDrag - {$ENDIF} - - JMP @@killtimer - -@@noWM_LBUTTONUP: - CMP word ptr[EDX].TMsg.message, WM_TIMER - JNE @@exit - {$IFDEF USE_FLAGS} - TEST [EBX].TControl.fFlagsG6, 1 shl G6_Dragging - {$ELSE} - CMP [EBX].TControl.fDragging, 0 - {$ENDIF} - JE @@exit - PUSH VK_ESCAPE - CALL GetAsyncKeyState - TEST EAX, EAX - JGE @@exit - - MOV DL, 1 - {$IFDEF USE_ASM_DODRAG} - CALL @@DoDrag - {$ELSE} - MOV EAX, EBX - CALL DoDrag - {$ENDIF} - -@@killtimer: - {$IFDEF USE_FLAGS} - AND [EBX].TControl.fFlagsG6, $7F //not(1 shl G6_Dragging) - {$ELSE} - MOV [EBX].TControl.fDragging, 0 - {$ENDIF} - PUSH $7B - PUSH [EBX].TControl.fHandle - CALL KillTimer - CALL ReleaseCapture - -@@exit: - POP EBX - XOR EAX, EAX -end; - -function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer; - EdgeStyle: TEdgeStyle ): PControl; -const int_IDC_SIZEWE = integer( IDC_SIZEWE ); -asm - PUSH EBX - PUSH EAX // AParent - PUSH ECX // MinSizePrev - PUSH EDX // MinSizeNext - MOV DL, EdgeStyle - CALL NewPanel - XCHG EBX, EAX - POP [EBX].TControl.DF.fSplitMinSize1 - POP [EBX].TControl.DF.fSplitMinSize2 - {$IFDEF USE_FLAGS} - MOV [EBX].TControl.fFlagsG5, 1 shl G5_IsSplitter - {$ELSE} - INC [EBX].TControl.fIsSplitter - {$ENDIF} - XOR EDX, EDX - MOV DL, 4 - MOV EAX, [EBX].TControl.fBoundsRect.Left - ADD EAX, EDX - MOV [EBX].TControl.fBoundsRect.Right, EAX - ADD EDX, [EBX].TControl.fBoundsRect.Top - MOV [EBX].TControl.fBoundsRect.Bottom, EDX - - POP ECX // ECX = AParent - JECXZ @@noParent2 - MOV EAX, [ECX].TControl.fChildren - MOV ECX, [EAX].TList.fCount - CMP ECX, 1 - JLE @@noParent2 - - MOV EAX, [EAX].TList.fItems - MOV EAX, [EAX+ECX*4-8] - MOV CL, [EAX].TControl.fAlign - PUSH ECX - MOV AL, 1 - SHL EAX, CL - {$IFDEF PARANOIA} DB $A8, chkTop or chkBott {$ELSE} TEST AL, chkTop or chkBott {$ENDIF} - MOV EAX, int_IDC_SIZEWE - JZ @@TopBottom - INC EAX -@@TopBottom: - PUSH EAX - PUSH 0 - CALL LoadCursor - MOV [EBX].TControl.fCursor, EAX - POP EDX - MOV EAX, EBX - CALL TControl.SetAlign - -@@noParent2: - MOV EAX, EBX - MOV EDX, offset[WndProcSplitter] - CALL TControl.AttachProc - XCHG EAX, EBX - POP EBX - -{$IFDEF GRAPHCTL_XPSTYLES} - PUSH EAX - MOV EDX, offset[XP_Themes_For_Splitter] - CALL Attach_WM_THEMECHANGED - POP EAX -{$ENDIF} -end; - -function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl; -asm - PUSH ECX - PUSH EDX - XOR EDX, EDX - CALL NewLabel - PUSH EAX - MOV EDX, offset[WndProcGradient] - CALL TControl.AttachProc - POP EAX - POP [EAX].TControl.DF.fColor1 - POP [EAX].TControl.DF.fColor2 - ADD [EAX].TControl.fBoundsRect.Right, 40-64 - ADD [EAX].TControl.fBoundsRect.Bottom, 40 - 22 -end; - -function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor; - Style: TGradientStyle; Layout: TGradientLayout ): PControl; -asm - PUSH ECX - PUSH EDX - XOR EDX, EDX - CALL NewLabel - PUSH EAX - MOV EDX, offset[WndProcGradientEx] - CALL TControl.AttachProc - POP EAX - POP [EAX].TControl.DF.fColor1 - POP [EAX].TControl.DF.fColor2 - ADD [EAX].TControl.fBoundsRect.Right, 40-100 - ADD [EAX].TControl.fBoundsRect.Bottom, 40 - 22 - MOV DL, Style - MOV [EAX].TControl.DF.fGradientStyle, DL - MOV DL, Layout - MOV [EAX].TControl.DF.fGradientLayout, DL -end; - -const EditClass: array[0..4] of KOLChar = ( 'E','D','I','T',#0 ); -function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl; -const int_IDC_IBEAM = integer( IDC_IBEAM ); -const WS_flags = integer( WS_VISIBLE or WS_CHILD or WS_TABSTOP or WS_BORDER ); -const WS_clear = integer( not(WS_VSCROLL or WS_HSCROLL) ); -asm - PUSH EBX - XCHG EBX, EAX // EBX=AParent - PUSH EDX - MOV EAX, ESP - XOR ECX, ECX - MOV CL, 11 - MOV EDX, offset [EditFlags] - CALL MakeFlags - XCHG ECX, EAX // ECX = Flags - POP EAX // Options - PUSH EAX - {$IFDEF PARANOIA} DB $A8, 8 {$ELSE} TEST AL, 8 {$ENDIF} - JNZ @@1 - AND ECX, WS_clear -@@1: OR ECX, WS_flags - PUSH 1 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [EditActions_Packed] - {$ELSE} - PUSH offset[EditActions] - {$ENDIF} - MOV EDX, offset[EditClass] - XCHG EAX, EBX - CALL _NewControl - XCHG EBX, EAX - MOV Byte Ptr [EBX].TControl.aAutoSzY, 6 - LEA ECX, [EBX].TControl.fBoundsRect - MOV EDX, [ECX].TRect.Left - ADD EDX, 100 - MOV [ECX].TRect.Right, EDX - MOV EDX, [ECX].TRect.Top - ADD EDX, 22 - MOV [ECX].TRect.Bottom, EDX - POP EAX // Options - {$IFDEF PARANOIA} DB $A8, 8 {$ELSE} TEST AL, 8 {$ENDIF} - MOV DL, $0D - JZ @@2 - ADD [ECX].TRect.Right, 100 - ADD [ECX].TRect.Bottom, 200 - 22 - MOV DL, 1 - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG5, 1 shl G5_IgnoreDefault - {$ELSE} - INC [EBX].TControl.fIgnoreDefault - {$ENDIF} -@@2: - TEST AH, 4 - JZ @@3 - AND DL, $FE -@@3: MOV [EBX].TControl.fLookTabKeys, DL -{$IFDEF UNICODE_CTRLS} - MOV EAX, EBX - MOV EDX, offset[WndProcUnicodeChars] - CALL TControl.AttachProc -{$ENDIF} - XCHG EAX, EBX - POP EBX -end; - -{$IFNDEF USE_DROPDOWNCOUNT} -procedure ComboboxDropDown( Sender: PObj ); -asm - PUSH EBX - PUSH ESI - MOV EBX, EAX - CALL TControl.GetItemsCount - CMP EAX, 1 - JGE @@1 - MOV AL, 1 -@@1: CMP EAX, 8 - JLE @@2 - XOR EAX, EAX - MOV AL, 8 -@@2: XOR ESI, ESI - PUSH SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_SHOWWINDOW - PUSH ESI - PUSH ESI - PUSH SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_HIDEWINDOW - PUSH EAX - MOV EAX, EBX - CALL TControl.GetHeight - POP ECX - INC ECX - IMUL ECX - INC EAX - INC EAX - PUSH EAX - MOV EAX, EBX - CALL TControl.GetWidth - PUSH EAX - INC ESI -@@3: XOR EDX, EDX - PUSH EDX - PUSH EDX - PUSH EDX - PUSH [EBX].TControl.fHandle - CALL SetWindowPos - DEC ESI - JZ @@3 - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - MOV ECX, [EAX].TEvents.fOnDropDown.TMethod.Code - {$ELSE} - MOV ECX, [EBX].TControl.EV.fOnDropDown.TMethod.Code - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@exit - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnDropDown.TMethod.Data - {$ELSE} - MOV EAX, [EBX].TControl.EV.fOnDropDown.TMethod.Data - {$ENDIF} - MOV EDX, EBX - CALL ECX -@@exit: POP ESI - POP EBX -end; -{$ENDIF} - -const ComboboxClass: array[0..8] of KOLChar = ('C','O','M','B','O','B','O','X',#0 ); -function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl; -asm - {$IFDEF GRAPHCTL_XPSTYLES} - {$IFDEF UNICODE_CTRLS} - PUSHAD - CALL InitCommonControls; - POPAD - {$ENDIF} - {$ENDIF} - PUSH EDX - PUSH EAX - PUSH EDX - MOV EAX, ESP - MOV EDX, offset[ComboFlags] - XOR ECX, ECX - MOV CL, 10 - CALL MakeFlags - POP EDX - XCHG ECX, EAX - POP EAX - PUSH 1 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [ComboActions_Packed] - {$ELSE} - PUSH offset[ComboActions] - {$ENDIF} - MOV EDX, offset[ComboboxClass] - OR ECX, WS_VISIBLE or WS_CHILD or WS_VSCROLL or CBS_HASSTRINGS or WS_TABSTOP - TEST ECX, CBS_SIMPLE - JNZ @@O - OR ECX, CBS_DROPDOWN -@@O: - CALL _NewControl - {$IFDEF PACK_COMMANDACTIONS} - MOV EDX, [EAX].TControl.fCommandActions - MOV [EDX].TCommandActionsObj.aClear, offset[ClearCombobox] - {$ENDIF} - MOV Byte Ptr [EAX].TControl.aAutoSzY, 6 - MOV [EAX].TControl.PP.fCreateWndExt, offset[CreateComboboxWnd] - OR byte ptr [EAX].TControl.fClsStyle, CS_DBLCLKS - ADD [EAX].TControl.fBoundsRect.Right, 100-64 - ADD [EAX].TControl.fBoundsRect.Bottom, 22-64 - MOV CL, 1 - POP EDX - TEST DL, 1 - JZ @@exit - MOV CL, 3 -@@exit: - MOV [EAX].TControl.fLookTabKeys, CL - PUSH EAX - MOV EDX, offset[ WndProcCombo ] - CALL TControl.AttachProc - POP EAX -end; - -function WndProcParentResize( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - CMP word ptr [EDX].TMsg.message, CM_SIZE - JNZ @@exit - PUSH EAX - PUSH 0 - PUSH 0 - PUSH WM_SIZE - PUSH EAX - CALL TControl.Perform - POP EAX - CALL TControl.Invalidate -@@exit: XOR EAX, EAX -end; - -procedure InitCommonControlCommonNotify( Ctrl: PControl ); -asm - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG5, 1 shl G5_IsCommonCtl - {$ELSE} - MOV [EAX].TControl.fIsCommonControl, 1 - {$ENDIF} - MOV ECX, [EAX].TControl.fParent - JECXZ @@fin - PUSH ECX - MOV EDX, offset[WndProcCommonNotify] - CALL TControl.AttachProc - POP EAX - MOV EDX, offset[WndProcNotify] - CALL TControl.AttachProc -@@fin: -end; - -function NewProgressbar( AParent: PControl ): PControl; -asm - PUSH 1 - {$IFDEF COMMANDACTIONS_OBJ} - PUSH PROGRESS_ACTIONS - {$ELSE} - PUSH 0 - {$ENDIF} - MOV EDX, offset[Progress_class] - MOV ECX, WS_CHILD or WS_VISIBLE - CALL _NewCommonControl - LEA EDX, [EAX].TControl.fBoundsRect - MOV ECX, [EDX].TRect.Left - ADD ECX, 300 - MOV [EDX].TRect.Right, ECX - MOV ECX, [EDX].TRect.Top - ADD ECX, 20 - MOV [EDX].TRect.Bottom, ECX - XOR EDX, EDX - MOV [EAX].TControl.fMenu, EDX - MOV [EAX].TControl.fTextColor, clHighlight - {$IFDEF COMMANDACTIONS_OBJ} //todo: should be used separate Actions record - MOV ECX, [EAX].TControl.fCommandActions - MOV [ECX].TCommandActionsObj.aSetBkColor, PBM_SETBKCOLOR - {$ELSE} - MOV [EAX].TControl.fCommandActions.aSetBkColor, PBM_SETBKCOLOR - {$ENDIF} -end; - -function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl; -asm - PUSH EDX - CALL NewProgressbar - POP ECX - XOR EDX, EDX - SHR ECX, 1 - JNC @@notVert - MOV DL, 4 -@@notVert: - SHR ECX, 1 - JNC @@notSmooth - INC EDX -@@notSmooth: - OR [EAX].TControl.fStyle, EDX -end; - -// by Galkov, Jun-2009 -function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNE @@ret_false - PUSH ECX - PUSH EDX - push eax - MOV ECX, [EDX].TMsg.lParam - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] - PUSH [ECX].TNMHdr.hwndFrom - CALL GetProp - {$ELSE} - PUSH GWL_USERDATA - PUSH [ECX].TNMHdr.hwndFrom - CALL GetWindowLong - {$ENDIF} - pop ecx - POP EDX - TEST EAX, EAX - JZ @@ret_false_ECX - cmp eax, ecx - jz @@ret_false_ECX - MOV ECX, [EAX].TControl.fHandle - MOV [EDX].TMsg.hwnd, ECX - POP ECX - JMP TControl.EnumDynHandlers -@@ret_false_ECX: - POP ECX -@@ret_false: - XOR EAX, EAX -end; - -function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNE @@ret_false - PUSH EBX - MOV EBX, [EDX].TMsg.lParam - MOV EDX, [EBX].TNMHdr.code - -@@chk_nm_click: - XOR ECX, ECX - CMP EDX, NM_CLICK - JZ @@click - CMP EDX, NM_RCLICK - JNE @@chk_killfocus - {$IFDEF USE_FLAGS} - MOV CL, 1 shl G6_RightClick - {$ELSE} - INC ECX - {$ENDIF} -@@click: - {$IFDEF USE_FLAGS} - AND [EAX].TControl.fFlagsG6, not(1 shl G6_RightClick) - OR [EAX].TControl.fFlagsG6, CL - {$ELSE} - MOV [EAX].TControl.fRightClick, CL - {$ENDIF} - - {$IFDEF EVENTS_DYNAMIC} - MOV ECX, [EAX].TControl.EV - MOV ECX, [ECX].TEvents.fOnClick.TMethod.Code - {$ELSE} - MOV ECX, [EAX].TControl.EV.fOnClick.TMethod.Code - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@fin_false - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EDX, [EAX].TControl.EV - MOV EDX, [EDX].TEvents.fOnClick.TMethod.Data - {$ELSE} - MOV EDX, [EAX].TControl.EV.fOnClick.TMethod.Data - {$ENDIF} - JMP @@fin_event - -{$IFDEF NIL_EVENTS} -@@fin_false: - POP EBX -@@ret_false: - XOR EAX, EAX - RET -{$ENDIF} - -@@chk_killfocus: - CMP EDX, NM_KILLFOCUS - JNE @@chk_setfocus - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TControl.EV - MOV ECX, [EAX].TEvents.fOnLeave.TMethod.Code - {$ELSE} - MOV ECX, [EAX].TControl.EV.fOnLeave.TMethod.Code - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@fin_false - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EDX, [EAX].TEvents.fOnLeave.TMethod.Data - {$ELSE} - MOV EDX, [EAX].TControl.EV.fOnLeave.TMethod.Data - {$ENDIF} - JMP @@fin_event -@@chk_setfocus: - CMP EDX, NM_RETURN - JE @@set_focus - CMP EDX, NM_SETFOCUS - JNE @@fin_false - -@@set_focus: - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TControl.EV - MOV ECX, [EAX].TEvents.fOnEnter.TMethod.Code - {$ELSE} - MOV ECX, [EAX].TControl.EV.fOnEnter.TMethod.Code - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@fin_false - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EDX, [EAX].TEvents.fOnEnter.TMethod.Data - {$ELSE} - MOV EDX, [EAX].TControl.EV.fOnEnter.TMethod.Data - {$ENDIF} - -@@fin_event: - XCHG EAX, EDX - CALL ECX -{$IFnDEF NIL_EVENTS} -@@fin_false: -{$ENDIF} - POP EBX -{$IFnDEF NIL_EVENTS} -@@ret_false: -{$ENDIF} - //MOV AL, 1 - XOR EAX, EAX -end; - -procedure ApplyImageLists2Control( Sender: PControl ); -asm - PUSHAD - XCHG ESI, EAX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [ESI].TControl.fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aSetImgList - {$ELSE} - MOVZX ECX, [ESI].TControl.fCommandActions.aSetImgList - {$ENDIF} - JECXZ @@fin - MOV EBP, ECX - XOR EBX, EBX - MOV BL, 32 - XOR EDI, EDI -@@loo: - MOV EAX, ESI - MOV EDX, EBX - CALL TControl.GetImgListIdx - TEST EAX, EAX - JZ @@nx - CALL TImageList.GetHandle - PUSH EAX - PUSH EDI - PUSH EBP - PUSH ESI - CALL TControl.Perform -@@nx: - INC EDI - SHR EBX, 1 - JZ @@fin - CMP BL, 16 - JGE @@loo - XOR EBX, EBX - JMP @@loo -@@fin: - POPAD -end; - -procedure ApplyImageLists2ListView( Sender: PControl ); -asm - PUSHAD - - XCHG ESI, EAX - PUSH dword ptr [ESI].TControl.DF.fLVOptions - MOV EAX, ESP - MOV EDX, offset[ListViewFlags] - XOR ECX, ECX - MOV CL, 25 - CALL MakeFlags - POP ECX - PUSH ECX - - MOV EDX, [ESI].TControl.fStyle - //AND DH, 3 - AND DX, not $403F - OR EDX, EAX - - MOVZX EAX, [ESI].TControl.DF.fLVStyle - OR EDX, [EAX*4 + offset ListViewStyles] - - MOV EAX, ESI - CALL TControl.SetStyle - - MOV EAX, ESP - MOV EDX, offset[ListViewExFlags] - XOR ECX, ECX - MOV CL, 23 - CALL MakeFlags - POP EDX - PUSH EAX - PUSH $3FFF - PUSH LVM_SETEXTENDEDLISTVIEWSTYLE - PUSH ESI - CALL TControl.Perform - - POPAD - CALL ApplyImageLists2Control -end; - -function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions; - ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl; -asm - PUSH EDX - PUSH ECX - MOVZX EDX, DL - MOV ECX, [EDX*4 + offset ListViewStyles] - OR ECX, LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP - MOV EDX, offset[WC_LISTVIEW] - PUSH 1 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [ListViewActions_Packed] - {$ELSE} - PUSH offset[ListViewActions] - {$ENDIF} - CALL _NewCommonControl - - {$IFDEF PACK_COMMANDACTIONS} - MOV EDX, [EAX].TControl.fCommandActions - MOV [EDX].TCommandActionsObj.aClear, offset[ClearListView] - {$ENDIF} - - MOV EDX, ESP - PUSH EAX - XCHG EAX, EDX - MOV EDX, offset ListViewFlags - XOR ECX, ECX - MOV CL, 25 - CALL MakeFlags - XCHG EDX, EAX - POP EAX - MOV ECX, [EAX].TControl.fStyle - AND ECX, not LVS_TYPESTYLEMASK - OR EDX, ECX - MOV [EAX].TControl.fStyle, EDX - - POP [EAX].TControl.DF.fLVOptions - POP EDX - MOV [EAX].TControl.DF.fLVStyle, DL - MOV [EAX].TControl.PP.fCreateWndExt, offset[ApplyImageLists2ListView] - ADD [EAX].TControl.fBoundsRect.Right, 200-64 - ADD [EAX].TControl.fBoundsRect.Bottom, 150-64 - MOV ECX, [ImageListState] - XOR EDX, EDX - PUSHAD - CALL TControl.SetImgListIdx - POPAD - MOV ECX, [ImageListSmall] - MOV DL, 16 - PUSHAD - CALL TControl.SetImgListIdx - POPAD - MOV ECX, [ImageListNormal] - ADD EDX, EDX - PUSH EAX - CALL TControl.SetImgListIdx - POP EAX - MOV [EAX].TControl.DF.fLVTextBkColor, clWindow - XOR EDX, EDX - INC EDX - MOV [EAX].TControl.fLookTabKeys, DL -end; - -function NewTreeView( AParent: PControl; Options: TTreeViewOptions; - ImgListNormal, ImgListState: PImageList ): PControl; -asm //cmd //opd - PUSH EBX - PUSH ECX - PUSH EAX - PUSH EDX - MOV EAX, ESP - MOV EDX, offset[TreeViewFlags] - XOR ECX, ECX - MOV CL, 13 - CALL MakeFlags - POP EDX - OR EAX, WS_VISIBLE or WS_CHILD or WS_TABSTOP - XCHG ECX, EAX - POP EAX - MOV EDX, offset[WC_TREEVIEW] - PUSH 1 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [TreeViewActions_Packed] - {$ELSE} - PUSH offset[TreeViewActions] - {$ENDIF} - CALL _NewCommonControl - MOV EBX, EAX - {$IFDEF PACK_COMMANDACTIONS} - MOV EDX, [EBX].TControl.fCommandActions - MOV [EDX].TCommandActionsObj.aClear, offset[ClearTreeView] - {$ENDIF} - MOV [EBX].TControl.PP.fCreateWndExt, offset[ApplyImageLists2Control] - MOV [EBX].TControl.fColor, clWindow - MOV EDX, offset[WndProcTreeView] - CALL TControl.AttachProc - ADD [EBX].TControl.fBoundsRect.Right, 150-64 - ADD [EBX].TControl.fBoundsRect.Bottom, 200-64 - MOV EAX, EBX - XOR EDX, EDX - MOV DL, 32 - POP ECX // ImageListNormal - CALL TControl.SetImgListIdx - MOV EAX, EBX - XOR EDX, EDX - MOV ECX, [ImgListState] - CALL TControl.SetImgListIdx - MOV byte ptr [EBX].TControl.fLookTabKeys, 1 - XCHG EAX, EBX - POP EBX -end; - -function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm //cmd //opd -{$IFDEF OLD_ALIGN} - PUSH EBP - PUSH EBX - PUSH ESI - PUSH EDI - MOV EBX, EAX - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNZ @@chk_WM_SIZE - MOV EDX, [EDX].TMsg.lParam -//!!! - CMP word ptr [EDX].TNMHdr.code, TCN_SELCHANGING - JNZ @@chk_TCN_SELCHANGE - CALL TControl.GetCurIndex - MOV [EBX].TControl.fCurIndex, EAX - JMP @@ret_false -@@chk_TCN_SELCHANGE: - CMP word ptr [EDX].TNMHdr.code, TCN_SELCHANGE - JNZ @@ret_false - - CALL TControl.GetCurIndex - XCHG EDI, EAX - CMP EDI, [EBX].TControl.fCurIndex - PUSHFD // WasActive = ZF - - MOV [EBX].TControl.FCurIndex, EDI - - MOV EAX, EBX - CALL TControl.GetItemsCount - XCHG ESI, EAX // ESI := Self_.Count - -@@loo: DEC ESI - JS @@e_loo - MOV EDX, ESI - MOV EAX, EBX - CALL TControl.GetPages - - CMP ESI, EDI - PUSH EAX - SETZ DL - CALL TControl.SetVisible - POP EAX - CMP ESI, EDI - JNE @@nx_loo - CALL TControl.BringToFront -@@nx_loo: - JMP @@loo -@@e_loo: - POPFD - JZ @@ret_false - - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - MOV ECX, [EAX].TEvents.fOnSelChange.TMethod.Code - {$ELSE} - MOV ECX, [EBX].TControl.EV.fOnSelChange.TMethod.Code - {$ENDIF} - JECXZ @@ret_false - MOV EDX, EBX - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnSelChange.TMethod.Data - {$ELSE} - MOV EAX, [EBX].TControl.EV.fOnSelChange.TMethod.Data - {$ENDIF} - CALL ECX - JMP @@ret_false -@@chk_WM_SIZE: - CMP word ptr [EDX].TMsg.message, WM_SIZE - JNE @@ret_false - ADD ESP, -16 - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL Windows.GetClientRect - PUSH ESP - PUSH 0 - PUSH TCM_ADJUSTRECT - PUSH EBX - CALL TControl.Perform - MOV EAX, EBX - CALL TControl.GetItemsCount - XCHG ESI, EAX -@@loo2: - DEC ESI - JS @@e_loo2 - MOV EDX, ESI - MOV EAX, EBX - CALL TControl.GetPages - MOV EDX, ESP - CALL TControl.SetBoundsRect - JMP @@loo2 -@@e_loo2: - ADD ESP, 16 -@@ret_false: - XOR EAX, EAX - POP EDI - POP ESI - POP EBX - POP EBP -{$ELSE NEW_ALIGN} - PUSH EBX - MOV EBX, EAX - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNZ @@chk_WM_SIZE - MOV EDX, [EDX].TMsg.lParam - - CMP word ptr [EDX].TNMHdr.code, TCN_SELCHANGING - JNZ @@chk_TCN_SELCHANGE - CALL TControl.GetCurIndex - MOV [EBX].TControl.fCurIndex, EAX - JMP @@ret_false -@@chk_TCN_SELCHANGE: - CMP word ptr [EDX].TNMHdr.code, TCN_SELCHANGE - JNZ @@ret_false - CALL TControl.GetCurIndex - MOV EDX, [EBX].TControl.fCurIndex - MOV [EBX].TControl.fCurIndex, EAX - CMP EAX, EDX - PUSHFD // WasActive = ZF - BT EDX,31 - JBE @@00 - MOV EAX, EBX - CALL TControl.GetPages - XOR EDX,EDX - CALL TControl.SetVisible -@@00: - MOV EDX, [EBX].TControl.fCurIndex - MOV EAX, EBX - CALL TControl.GetPages - MOV DL,1 - PUSH EAX - CALL TControl.SetVisible - POP EAX - CALL TControl.BringToFront - POPFD - JZ @@ret_false - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - MOV ECX, [EAX].TEvents.fOnSelChange.TMethod.Code - {$ELSE} - MOV ECX, [EBX].TControl.EV.fOnSelChange.TMethod.Code - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@ret_false - {$ENDIF} - MOV EDX, EBX - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnSelChange.TMethod.Data - {$ELSE} - MOV EAX, [EBX].TControl.EV.fOnSelChange.TMethod.Data - {$ENDIF} - CALL ECX - JMP @@ret_false -@@chk_WM_SIZE: - CMP word ptr [EDX].TMsg.message, WM_SIZE - JNE @@ret_false - SUB ESP, 10h - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL Windows.GetClientRect - MOV EAX,[ESP].TRect.Right - MOV [EBX].TControl.fClientRight, AL - MOV EAX,[ESP].TRect.Bottom - MOV [EBX].TControl.fClientBottom, AL - PUSH ESP - PUSH 0 - PUSH TCM_ADJUSTRECT - PUSH EBX - CALL TControl.Perform - POP EAX - MOV [EBX].TControl.fClientLeft, AL - POP EAX - MOV [EBX].TControl.fClientTop, AL - POP EAX - SUB [EBX].TControl.fClientRight, AL - POP EAX - SUB [EBX].TControl.fClientBottom, AL -@@ret_false: - XOR EAX, EAX - POP EBX -{$ENDIF} -end; - -{$IFNDEF OLD_ALIGN} -function NewTabEmpty( AParent: PControl; Options: TTabControlOptions; - ImgList: PImageList ): PControl; -const lenf=high(TabControlFlags); //+++ -asm //cmd //opd - PUSH EBX - MOV EBX, EAX - PUSH ECX - PUSH EDX - MOV EAX, ESP - MOV EDX, offset[TabControlFlags] - XOR ECX, ECX - MOV CL, lenf - CALL MakeFlags - TEST byte ptr [ESP], 4 - JZ @@0 - OR EAX, WS_TABSTOP or TCS_FOCUSONBUTTONDOWN -@@0: OR EAX, WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE - XCHG ECX, EAX - XCHG EAX, EBX - MOV EDX, offset[WC_TABCONTROL] - PUSH 1 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [TabControlActions_Packed] - {$ELSE} - PUSH offset[TabControlActions] - {$ENDIF} - CALL _NewCommonControl - MOV EBX, EAX - POP ECX //Options - TEST ECX, 2 shl (tcoBorder - 1) - JNZ @@borderfixed - AND [EBX].TControl.fExStyle, not WS_EX_CLIENTEDGE -@@borderfixed: - MOV EDX, offset[WndProcTabControl] - CALL TControl.AttachProc - ADD [EBX].TControl.fBoundsRect.Right, 100-64 - ADD [EBX].TControl.fBoundsRect.Bottom, 100-64 - POP ECX //ImgList - JECXZ @@2 - XCHG EAX, ECX - CALL TImageList.GetHandle - PUSH EAX - PUSH 0 - PUSH TCM_SETIMAGELIST - PUSH EBX - CALL TControl.Perform -@@2: - MOV byte ptr [EBX].TControl.fLookTabKeys, 1 - XCHG EAX, EBX - POP EBX -end; -{$ENDIF} - -{$IFNDEF NOT_USE_RICHEDIT} - -const RichEdit50W: array[0..11] of AnsiChar = ('R','i','c','h','E','d','i','t','5','0','W',#0 ); -function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl; -const deltaChr = 24; // sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat ); - deltaPar = sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat ); -asm - PUSHAD - CALL OleInit - TEST EAX, EAX - POPAD - JZ @@new1 - MOV [RichEditIdx], 0 - CALL NewRichEdit1 - MOV byte ptr [EAX].TControl.DF.fCharFmtDeltaSz, deltaChr - MOV byte ptr [EAX].TControl.DF.fParaFmtDeltaSz, deltaPar - RET -@@new1: CALL NewRichEdit1 -end; - -(* -function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNE @@ret_false - MOV EDX, [EDX].TMsg.lParam - CMP [EDX].TNMHdr.code, EN_LINK - JNE @@ret_false - PUSH EBX - PUSH EDX - XCHG EBX, EAX - XOR EAX, EAX - MOV [ECX], EAX - {$IFDEF UNICODE_CTRLS} - ADD ESP, -2040 - {$ELSE} - ADD ESP, -1020 - {$ENDIF} - PUSH EAX - PUSH ESP - PUSH [EDX].TENLink.chrg.cpMax - PUSH [EDX].TENLink.chrg.cpMin - PUSH ESP - PUSH 0 - PUSH EM_GETTEXTRANGE - PUSH EBX - CALL TControl.Perform - LEA EAX, [EBX].TControl.fREUrl - - POP EDX - POP ECX - DEC EDX - CMP ECX, EDX - POP ECX - MOV EDX, ESP - JLE @@1 - CMP byte ptr [EDX+1], 0 - JNZ @@1 - // система вернула текст как unicode - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrFromPWChar // TODO: not need ecx - {$ELSE not UNICODE_CTRLS} - {$IFDEF _D2} - CALL LStrFromPWChar - {$ELSE} - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: fixme - {$ENDIF} - CALL System.@LStrFromPWChar - {$ENDIF} - {$ENDIF UNICODE_CTRLS} - JMP @@2 -@@1: - // система вернула текст как обычную строку - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrFromPChar - {$ELSE not UNICODE_CTRLS} - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: fixme - {$ENDIF} - CALL System.@LStrFromPChar - {$ENDIF UNICODE_CTRLS} -@@2: - {$IFDEF UNICODE_CTRLS} - ADD ESP, 2044 - {$ELSE not UNICODE_CTRLS} - ADD ESP, 1024 - {$ENDIF UNICODE_CTRLS} - POP EDX - MOV ECX, [EDX].TENLink.msg - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - LEA EAX, [EAX].TEvents.fOnREOverURL - {$ELSE} - LEA EAX, [EBX].TControl.EV.fOnREOverURL - {$ENDIF} - CMP ECX, WM_MOUSEMOVE - JE @@Url_event - //LEA EAX, [EBX].TControl.EV.fOnREUrlClick - ADD EAX, 8 - CMP ECX, WM_LBUTTONDOWN - JE @@Url_Event - CMP ECX, WM_RBUTTONDOWN - JNE @@after_Url_event -@@Url_event: - MOV ECX, [EAX].TMethod.Code - {$IFDEF NIL_EVENTS} - JECXZ @@after_Url_event - {$ENDIF} - MOV EDX, EBX - MOV EAX, [EAX].TMethod.Data - CALL ECX -@@after_Url_event: - POP EBX - MOV AL, 1 - RET -@@ret_false: - XOR EAX, EAX -end; -*) -{$ENDIF NOT_USE_RICHEDIT} - -function OleInit: Boolean; -asm - MOV ECX, [OleInitCount] - INC ECX - LOOP @@init1 - PUSH ECX - CALL OleInitialize - TEST EAX, EAX - MOV AL, 0 - JNZ @@exit -@@init1: - INC [OleInitCount] - MOV AL, 1 -@@exit: -end; - -procedure OleUnInit; -asm - MOV ECX, [OleInitCount] - JECXZ @@exit - DEC [OleInitCount] - JNZ @@exit - CALL OleUninitialize -@@exit: -end; - -procedure TControl.Init; -const - IniStyle = WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or - WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or - WS_BORDER or WS_THICKFRAME; -asm //cmd //opd - PUSH EBX - PUSH EDI - MOV EBX, EAX - {$IFDEF CALL_INHERITED} - CALL TObj.Init // for now, TObj.Init do nothing for Delphi 4 and higher - {$ENDIF} - {$IFDEF USE_GRAPHCTLS} - MOV [EBX].PP.fDoInvalidate, offset[InvalidateWindowed] - {$ENDIF} - - {$IFDEF OLD_EVENTS_MODEL} - MOV EAX, offset WndProcDummy - LEA EDI, [EBX].PP.fPass2DefProc - STOSD // fPass2DefProc := WndProcDummy - STOSD // fOnDynHandlers := WndProcDummy - STOSD // fWndProcKeybd := WndProcDummy - STOSD // fControlClick := WndProcDummy - similar to DefWindowProc - STOSD // fAutoSize := WndProcDummy - similar to DefWindowProc - LEA EDI, [EBX].PP.fWndProcResizeFlicks - STOSD - - MOV [EBX].PP.fWndFunc, offset WndFunc - {$ELSE NEW_EVENTS_MODEL} - {$IFDEF EVENTS_DYNAMIC} - XOR ECX, ECX - CMP DWORD PTR[EmptyEvents].TEvents.fOnMessage.TMethod.Code, ECX - JNZ @@a2 - MOV CL, idx_LastEvent+1 - @@a1: MOVZX EDX, byte ptr [ECX+InitEventsTable-1] - AND DL, $0F - MOV EDX, dword ptr [EDX*4 + DummyProcTable] - MOV dword ptr [EmptyEvents+ECX*8-8], EDX - LOOP @@a1 - @@a2: - MOV EDX, offset[EmptyEvents] - MOV [EBX].EV, EDX - MOV CL, idx_LastProc - idx_LastEvent - @@a3: - MOVZX EDX, byte ptr [ECX+InitEventsTable-1] - SHR EDX, 4 - MOV EDX, dword ptr [EDX*4 + DummyProcTable] - MOV dword ptr [EBX+ECX*4-4].PP, EDX - LOOP @@a3 - {$ELSE} - XOR ECX, ECX - MOV CL, idx_LastEvent+1 - @@1: - MOVZX EDX, byte ptr [ECX+InitEventsTable-1] - PUSH EDX - AND DL, $0F - MOV EDX, [EDX*4 + DummyProcTable] - MOV dword ptr [EBX+ECX*8-8].EV, EDX - POP EDX - SHR EDX, 4 - CMP ECX, idx_LastProc - idx_LastEvent + 1 - JGE @@2 - - MOV EDX, [EDX*4 + DummyProcTable] - MOV dword ptr [EBX+ECX*4-4].PP, EDX - @@2: - LOOP @@1 - {$ENDIF} - {$ENDIF NEW_EVENTS_MODEL} - - {$IFDEF COMMANDACTIONS_OBJ} //--- moved to _NewWindowed - //---- MOV EDX, [EBX].fCommandActions - //---- MOV [EDX].TCommandActionsObj.aClear, offset[ClearText] - {$ELSE} - //---- MOV [EBX].fCommandActions.aClear, offset[ClearText] - {$ENDIF} - {$IFDEF USE_FLAGS} - {$ELSE} - INC [EBX].fWindowed - {$ENDIF} - MOV [EBX].fColor, clBtnFace - {$IFDEF SYSTEMCOLORS_DELPHI} - MOV [EBX].fTextColor, clWindowText and $FF - {$ELSE} - MOV [EBX].fTextColor, clWindowText - {$ENDIF} - - MOV byte ptr [EBX].fMargin, 2 - OR dword ptr [EBX].fCtl3D_child, 3 - - {$IFDEF SMALLEST_CODE} - {$ELSE} - DEC byte ptr [EBX].fAlphaBlend // has no effect until AlphaBlend changed - {$ENDIF} - MOV byte ptr[EBX].fClsStyle, CS_OWNDC - MOV [EBX].fStyle, IniStyle - INC dword ptr[EBX].fExStyle+2 - {$IFDEF USE_FLAGS} - //AND [EBX].fStyle.f3_Style, not(1 shl F3_Disabled) - OR [EBX].fStyle.f3_Style, (1 shl F3_Visible) - {$ELSE} - DEC WORD PTR [EBX].fEnabled - {$ENDIF} - - LEA EDI, [EBX].fDynHandlers - MOV EBX, offset[NewList] - CALL EBX - STOSD - CALL EBX - STOSD - - POP EDI - POP EBX -end; - -procedure CallTControlInit( Ctl: PControl ); -begin - Ctl.Init; -end; - -procedure TControl.InitParented( AParent: PControl ); -const IStyle = WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or - WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or - WS_BORDER or WS_THICKFRAME; - IExStyle = WS_EX_CONTROLPARENT; - IClsStyle = CS_OWNDC; - int_IDC_ARROW = integer( IDC_ARROW ); -asm - PUSH EAX - PUSH EDX - //CALL CallTControlInit - mov EDX, [EAX] - call dword ptr [EDX] - - POP EDX - POP EAX - TEST EDX, EDX - JZ @@0 - MOV ECX, [EDX].fColor - MOV [EAX].fColor, ECX -@@0: - CALL SetParent -end; - -destructor TControl.Destroy; -asm - PUSH EBX - PUSH ESI - MOV EBX, EAX - CALL TControl.ParentForm - XCHG ECX, EAX - JECXZ @@cur_ctl_removed - MOV EDX, EBX - XOR EDX, [ECX].TControl.DF.fCurrentControl - JNE @@cur_ctl_removed - MOV [ECX].TControl.DF.fCurrentControl, EDX -@@cur_ctl_removed: - - MOV ECX, [EBX].fHandle - JECXZ @@wndhidden - PUSH SW_HIDE - PUSH ECX - CALL ShowWindow -@@wndhidden: - - MOV EAX, EBX - CALL Final - {$IFDEF USE_AUTOFREE4CHILDREN} - {$ELSE} - MOV EAX, EBX - CALL DestroyChildren - {$ENDIF} - - {$IFDEF USE_FLAGS} - BTS DWORD PTR [EBX].fFlagsG2, G2_Destroying - JC @@destroyed - {$ELSE} - XOR ECX, ECX - CMP [EBX].fDestroying, CL - JNZ @@destroyed - INC [EBX].fDestroying - {$ENDIF USE_FLAGS} - - {$IFDEF USE_AUTOFREE4CONTROLS} - XOR EAX, EAX - XCHG EAX, [EBX].fCanvas - CALL TObj.RefDec - {$ELSE} - PUSH EBX - LEA ESI, [EBX].fFont - MOV BL, 3 -@@free_font_brush_canvas: - XOR ECX, ECX - XCHG ECX, [ESI] - LODSD - XCHG EAX, ECX - CALL TObj.RefDec - DEC BL - JNZ @@free_font_brush_canvas - POP EBX - {$ENDIF} - - MOV EAX, [EBX].fCustomObj - CALL TObj.RefDec - - MOV EAX, [EBX].fHandle - TEST EAX, EAX - JZ @@free_fields - - {$IFNDEF USE_AUTOFREE4CONTROLS} - {$IFNDEF NEW_MENU_ACCELL} - XOR ECX, ECX - XCHG ECX, [EBX].fAccelTable - JECXZ @@accelTable_destroyed - PUSH ECX - CALL DestroyAcceleratorTable -@@accelTable_destroyed: - {$ENDIF} - MOV EAX, [EBX].fMenuObj - CALL TObj.RefDec -@@destroy_img_list: - XOR EAX, EAX - XCHG EAX, [EBX].fImageList - TEST EAX, EAX - JZ @@img_list_destroyed - CALL TObj.RefDec - JMP @@destroy_img_list -@@img_list_destroyed: - {$ENDIF} - - MOV ECX, [EBX].DF.fIcon - JECXZ @@icoremoved - INC ECX - JZ @@icoremoved - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG1, (1 shl G1_IconShared) - JNZ @@icoremoved - {$ELSE} - CMP [EBX].fIconShared, 0 - JNZ @@icoremoved - {$ENDIF USE_FLAGS} - DEC ECX - PUSH ECX - CALL DestroyIcon -@@icoremoved: - - PUSH [EBX].fHandle - CALL IsWindow - TEST EAX, EAX - JZ @@destroy2 - (* -- moved to WM_NCDESTROY handler - VK + Alexey Kirov - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] //* Remarked By M.Gerasimov - PUSH [EBX].fHandle //* unremarked to prevent problems with progress bar - CALL RemoveProp - {$ELSE} - PUSH 0 - PUSH GWL_USERDATA - PUSH [EBX].fHandle - CALL SetWindowLong - {$ENDIF} - *) - {$IFDEF USE_fNCDestroyed} - CMP [EBX].fNCDestroyed, 0 - JNZ @@destroy2 - {$ENDIF USE_fNCDestroyed} - PUSH [EBX].fHandle - CALL DestroyWindow -@@destroy2: - XOR EAX, EAX - MOV [EBX].fHandle, EAX - -@@free_fields: - PUSH 0 - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG6, 1 shl G6_CtlClassNameChg - JZ @@notFreeCtlClsName - {$ELSE} - MOVZX ECX, [EBX].fCtlClsNameChg - JECXZ @@notFreeCtlClsName - {$ENDIF} - PUSH [EBX].fControlClassName -@@notFreeCtlClsName: - MOV ECX, [EBX].fCustomData - JECXZ @@notFreeCustomData - PUSH ECX -@@notFreeCustomData: -@@FreeFieldsLoop: - POP ECX - JECXZ @@endFreeFieldsLoop - XCHG EAX, ECX - CALL System.@FreeMem - JMP @@FreeFieldsLoop -@@endFreeFieldsLoop: - - XOR ECX, ECX - XCHG ECX, [EBX].fTmpBrush - JECXZ @@tmpBrush_deleted - PUSH ECX - CALL DeleteObject -@@tmpBrush_deleted: - - MOV ECX, [EBX].fParent - JECXZ @@removed_from_parent - CMP [ECX].DF.fCurrentControl, EBX - JNE @@removefromParent - XOR EAX, EAX - MOV [ECX].DF.fCurrentControl, EAX -@@removefromParent: - {$IFDEF USE_AUTOFREE4CHILDREN} - PUSH ECX - {$ENDIF} - MOV EAX, [ECX].fChildren - MOV EDX, EBX - CALL TList.Remove - {$IFDEF USE_AUTOFREE4CHILDREN} - POP EAX - MOV EDX, EBX - CALL TControl.RemoveFromAutoFree - {$ENDIF} -@@removed_from_parent: - - {$IFDEF USE_AUTOFREE4CONTROLS} - LEA ESI, [EBX].fDynHandlers - LODSD - CALL TObj.RefDec - LODSD // fChildren - CALL TObj.RefDec - {$ELSE} - PUSH EBX - LEA ESI, [EBX].fDynHandlers - MOV BL, 5 -@@freeloo: - LODSD - CALL TObj.RefDec - DEC BL - JNZ @@freeloo - POP EBX - {$ENDIF} - - LEA EAX, [EBX].fCaption - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrClr - {$ELSE} - CALL System.@LStrClr - {$ENDIF} - XCHG EAX, EBX - CALL TObj.Destroy -@@destroyed: - POP ESI - POP EBX -end; - -procedure TControl.SetEnabled( Value: Boolean ); -asm - PUSH EBX - MOV EBX, EAX - MOVZX EDX, DL - PUSH EDX - CALL GetEnabled - POP EDX - CMP AL, DL - JZ @@exit - {$IFDEF USE_FLAGS} - {$ELSE} - MOV [EBX].fEnabled, DL - {$ENDIF USE_FLAGS} - TEST EDX, EDX - JNZ @@andnot - OR [EBX].fStyle.f3_Style, (1 shl F3_Disabled) - JMP @@1 -@@andnot: - AND [EBX].fStyle.f3_Style, not(1 shl F3_Disabled) -@@1: - MOV ECX, [EBX].fHandle - JECXZ @@2 - - PUSH EDX - PUSH ECX - CALL EnableWindow - -@@2: - XCHG EAX, EBX - CALL Invalidate - -@@exit: - POP EBX -end; - -{function TControl.GetParentWindow: HWnd; -asm - MOV ECX, [EAX].fHandle - JECXZ @@1 - PUSH EAX - PUSH GW_OWNER - PUSH EAX - CALL GetWindow - POP ECX - TEST EAX, EAX - JZ @@0 - RET -@@0: XCHG EAX, ECX -@@1: - MOV EAX, [EAX].fParent - TEST EAX, EAX - JNZ TControl.GetWindowHandle -end;} - -function WndProcMouse(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -asm - PUSH EBX - PUSH ESI - XCHG EBX, EAX - - XOR ECX, ECX // Rslt not used. ECX <= Result = 0 - MOV EAX, [EDX].TMsg.message - SUB AH, WM_MOUSEFIRST shr 8 - CMP EAX, $20A - WM_MOUSEFIRST //WM_MOUSELAST - WM_MOUSEFIRST - JA @@exit - - PUSH dword ptr [EDX].TMsg.lParam // prepare X, Y - - PUSHAD - PUSH VK_MENU - CALL GetKeyState - ADD EAX, EAX - POPAD - - XCHG EAX, EDX - MOV EAX, [EAX].TMsg.wParam - - JNC @@noset_MKALT - {$IFDEF PARANOIA} DB $0C, MK_ALT {$ELSE} OR AL, MK_ALT {$ENDIF} -@@noset_MKALT: - - PUSH EAX // prepare Shift - - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - LEA ESI, [EAX].TEvents.fOnMouseDown - {$ELSE} - LEA ESI, [EBX].TControl.EV.fOnMouseDown - {$ENDIF} - CALL dword ptr [EDX*4 + @@jump_table] - -@@call_evnt: - - PUSH ECX // prepare Button, StopHandling - MOV ECX, ESP // ECX = @MouseData - - {$IFDEF NIL_EVENTS} - CMP word ptr [ESI].TMethod.Code+2, 0 - JZ @@after_call - {$ENDIF} - - MOV EDX, EBX // EDX = Self_ - MOV EAX, [ESI].TMethod.Data // EAX = Target_ - CALL dword ptr [ESI].TMethod.Code - -@@after_call: - POP ECX - POP EDX - POP EDX - MOV CL, CH // Result := StopHandling - -@@exit: - XCHG EAX, ECX - POP ESI - POP EBX - RET - -@@jump_table: - DD Offset[@@MMove],Offset[@@LDown],Offset[@@LUp],Offset[@@LDblClk] - DD Offset[@@RDown],Offset[@@RUp],Offset[@@RDblClk] - DD Offset[@@MDown],Offset[@@MUp],Offset[@@MDblClk],Offset[@@MWheel] - -@@MDown: INC ECX -@@RDown: INC ECX -@@LDown: INC ECX - RET - -@@MUp: INC ECX -@@RUp: INC ECX -@@LUp: INC ECX - LODSD - LODSD - RET - -@@MMove: ADD ESI, 16 - RET - -@@MDblClk: INC ECX -@@RDblClk: INC ECX -@@LDblClk: INC ECX - ADD ESI, 24 - RET - -@@MWheel:ADD ESI, 32 -end; - -{$IFnDEF USE_GRAPHCTLS} -{$IFnDEF NEW_MODAL} -{$IFnDEF USE_MDI} -function TControl.WndProc( var Msg: TMsg ): Integer; -asm //cmd //opd - PUSH EBX - PUSH ESI - PUSH EDI - PUSH EBP - //MOV ESI, EAX - XCHG ESI, EAX - MOV EDI, EDX - //CALL TControl.RefInc - MOV EBP, [ESI].TControl.PP.fPass2DefProc - - XOR EAX, EAX - CMP EAX, [EDI].TMsg.hWnd - JE @@1 - CMP EAX, [ESI].TControl.fHandle - JNE @@1 - {$IFDEF USE_GRAPHCTLS} - {$IFDEF USE_FLAGS} - TEST [ESI].TControl.fFlagsG6, 1 shl G6_GraphicCtl - {$ELSE} - CMP [ESI].TControl.fWindowed, AL - {$ENDIF} - JNE @@1 - {$ENDIF} - MOV EAX, [EDI].TMsg.hWnd - MOV [ESI].TControl.fHandle, EAX -@@1: - XOR eax, eax - - CMP [AppletRunning], AL - JZ @@dyn2 - MOV ECX, [Applet] - JECXZ @@dyn2 - CMP ECX, ESI - JE @@dyn2 - - CALL @@onmess - -@@dyn2: MOV ECX, ESI - CALL @@onmess - - MOV EBX, [ESI].TControl.PP.fOnDynHandlers - MOV EAX, ESI - CALL @@callonmes - -//********************************************************** - MOVZX EAX, word ptr [EDI].TMsg.message - CMP AX, WM_CLOSE - JNZ @@chk_WM_DESTROY - - CMP ESI, [Applet] - JZ @@postquit - MOV EAX, ESI - CALL IsMainWindow - TEST AL, AL - JZ @@calldef -@@postquit: - PUSH 0 - CALL PostQuitMessage - MOV byte ptr [AppletTerminated], 1 - JMP @@calldef -//********************************************************** Added By M.Gerasimov -@@chk_WM_DESTROY: - {$IFnDEF SMALLER_CODE} - MOV EDX, [EDI].TMsg.hWnd - {$ENDIF SMALLER_CODE} - CMP AX, WM_DESTROY - JNE @@chk_WM_NCDESTROY - - {$IFnDEF SMALLER_CODE} - CMP EDX, [ESI].TControl.fHandle - JNE @@chk_WM_NCDESTROY - {$ENDIF SMALLER_CODE} - - {$IFDEF USE_FLAGS} - OR [ESI].TControl.fFlagsG2, (1 shl G2_BeginDestroying) - {$ELSE} - MOV [ESI].TControl.fBeginDestroying, AL - {$ENDIF} - JMP @@calldef -//********************************************************** -@@chk_WM_NCDESTROY: - CMP AX, WM_NCDESTROY - JNE @@chk_WM_SIZE // @@chk_CM_RELEASE -//********************************************************** Added By M.Gerasimov - {$IFnDEF SMALLER_CODE} - CMP EDX, [ESI].TControl.fHandle - JNE @@chk_WM_SIZE - {$ENDIF SMALLER_CODE} - - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] - PUSH [ESI].fHandle - CALL RemoveProp - {$ELSE} - PUSH 0 - PUSH GWL_USERDATA - PUSH [ESI].fHandle - CALL SetWindowLong - {$ENDIF} - JMP @@calldef -//********************************************************** -@@return0: - XOR EAX, EAX - JMP @@exit // WM_NCDESTROY and CM_RELEASE - // is not a subject to pass it - // to fPass2DefProc -@@onmess: - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [ECX].TControl.EV - MOV EBX, [EAX].TEvents.fOnMessage.TMethod.Code - MOV EAX, [EAX].TEvents.fOnMessage.TMethod.Data - {$ELSE} - MOV EAX, [ECX].TControl.EV.fOnMessage.TMethod.Data - MOV EBX, [ECX].TControl.EV.fOnMessage.TMethod.Code - {$ENDIF} -@@callonmes: - {$IFDEF NIL_EVENTS} - TEST EBX, EBX - JZ @@ret - {$ENDIF} -@@onmess1: - PUSH 0 - - MOV EDX, EDI - MOV ECX, ESP - CALL EBX - TEST AL, AL - - POP EAX - JZ @@ret - POP EDX // pop retaddr - JMP @@pass2defproc - -//************************************************************** -@@chk_WM_SIZE: - CMP AX, WM_SIZE - JNE @@chk_WM_SYSCOMMAND //@@chk_WM_SHOWWINDOW - - MOV EDX, EDI - MOV EAX, ESI - CALL TControl.CallDefWndProc - PUSH EAX - - {$IFDEF OLD_ALIGN} - {$IFDEF USE_FLAGS} - TEST [ESI].TControl.fFlagsG3, (1 shl G3_IsForm) - {$ELSE} - CMP [ESI].TControl.fIsForm, 0 - {$ENDIF} - JNZ @@doGlobalAlignSelf - MOV EAX, [ESI].TControl.fParent - CALL dword ptr [Global_Align] -@@doGlobalAlignSelf: - {$ENDIF} - MOV EAX, ESI - CALL dword ptr [Global_Align] - JMP @@popeax_exit // fPass2DefProc not needed, CallDefWndProc already called - -//************************************************************** -@@chk_WM_SYSCOMMAND: - CMP AX, WM_SYSCOMMAND - JNE @@chk_WM_SETFOCUS - - MOV EAX, [EDI].TMsg.wParam - {$IFDEF PARANOIA} DB $24, $F0 {$ELSE} AND AL, $F0 {$ENDIF} - CMP AX, SC_MINIMIZE - JNE @@calldef - - MOV EAX, ESI - CALL TControl.IsMainWindow - TEST AL, AL - JZ @@calldef - - CMP ESI, [Applet] - JE @@calldef - - PUSH 0 - PUSH SC_MINIMIZE - PUSH WM_SYSCOMMAND - MOV EAX, [Applet] - PUSH [EAX].TControl.fHandle - CALL PostMessage -@@ret_0: - JMP @@0pass2defproc - -//*************************************************************** -@@chk_WM_SETFOCUS: - CMP AX, WM_SETFOCUS - JNE @@chk_WM_CTLCOLOR //@@chk_WM_SETCURSOR - - MOV EAX, ESI - CALL TControl.DoSetFocus - TEST AL, AL - JZ @@0pass2defproc - - INC [ESI].TControl.fClickDisabled - - MOV EAX, ESI - MOV EDX, EDI - CALL TControl.CallDefWndProc - - DEC [ESI].TControl.fClickDisabled - JMP @@exit - -//************************************************************** -@@chk_WM_CTLCOLOR: - MOV EDX, EAX - SUB DX, WM_CTLCOLORMSGBOX - CMP DX, WM_CTLCOLORSTATIC-WM_CTLCOLORMSGBOX - JA @@chk_WM_COMMAND - - PUSH [EDI].TMsg.lParam - PUSH [EDI].TMsg.wParam - ADD AX, CN_BASE //+WM_CTLCOLORMSGBOX - PUSH EAX - PUSH [EDI].TMsg.lParam - CALL SendMessage - JMP @@pass2defproc - -//************************************************************** -@@chk_WM_COMMAND: - CMP AX, WM_COMMAND - JNE @@chk_WM_KEY - - {$IFDEF USE_PROP} - PUSH offset[ID_SELF] - PUSH [EDI].TMsg.lParam - CALL GetProp - {$ELSE} - PUSH GWL_USERDATA - PUSH [EDI].TMsg.lParam - CALL GetWindowLong - {$ENDIF} - TEST EAX, EAX - JZ @@calldef - - PUSH [EDI].TMsg.lParam - PUSH [EDI].TMsg.wParam - PUSH CM_COMMAND - PUSH [EDI].TMsg.lParam - CALL SendMessage - JMP @@pass2defproc - -//************************************************************** -@@chk_WM_KEY: - MOV EDX, EAX - SUB DX, WM_KEYFIRST - CMP DX, WM_KEYLAST-WM_KEYFIRST - JA @@calldef //@@chk_CM_EXECPROC - {$IFDEF KEY_PREVIEW} - {$IFDEF USE_FLAGS} - TEST [ESI].TControl.fFlagsG4, 1 shl G4_Pushed - {$ELSE} - CMP [ESI].TControl.fKeyPreviewing, 0 - {$ENDIF} - JNE @@in_focus - {$ENDIF KEY_PREVIEW} - - CALL GetFocus - //--- CMP EAX, [ESI].TControl.fFocusHandle - //--- JE @@in_focus - CMP EAX, [ESI].TControl.fHandle - {$IFDEF USE_GRAPHCTLS} - JE @@in_focus - CMP [ESI].fWindowed, 0 - {$ENDIF} - JNE @@0pass2defproc - -@@in_focus: - {$IFDEF KEY_PREVIEW} - {$IFDEF USE_FLAGS} - AND [ESI].TControl.fFlagsG4, not(1 shl G4_Pushed) - {$ELSE} - MOV [ESI].TControl.fKeyPreviewing, 0 - {$ENDIF} - {$ENDIF KEY_PREVIEW} - PUSH EAX - - MOV ECX, ESP - MOV EDX, EDI - MOV EAX, ESI - CALL dword ptr [fGlobalProcKeybd] - TEST AL, AL - JNZ @@to_exit - - MOV ECX, ESP - MOV EDX, EDI - MOV EAX, ESI - CALL [ESI].PP.fWndProcKeybd - TEST AL, AL -@@to_exit: - POP EAX - JNZ @@pass2defproc - - PUSH VK_CONTROL - CALL GetKeyState - XCHG EBX, EAX - PUSH VK_MENU - CALL GetKeyState - OR EAX, EBX - JS @@calldef - - CMP word ptr [EDI].TMsg.message, WM_CHAR - JNE @@to_fGotoControl - - CMP byte ptr [EDI].TMsg.wParam, 9 - JE @@clear_wParam - JMP @@calldef - -@@to_fGotoControl: - MOV EAX, ESI - CALL TControl.ParentForm - TEST EAX, EAX - JZ @@calldef - - MOV ECX, [EAX].PP.fGotoControl - {$IFDEF NIL_EVENTS} - JECXZ @@calldef - {$ENDIF} - - MOV EBX, ECX - CMP [EDI].TMsg.message, WM_KEYDOWN - SETNE CL - CMP [EDI].TMsg.message, WM_SYSKEYDOWN - SETNE CH - AND CL, CH - MOV EDX, [EDI].TMsg.wParam - MOV EAX, ESI - CALL EBX - TEST AL, AL - JZ @@calldef - -@@clear_wParam: - XOR EAX, EAX - MOV [EDI].TMsg.wParam, EAX - JMP @@pass2defproc - -@@calldef: - MOV EAX, ESI - MOV EDX, EDI - CALL TControl.CallDefWndProc - JMP @@exit - -@@0pass2defproc: - XOR EAX, EAX -@@pass2defproc: - PUSH EAX -@@1pass2defproc: - CMP [AppletTerminated], 0 // - JNZ @@popeax_exit // uncommented 25-Oct-2003 - {$IFDEF USE_fNCDestroyed} - CMP [ESI].fNCDestroyed, 0 // - JNZ @@popeax_exit // - {$ENDIF USE_fNCDestroyed} - - MOV ECX, ESP - MOV EAX, ESI - MOV EDX, EDI - CALL EBP -@@popeax_exit: - POP EAX - -@@exit: - {XCHG ESI, EAX - CALL TControl.RefDec - XCHG EAX, ESI} - - POP EBP - POP EDI - POP ESI - POP EBX -@@ret: -end; -{$ENDIF no_USE_MDI} -{$ENDIF no NEW_MODAL} -{$ENDIF no USE_GRAPHCTLS} - -procedure TControl.SetClsStyle( Value: DWord ); -asm //cmd //opd - CMP EDX, [EAX].TControl.fClsStyle - JE @@exit - MOV [EAX].TControl.fClsStyle, EDX - MOV ECX, [EAX].TControl.fHandle - JECXZ @@exit - PUSH EDX - PUSH GCL_STYLE - PUSH ECX - CALL SetClassLong -@@exit: -end; - -procedure TControl.SetStyle( Value: DWord ); -const SWP_FLAGS = SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or - SWP_NOZORDER or SWP_FRAMECHANGED; -asm - CMP EDX, [EAX].fStyle - JZ @@exit - MOV [EAX].fStyle, EDX - MOV ECX, [EAX].fHandle - JECXZ @@exit - - PUSH EAX - - PUSH SWP_FLAGS - XOR EAX, EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH ECX - - PUSH EDX - PUSH GWL_STYLE - PUSH ECX - CALL SetWindowLong - - CALL SetWindowPos - - POP EAX - CALL Invalidate -@@exit: -end; - -procedure TControl.SetExStyle( Value: DWord ); -const SWP_FLAGS = SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or - SWP_NOZORDER or SWP_FRAMECHANGED; -asm - CMP EDX, [EAX].fExStyle - JZ @@exit - MOV [EAX].fExStyle, EDX - MOV ECX, [EAX].fHandle - JECXZ @@exit - - PUSH EAX - - PUSH SWP_FLAGS - XOR EAX, EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH ECX - - PUSH EDX - PUSH GWL_EXSTYLE - PUSH ECX - CALL SetWindowLong - - CALL SetWindowPos - - POP EAX - CALL Invalidate -@@exit: -end; - -procedure TControl.SetCursor( Value: HCursor ); -asm //cmd //opd - PUSH EBX - MOV EBX, EAX - PUSH EDX - LEA EDX, WndProcSetCursor - CALL TControl.AttachProc - POP EDX - - CMP EDX, [EBX].TControl.fCursor - JE @@exit - MOV [EBX].TControl.fCursor, EDX - MOV ECX, [EBX].TControl.fHandle - JECXZ @@exit - TEST EDX, EDX //YS - JE @@exit //YS - MOV ECX, [ScreenCursor] - INC ECX - LOOP @@exit - - PUSH EDX - PUSH EAX - PUSH EAX - PUSH ESP - CALL GetCursorPos - MOV EDX, ESP - MOV ECX, EDX - MOV EAX, EBX - CALL Screen2Client - ADD ESP, -16 - MOV EDX, ESP - MOV EAX, EBX - CALL TControl.ClientRect - MOV EDX, ESP - LEA EAX, [ESP+16] - CALL PointInRect - ADD ESP, 24 - TEST AL, AL - JZ @@fin - CALL Windows.SetCursor - PUSH EAX -@@fin: POP EAX -@@exit: - POP EBX -end; - -procedure TControl.SetIcon( Value: HIcon ); -asm //cmd //opd - CMP EDX, [EAX].TControl.DF.fIcon - JE @@exit - MOV [EAX].TControl.DF.fIcon, EDX - INC EDX - JZ @@1 - DEC EDX -@@1: - PUSH EDX - PUSH 1 //ICON_BIG - PUSH WM_SETICON - PUSH EAX - CALL Perform - TEST EAX, EAX - JZ @@exit - PUSH EAX - CALL DestroyIcon -@@exit: -end; - -procedure TControl.SetMenu( Value: HMenu ); -asm - PUSH EBX - XCHG EBX, EAX - CMP [EBX].fMenu, EDX - JZ @@exit - PUSH EDX - MOV ECX, [EBX].fMenuObj - JECXZ @@no_free_menuctl - {$IFDEF USE_AUTOFREE4CONTROLS} - PUSH EDX - MOV EAX, EBX - CALL TControl.RemoveFromAutoFree - POP EAX - {$ELSE} - XCHG EAX, EDX - {$ENDIF} - CALL TObj.RefDec -@@no_free_menuctl: - MOV ECX, [EBX].fMenu - JECXZ @@no_destroy - PUSH ECX - CALL DestroyMenu -@@no_destroy: - POP EDX - MOV [EBX].fMenu, EDX - MOV ECX, [EBX].fHandle - JECXZ @@exit - PUSH EDX - PUSH ECX - CALL Windows.SetMenu -@@exit: - POP EBX -end; - -procedure TControl.DoAutoSize; -asm - {$IFDEF NIL_EVENTS} - MOV ECX, [EAX].PP.fAutoSize - JECXZ @@exit - PUSH ECX - {$ELSE not NIL_EVENTS} - PUSH [EAX].PP.fAutoSize - {$ENDIF} -@@exit: -end; - -procedure TControl.SetCaption( const Value: KOLString ); -asm - PUSH EBX - XCHG EBX, EAX - LEA EAX, [EBX].fCaption - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrAsg - {$ELSE} - CALL System.@LStrAsg - {$ENDIF} - - MOV ECX, [EBX].fHandle - JECXZ @@0 - PUSH [EBX].TControl.fCaption - PUSH 0 - PUSH WM_SETTEXT - PUSH ECX - {$IFDEF UNICODE_CTRLS} - CALL SendMessageW - {$ELSE} - CALL SendMessage - {$ENDIF} -@@0: - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG1, (1 shl G1_IsStaticControl) - JNZ @@1 - {$ELSE} - MOVZX ECX, byte ptr [EBX].fIsStaticControl - INC ECX - LOOP @@1 - {$ENDIF} - MOV EAX, EBX - CALL Invalidate -@@1: - XCHG EAX, EBX -@@exit: POP EBX - PUSH [EAX].PP.fAutoSize -@@exit_2: -end; - -function TControl.GetVisible: Boolean; -asm - //CALL UpdateWndStyles - {MOV ECX, [EAX].fHandle - JECXZ @@check_fStyle - PUSH EAX - PUSH ECX - CALL IsWindowVisible - TEST EAX, EAX - POP EAX - JMP @@checked // Z if not visible - } -@@check_fStyle: - TEST byte ptr [EAX].fStyle.f3_Style, 1 shl F3_Visible // WS_VISIBLE shr 3 -@@checked: - {$IFDEF USE_FLAGS} - SETNZ AL - {$ELSE} - SETNZ DL - MOV [EAX].fVisible, DL - XCHG EAX, EDX - {$ENDIF} -end; - -function TControl.Get_Visible: Boolean; -asm // // - {$IFDEF USE_FLAGS} - CALL GetVisible - {$ELSE} - MOV ECX, [EAX].fHandle - JECXZ @@ret_fVisible - {$IFDEF USE_FLAGS} - TEST [EAX].fFlagsG3, 1 shl G3_IsControl - {$ELSE} - CMP [EAX].fIsControl, 0 - {$ENDIF} - JNZ @@ret_fVisible - PUSH EAX - PUSH ECX - CALL IsWindowVisible - XCHG EDX, EAX - POP EAX - {$IFDEF USE_FLAGS} - SHL DL, F3_Visible - AND [EAX].TControl.fStyle.f3_Style, not(1 shl F3_Visible) - OR [EAX].TControl.fStyle.f3_Style, DL - {$ELSE} - MOV [EAX].fVisible, DL - {$ENDIF} -@@ret_fVisible: - {$IFDEF USE_FLAGS} - TEST [EAX].fStyle.f3_Style, (1 shl F3_Visible) - SETNZ AL - {$ELSE} - MOVZX EAX, [EAX].fVisible - {$ENDIF} - {$ENDIF USE_FLAGS} -end; - -procedure TControl.Set_Visible( Value: Boolean ); -const wsVisible = $10; -asm - {$IFDEF OLD_ALIGN} - PUSH EBX - PUSH ESI - //MOV ESI, EAX - XCHG ESI, EAX - MOVZX EBX, DL - {CALL Get_Visible - CMP AL, BL - JE @@reset_fCreateHidden} - - MOV AL, byte ptr [ESI].fStyle + 3 - TEST EBX, EBX - JZ @@reset_WS_VISIBLE - {$IFDEF USE_FLAGS} - OR AL, 1 shl F3_Visible - {$ELSE} - OR AL, wsVisible - {$ENDIF} - PUSH SW_SHOW - JMP @@store_Visible -@@reset_WS_VISIBLE: - {$IFDEF USE_FLAGS} - AND AL, not(1 shl F3_Visible) - {$ELSE} - AND AL, not wsVisible - {$ENDIF} - PUSH SW_HIDE - -@@store_Visible: - MOV byte ptr [ESI].fStyle + 3, AL - {$IFDEF USE_FLAGS} - {$ELSE} - MOV [ESI].fVisible, BL - {$ENDIF} - MOV ECX, [ESI].fHandle - JECXZ @@after_showwindow - - PUSH ECX - CALL ShowWindow - PUSH ECX -@@after_showwindow: - POP ECX - - MOV EAX, [ESI].fParent - CALL dword ptr [Global_Align] - -@@chk_align_Self: - TEST EBX, EBX - JZ @@reset_fCreateHidden - MOV EAX, ESI - CALL dword ptr [Global_Align] - - -@@reset_fCreateHidden: - MOV ECX, [ESI].fHandle - JECXZ @@exit - TEST BL, BL - JNZ @@exit - {$IFDEF USE_FLAGS} - AND [ESI], not(1 shl G4_CreateHidden) - {$ELSE} - MOV [ESI].fCreateHidden, BL { +++ } - {$ENDIF} -@@exit: - POP ESI - POP EBX - {$ELSE NEW_ALIGN} - AND byte ptr [EAX].fStyle.f3_Style, not(1 shl F3_Visible) - TEST DL,DL - JZ @@0 - OR byte ptr [EAX].fStyle.f3_Style, (1 shl F3_Visible) -@@0: - {$IFDEF USE_FLAGS} - {$ELSE} - MOV [EAX].fVisible, DL - {$ENDIF USE_FLAGS} - MOV ECX, [EAX].fHandle - JECXZ @@exit - PUSH EAX - JZ @@1 - CALL dword ptr [Global_Align] - POP EAX - PUSH SW_SHOW - PUSH [EAX].fHandle - CALL ShowWindow -@@exit: - RET -@@1: - {$IFDEF USE_FLAGS} - AND [EAX].fFlagsG4, not(1 shl G4_CreateHidden) - {$ELSE} - MOV [EAX].fCreateHidden, DL // = 0 - {$ENDIF} - PUSH SW_HIDE - PUSH ECX - CALL ShowWindow - POP EAX - CALL dword ptr [Global_Align] - {$ENDIF} -end; - -procedure TControl.SetVisible( Value: Boolean ); -asm - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG4, 1 shl G4_CreateVisible - {$ELSE} - MOV [EAX].TControl.fCreateVisible, 1 - {$ENDIF} - CALL TControl.Set_Visible -end; - -function TControl.GetBoundsRect: TRect; -asm - PUSH ESI - PUSH EDI - LEA ESI, [EAX].fBoundsRect - MOV EDI, EDX - - PUSH EDX - - MOVSD - MOVSD - MOVSD - MOVSD - - POP EDI - - XCHG ESI, EAX - MOV ECX, [ESI].fHandle - JECXZ @@exit - - PUSH EDI - PUSH ECX - CALL GetWindowRect - - {$IFDEF USE_FLAGS} - TEST [ESI].fFlagsG3, (1 shl G3_IsControl) or (1 shl G3_IsMDIChild) - {$ELSE} - MOV AL, [ESI].fIsControl - OR AL, [ESI].fIsMDIChild - {$ENDIF} - JZ @@storeBounds - -@@chk_Parent: - MOV EAX, ESI - CALL TControl.GetParentWindow - - TEST EAX, EAX - JZ @@exit - - XOR EDX, EDX - PUSH EDX - PUSH EDX - PUSH ESP - PUSH EAX - CALL Windows.ClientToScreen - - POP EAX - NEG EAX - POP ECX - NEG ECX - PUSH ECX - PUSH EAX - PUSH EDI - CALL OffsetRect - -@@storeBounds: - XCHG ESI, EDI - LEA EDI, [EDI].fBoundsRect - MOVSD - MOVSD - MOVSD - MOVSD - -@@exit: - POP EDI - POP ESI -end; - -procedure HelpGetBoundsRect; -asm - POP ECX - ADD ESP, - size_TRect - MOV EDX, ESP - PUSH ECX - PUSH EAX - CALL TControl.GetBoundsRect - POP EAX -end; - -procedure TControl.SetBoundsRect( const Value: TRect ); -const swp_flags = SWP_NOZORDER or SWP_NOACTIVATE; -asm - PUSH EDI - MOV EDI, EAX - - PUSH ESI - MOV ESI, EDX - - CALL HelpGetBoundsRect - - MOV EAX, ESI - MOV EDX, ESP - CALL RectsEqual - TEST AL, AL - JNZ @@exit - - POP EDX // left - POP ECX // top - POP EAX // right - PUSH EAX - PUSH ECX - PUSH EDX - - SUB EAX, EDX // EAX = width - CMP EDX, [ESI].TRect.Left - {$IFDEF USE_FLAGS} - {$ELSE} - MOV DL, 0 - {$ENDIF} - JNE @@11 -@@1: CMP ECX, [ESI].TRect.Top - JE @@2 -@@11: - {$IFDEF USE_FLAGS} - OR [EDI].fFlagsG2, (1 shl G2_ChangedPos) - {$ELSE} - OR DL, 2 - OR [EDI].fChangedPosSz, DL - {$ENDIF} -@@2: - PUSH EAX // W saved - - MOV EAX, [EDI].fBoundsRect.Bottom - SUB EAX, ECX - PUSH EAX // H saved - - PUSH EDI // @Self saved - {$IFDEF USE_GRAPHCTLS} - {$IFDEF USE_FLAGS} - TEST [EDI].fFlagsG6, 1 shl G6_GraphicCtl - JZ @@invalid1 - {$ELSE} - CMP [EDI].fWindowed, 0 - JNZ @@invalid1 - {$ENDIF} - MOV EAX, EDI - CALL TControl.InvalidateNonWindowed -@@invalid1: - {$ENDIF} - - LEA EDI, [EDI].fBoundsRect - MOVSD - MOVSD - MOVSD - MOVSD - - MOV ESI, EDI - POP EDI // @ Self restored - - MOV ECX, [EDI].fHandle - JECXZ @@fin - - STD - PUSH swp_flags - - LODSD - LODSD - XCHG EDX, EAX // EDX = bottom - LODSD - XCHG ECX, EAX // ECX = right - LODSD - SUB EDX, EAX // EAX = bottom - top - PUSH EDX // push HEIGHT - XCHG EDX, EAX // EDX = top - LODSD // EAX = left - CLD - - SUB ECX, EAX - PUSH ECX // push WIDTH - - PUSH EDX // push TOP - PUSH EAX // push LEFT - PUSH 0 - - PUSH [EDI].fHandle - CALL SetWindowPos - -@@fin: - POP EDX // H restored - POP EAX // W restored - - {$IFDEF USE_FLAGS} - TEST [EDI].fFlagsG1, (1 shl G1_SizeRedraw) - {$ELSE} - CMP [EDI].fSizeRedraw, 0 - {$ENDIF USE_FLAGS} - JE @@exit -@@invalid2: - XCHG EAX, EDI - CALL Invalidate - -@@exit: - ADD ESP, size_TRect - POP ESI - POP EDI -end; - -procedure TControl.SetWindowState( Value: TWindowState ); -asm //cmd //opd - PUSH EAX - PUSH EDX - CALL TControl.GetWindowState - POP EDX - CMP AL, DL - POP EAX - JE @@exit - MOV [EAX].TControl.DF.fWindowState, DL - MOV ECX, [EAX].TControl.fHandle - JECXZ @@exit - XCHG EAX, EDX - CBW - CWDE - MOV AL, byte ptr [WindowStateShowCommands+EAX] - PUSH EAX - PUSH ECX - CALL ShowWindow -@@exit: -end; - -procedure TControl.Show; -asm - PUSH EBX - MOV EBX, EAX - CALL CreateWindow - MOV DL, 1 - MOV EAX, EBX - CALL SetVisible - PUSH [EBX].fHandle - CALL SetForegroundWindow - XCHG EAX, EBX - CALL DoSetFocus - POP EBX -end; - -function TControl.Client2Screen( const P: TPoint ): TPoint; -asm - PUSH ESI - PUSH EDI - - MOV ESI, EDX - MOV EDI, ECX - - MOVSD - MOVSD - - PUSH ECX - MOV ECX, [EAX].fHandle - JECXZ @@exit - - PUSH ECX - CALL ClientToScreen - PUSH ECX - -@@exit: POP ECX - POP EDI - POP ESI -end; - -function TControl.Screen2Client( const P: TPoint ): TPoint; -asm - PUSH ESI - PUSH EDI - - MOV ESI, EDX - MOV EDI, ECX - - MOVSD - MOVSD - - PUSH ECX - MOV ECX, [EAX].fHandle - JECXZ @@exit - - PUSH ECX - CALL ScreenToClient - PUSH ECX - -@@exit: POP ECX - POP EDI - POP ESI -end; - -function TControl.ClientRect: TRect; -asm - PUSH ESI - XCHG ESI, EAX - PUSH EDX - PUSH EDX // prepare 'dest' for GetClientRect - - LEA EAX, [ESI].fBoundsRect - XOR ECX, ECX - MOV CL, size_TRect - - CALL System.Move - - MOV EAX, ESI - CALL TControl.GetWindowHandle - - XCHG ECX, EAX - JECXZ @@exit - - PUSH ECX // prepare 'handle' for GetClientRect - CALL GetClientRect - - PUSH EDX - -@@exit: POP EDX - POP EDX // EDX = @Result - LEA ESI, [ESI].fClientTop - LODSB - MOVSX EAX, AL - ADD [EDX].TRect.Top, EAX - LODSB - MOVSX EAX, AL - SUB [EDX].TRect.Bottom, EAX - LODSB - MOVSX EAX, AL - ADD [EDX].TRect.Left, EAX - LODSB - MOVSX EAX, AL - SUB [EDX].TRect.Right, EAX - POP ESI -end; - -procedure TControl.Invalidate; -asm - {$IFDEF USE_GRAPHCTLS} - PUSH dword ptr [EAX].TControl.PP.fDoInvalidate - {$ELSE} - MOV ECX, [EAX].fHandle - JECXZ @@exit - PUSH $FF - PUSH 0 - PUSH ECX - CALL Windows.InvalidateRect -@@exit: - {$ENDIF} -end; - -{$IFDEF USE_GRAPHCTLS} -procedure InvalidateWindowed( Sender: PObj ); -asm - MOV ECX, [EAX].TControl.fHandle - JECXZ @@exit - PUSH $FF - PUSH 0 - PUSH ECX - CALL Windows.InvalidateRect -@@exit: -end; -{$ENDIF USE_GRAPHCTLS} - -function TControl.GetIcon: HIcon; -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, [EBX].DF.fIcon - INC EAX - JZ @@exit - DEC EAX - JNZ @@exit - - MOV ECX, [Applet] - JECXZ @@load - CMP ECX, EBX - JZ @@load - - XCHG EAX, ECX - CALL TControl.GetIcon - TEST EAX, EAX - JZ @@exit - - XOR EDX, EDX - PUSH EDX - PUSH EDX - PUSH EDX - INC EDX // IMAGE_ICON = 1 - PUSH EDX - PUSH EAX - CALL CopyImage - JMP @@store_fIcon - -@@main_icon: - {$IFDEF NUMERIC_APPICON} {$DEFINE CUSTOM_APPICON} {$ENDIF} - {$IFDEF CUSTOM_APPICON} - {$I CustomAppIconRsrcName_ASM.inc} // create such file with DB 'your icon rsrc name' / DD youriconnumber - {$ELSE} - {$IFDEF UNICODE_CTRLS} - DB 'M',0,'A',0,'I',0,'N',0,'I',0,'C',0,'O',0,'N',0,0 - {$ELSE} - DB 'MAINICON' - {$ENDIF} - {$ENDIF} - DB 0 - -@@load: - {$IFDEF NUMERIC_APPICON} - PUSH DWORD [@@main_icon] - {$ELSE} - PUSH offset @@main_icon - {$ENDIF} - PUSH [hInstance] - CALL LoadIcon -@@store_fIcon: - MOV [EBX].DF.fIcon, EAX -@@exit: - POP EBX -end; - -function TControl.CallDefWndProc(var Msg: TMsg): Integer; -asm - PUSH [EDX].TMsg.lParam - PUSH [EDX].TMsg.wParam - PUSH [EDX].TMsg.message - - MOV ECX, [EAX].fDefWndProc - JECXZ @@defwindowproc - - PUSH [EAX].fHandle - PUSH ECX - CALL CallWindowProc - RET - -@@defwindowproc: - PUSH [EDX].TMsg.hwnd - {$IFDEF UNICODE_CTRLS} - CALL DefWindowProcW - {$ELSE} - CALL DefWindowProc - {$ENDIF} -end; - -function TControl.GetWindowState: TWindowState; -asm //cmd //opd - PUSH EBX - PUSH ESI - XCHG ESI, EAX - MOVZX EBX, [ESI].TControl.DF.fWindowState - MOV ECX, [ESI].TControl.fHandle - JECXZ @@ret_EBX - MOV BL, 2 - MOV ESI, ECX - PUSH ESI - CALL IsZoomed - TEST EAX, EAX - JNZ @@ret_EBX - DEC EBX - PUSH ESI - CALL IsIconic - TEST EAX, EAX - JNZ @@ret_EBX - DEC EBX -@@ret_EBX: - XCHG EAX, EBX - POP ESI - POP EBX -end; - -function TControl.DoSetFocus: Boolean; -asm - PUSH ESI - MOV ESI, EAX - - CALL GetEnabled - (* - {$IFDEF USE_FLAGS} - MOV DL, byte ptr [ESI].TControl.fStyle.f2_Style - // F2_Tabstop = 0 ! - {$ELSE} - MOV DL, byte ptr [ESI+2].TControl.fStyle - OR DL, [ESI].TControl.fTabstop - {$ENDIF USE_FLAGS} - AND AL, DL - *) - TEST AL, AL - JZ @@exit - - INC [ESI].TControl.fClickDisabled - PUSH [ESI].TControl.fHandle - CALL SetFocus - DEC [ESI].TControl.fClickDisabled - MOV AL, 1 -@@exit: - POP ESI -end; - -function TControl.GetEnabled: Boolean; -asm - MOV ECX, [EAX].fHandle - JECXZ @@get_field - - PUSH ECX - CALL IsWindowEnabled - RET - -@@get_field: - TEST byte ptr [EAX].fStyle + 3, 8 //WS_DISABLED shr 3 - SETZ AL -end; - -function TControl.IsMainWindow: Boolean; -asm XCHG ECX, EAX - XOR EDX, EDX - MOV EAX, [Applet] - TEST EAX, EAX - JNZ @@0 - {$IFDEF USE_FLAGS} - TEST [ECX].fFlagsG3, 1 shl G3_IsControl - {$ELSE} - CMP [ECX].fIsControl, AL - {$ENDIF} - JMP @@3 -@@0: CMP [appbuttonUsed], DL - JZ @@2 -@@1: PUSH ECX - CALL TControl.GetMembers - POP ECX -@@2: CMP ECX, EAX -@@3: SETZ AL -end; - -procedure TControl.SetParent( Value: PControl ); -asm - PUSH EBX - PUSH EDI - XCHG EBX, EAX - MOV EDI, EDX - MOV ECX, [EBX].fParent - CMP EDI, ECX - JE @@exit - - JECXZ @@1 - {$IFDEF USE_GRAPHCTLS} - PUSH ECX - MOV EAX, EBX - CALL TControl.Invalidate - POP ECX - {$ENDIF} - PUSH ECX - - MOV EAX, [ECX].fChildren - MOV EDX, EBX - CALL TList.Remove - - POP EAX - {$IFNDEF USE_AUTOFREE4CONTROL} - PUSH EAX - MOV EDX, EBX - CALL TObj.RemoveFromAutoFree - POP EAX - {$ENDIF} - - {$IFNDEF SMALLEST_CODE} - MOV ECX, [EAX].PP.fNotifyChild - {$IFDEF NIL_EVENTS} - JECXZ @@1 - {$ENDIF} - XOR EDX, EDX - CALL ECX - {$ENDIF} -@@1: - MOV [EBX].fParent, EDI - TEST EDI, EDI - JZ @@exit - - MOV EAX, [EDI].fChildren - MOV EDX, EBX - CALL TList.Add - - {$IFDEF USE_AUTOFREE4CHILDREN} - MOV EAX, EDI - MOV EDX, EBX - CALL TControl.Add2AutoFree - {$ENDIF} - - {$IFNDEF INPACKAGE} - MOV ECX, [EBX].fHandle - JECXZ @@2 - MOV EAX, EDI - CALL TControl.GetWindowHandle - PUSH EAX - PUSH [EBX].fHandle - CALL Windows.SetParent -@@2: - {$ENDIF} - - {$IFNDEF SMALLEST_CODE} - MOV ECX, [EDI].PP.fNotifyChild - {$IFDEF NIL_EVENTS} - JECXZ @@3 - {$ENDIF} - MOV EAX, EDI - MOV EDX, EBX - CALL ECX -@@3: - MOV ECX, [EBX].PP.fNotifyChild - {$IFDEF NIL_EVENTS} - JECXZ @@4 - {$ENDIF} - MOV EAX, EDI - MOV EDX, EBX - CALL ECX -@@4: {$ENDIF} - - {$IFNDEF USE_GRAPHCTLS} - XCHG EAX, EBX - CALL TControl.Invalidate - {$ENDIF} -@@exit: - POP EDI - POP EBX -end; - -constructor TControl.CreateParented(AParent: PControl); -asm //cmd //opd - PUSH EAX - MOV EDX, ECX - MOV ECX, [EAX] - CALL dword ptr [ECX+8] - POP EAX -end; - -function TControl.GetLeft: Integer; -asm - CALL HelpGetBoundsRect - POP EAX - - POP ECX - POP ECX - POP ECX -end; - -procedure TControl.SetLeft( Value: Integer ); -asm - PUSH EDI - - PUSH EDX - CALL HelpGetBoundsRect - POP EDX // EDX = Left - POP ECX // ECX = Top - POP EDI // EDI = Right - - SUB EDI, EDX // EDI = width - MOV EDX, [ESP+4] // EDX = Left' - ADD EDI, EDX // EDI = Right' - - PUSH EDI - PUSH ECX - PUSH EDX - MOV EDX, ESP - - CALL SetBoundsRect - ADD ESP, size_TRect + 4 - - POP EDI - -end; - -function TControl.GetTop: Integer; -asm - CALL HelpGetBoundsRect - POP EDX - POP EAX - POP EDX - POP EDX -end; - -procedure TControl.SetTop( Value: Integer ); -asm - PUSH ESI - PUSH EDI - - PUSH EDX - CALL HelpGetBoundsRect - POP EDX // EDX = Left - POP ECX // ECX = Top - POP EDI // EDI = Right - POP ESI // ESI = Bottom - - SUB ESI, ECX // ESI = Height' - POP ECX // ECX = Top' - ADD ESI, ECX // ESI = Bottom' - - PUSH ESI - PUSH EDI - PUSH ECX - PUSH EDX - MOV EDX, ESP - - CALL SetBoundsRect - ADD ESP, size_TRect - - POP EDI - POP ESI -end; - -function TControl.GetWidth: Integer; -asm - CALL HelpGetBoundsRect - POP EDX - POP ECX - POP EAX - SUB EAX, EDX - POP ECX -end; - -procedure TControl.SetWidth( Value: Integer ); -asm - PUSH EDX - - CALL HelpGetBoundsRect - POP EDX - PUSH EDX - ADD EDX, [ESP].size_TRect - MOV [ESP].TRect.Right, EDX - - MOV EDX, ESP - CALL SetBoundsRect - - ADD ESP, size_TRect + 4 -end; - -function TControl.GetHeight: Integer; -asm - CALL HelpGetBoundsRect - POP ECX - POP EDX // EDX = top - POP ECX - POP EAX // EAX = bottom - SUB EAX, EDX // result = height -end; - -procedure TControl.SetHeight( Value: Integer ); -asm - PUSH EDX - - CALL HelpGetBoundsRect - MOV EDX, [ESP].TRect.Top - ADD EDX, [ESP].size_TRect - MOV [ESP].TRect.Bottom, EDX - - MOV EDX, ESP - CALL SetBoundsRect - - ADD ESP, size_TRect + 4 -end; - -function TControl.GetPosition: TPoint; -asm - PUSH EDX - CALL HelpGetBoundsRect - POP EAX // EAX = left - POP ECX // ECX = top - POP EDX - POP EDX - POP EDX // EDX = @Result - MOV [EDX], EAX - MOV [EDX+4], ECX -end; - -procedure TControl.Set_Position( Value: TPoint ); -asm - PUSH ESI - PUSH EDI - - PUSH EAX - PUSH EDX - CALL HelpGetBoundsRect - POP EDX // left - POP EAX // top - POP ECX // right - SUB ECX, EDX // ECX = width - POP EDX // bottom - SUB EDX, EAX // EDX = height - POP EAX // EAX = @Value - POP ESI // ESI = @Self - - MOV EDI, [EAX+4] // top' - ADD EDX, EDI - PUSH EDX // bottom' - - MOV EAX, [EAX] // left' - ADD ECX, EAX - PUSH ECX // right' - - PUSH EDI // top' - PUSH EAX // left' - - MOV EAX, ESI - MOV EDX, ESP - CALL SetBoundsRect - - ADD ESP, size_TRect - - POP EDI - POP ESI -end; - -procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect ); -asm - PUSH EDI - - PUSH EDI - MOV EDI, ESP - - PUSH ECX - PUSH EDX - - MOV EAX, [EAX].TControl.fColor - CALL Color2RGB - PUSH EAX - CALL CreateSolidBrush - STOSD - MOV EDI, EAX - CALL windows.FillRect - PUSH EDI - CALL DeleteObject - POP EDI -end; - -procedure TControl.SetCtlColor( Value: TColor ); -asm - PUSH EBX - MOV EBX, EAX - - {$IFNDEF INPACKAGE} - PUSH EDX - - CALL GetWindowHandle - XCHG ECX, EAX - - POP EDX - {$ELSE} - MOV ECX, [EBX].fHandle - {$ENDIF} - - JECXZ @@1 - - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EBX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aSetBkColor - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aSetBkColor - {$ENDIF} - JECXZ @@1 - - PUSH EDX - - XCHG EAX, EDX - PUSH ECX - CALL Color2RGB - POP ECX - - PUSH EAX // Color2RGB( Value ) - PUSH 0 // 0 - PUSH ECX // fCommandActions.aSetBkColor - PUSH EBX // @ Self - CALL TControl.Perform - - POP EDX - -@@1: - CMP EDX, [EBX].fColor - JZ @@exit - - MOV [EBX].fColor, EDX - - XOR ECX, ECX - XCHG ECX, [EBX].fTmpBrush - JECXZ @@setbrushcolor - - PUSH EDX - PUSH ECX - CALL DeleteObject - POP EDX - -@@setbrushcolor: - MOV ECX, [EBX].fBrush - JECXZ @@invldte - - XCHG EAX, ECX - MOV ECX, EDX - //MOV EDX, go_Color - XOR EDX, EDX - CALL TGraphicTool.SetInt - -@@invldte: - XCHG EAX, EBX - CALL TControl.Invalidate -@@exit: - POP EBX -end; - -function TControl.GetParentWnd( NeedHandle: Boolean ): HWnd; -asm - XCHG EDX, EAX - TEST AL, AL - MOV EAX, [EDX].fParentWnd - MOV ECX, [EDX].fParent - JECXZ @@exit - - PUSH ECX - JZ @@load_handle - - XCHG EAX, ECX - CALL GetWindowHandle - -@@load_handle: - POP EAX - MOV EAX, [EAX].fHandle -@@exit: -end; - -function TControl.ProcessMessage: Boolean; -const size_TMsg = sizeof( TMsg ); -asm - PUSH EBX - XCHG EBX, EAX - - ADD ESP, -size_TMsg-4 - - MOV EDX, ESP - PUSH 1 - XOR ECX, ECX - PUSH ECX - PUSH ECX - PUSH ECX - PUSH EDX - CALL PeekMessage - - TEST EAX, EAX - JZ @@exit - - CMP WORD PTR [ESP].TMsg.message, WM_QUIT - JNE @@tran_disp - OR [AppletTerminated], DL - {$IFDEF PROVIDE_EXITCODE} - MOV EDX, [ESP].TMsg.wParam - MOV [ExitCode], EDX - {$ENDIF PROVIDE_EXITCODE} - JMP @@fin - -@@tran_disp: - MOV ECX, [EBX].PP.fExMsgProc - {$IFDEF NIL_EVENTS} - JECXZ @@do_tran_disp - {$ENDIF} - XCHG EAX, EBX - MOV EDX, ESP - CALL ECX - TEST AL, AL - JNZ @@fin - -@@do_tran_disp: - MOV EAX, ESP - PUSH EAX - PUSH EAX - CALL TranslateMessage - CALL DispatchMessage - -@@fin: - CMP word ptr [ESP].TMsg.message, 0 - SETNZ AL - -@@exit: ADD ESP, size_TMsg+4 - POP EBX -end; - -procedure TControl.ProcessMessages; -asm -@@loo: PUSH EAX - CALL ProcessMessage - DEC AL - POP EAX - JZ @@loo -end; - -function WndProcForm(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -const szPaintStruct = sizeof(TPaintStruct); -asm //cmd //opd - {$IFDEF ENDSESSION_HALT} - CMP word ptr [EDX].TMsg.message, WM_ENDSESSION - JNE @@chk_WM_SETFOCUS - - CMP [EDX].TMsg.wParam, 0 - JZ @@ret_false - - CALL TObj.RefDec - XOR EAX, EAX - MOV [AppletRunning], AL - XCHG EAX, [Applet] - INC [AppletTerminated] - - CALL TObj.RefDec - CALL System.@Halt0 - {$ENDIF ENDSESSION_HALT} - -@@chk_WM_SETFOCUS: - CMP word ptr [EDX].TMsg.message, WM_SETFOCUS - JNE @@ret_false - - PUSH EBX - PUSH ESI - XOR EBX, EBX - INC EBX - XCHG ESI, EAX - {$IFDEF NEW_MODAL} - MOV ECX, [ESI].TControl.DF.fModalForm - JECXZ @@no_fix_modal_setfocus - PUSH [ECX].TControl.fHandle - CALL SetFocus -@@no_fix_modal_setfocus: - MOV ECX, [ESI].TControl.DF.FCurrentControl - JECXZ @@setFocuswhenCreateWindow - {$IFDEF USE_FLAGS} - TEST [ECX].TControl.fFlagsG3, (1 shl G3_IsForm) - SETNZ DL - TEST [ESI].TControl.fFlagsG3, (1 shl G3_IsApplet) - SETNZ DH - XOR DL, DH - JNZ @@1 - {$ELSE} - MOV DL, [ECX].TControl.fIsForm - XOR DL, [ESI].TControl.FIsApplet - JNZ @@1 - {$ENDIF} - {$ELSE not NEW_MODAL} - MOV ECX, [ESI].TControl.DF.fCurrentControl - JECXZ @@0 - {$ENDIF} -@@setFocuswhenCreateWindow: - JECXZ @@1 //+++++++++++++++ - //INC EBX - XCHG EAX, ECX - - // or CreateForm? - PUSH EAX - CALL CallTControlCreateWindow - TEST AL, AL - POP EAX - JZ @@1 - - PUSH [EAX].TControl.fHandle - CALL SetFocus - INC EBX -@@0: DEC EBX -@@1: MOV ECX, [Applet] - JECXZ @@ret_EBX - CMP ECX, ESI - JE @@ret_EBX - MOV [ECX].TControl.DF.FCurrentControl, ESI -@@ret_EBX: - XCHG EAX, EBX - POP ESI - POP EBX - RET - -@@ret_false: - XOR EAX, EAX -end; - -function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean; -asm - MOV EDX, EBX - MOV EAX, [EBX].TControl.fParent - TEST EAX, EAX - JZ @@exit - PUSH EAX - CALL TControl.ChildIndex - TEST EAX, EAX - XCHG EDX, EAX - POP EAX - JZ @@exit - DEC EDX - CALL TControl.GetMembers - - POP ECX // retaddr - ADD ESP, -size_TRect - MOV EDX, ESP - PUSH ECX - CALL TControl.GetBoundsRect - STC // return CARRY -@@exit: -end; - -function TControl.PlaceUnder: PControl; -asm - PUSH EBX - XCHG EBX, EAX - CALL GetPrevCtrlBoundsRect - JNC @@exit - POP EDX // EDX = Left - MOV EAX, EBX - CALL TControl.SetLeft - - POP EDX - POP EDX - POP EDX // EDX = Bottom - - MOV EAX, [EBX].fParent - MOVSX ECX, [EAX].fMargin - ADD EDX, ECX - - MOV EAX, EBX - CALL TControl.SetTop -@@exit: - XCHG EAX, EBX - POP EBX -end; - -function TControl.PlaceDown: PControl; -asm - PUSH EBX - XCHG EBX, EAX - CALL GetPrevCtrlBoundsRect - JNC @@exit - POP EDX - POP EDX - POP EDX - POP EDX // EDX = Bottom - - MOV EAX, [EBX].fParent - MOVSX ECX, [EAX].fMargin - ADD EDX, ECX - - MOV EAX, EBX - CALL TControl.SetTop -@@exit: - XCHG EAX, EBX - POP EBX -end; - -function TControl.PlaceRight: PControl; -asm - PUSH EBX - XCHG EBX, EAX - CALL GetPrevCtrlBoundsRect - JNC @@exit - POP EDX - POP EDX // EDX = Top - MOV EAX, EBX - CALL TControl.SetTop - POP EDX // EDX = Right - - MOV EAX, [EBX].fParent - MOVSX ECX, [EAX].fMargin - ADD EDX, ECX - - POP ECX - MOV EAX, EBX - CALL TControl.SetLeft -@@exit: - XCHG EAX, EBX - POP EBX -end; - -function TControl.SetSize(W, H: Integer): PControl; -asm - PUSH EBX - XCHG EBX, EAX - SUB ESP, 16 - XCHG EAX, EDX - MOV EDX, ESP - PUSH ECX // save H - PUSH EAX // save W - MOV EAX, EBX - CALL GetBoundsRect - POP ECX // pop W - JECXZ @@nochg_W - ADD ECX, [ESP+4].TRect.Left - MOV [ESP+4].TRect.Right, ECX -@@nochg_W: - POP ECX // pop H - JECXZ @@nochg_H - ADD ECX, [ESP].TRect.Top - MOV [ESP].TRect.Bottom, ECX -@@nochg_H: - MOV EAX, EBX - MOV EDX, ESP - CALL TControl.SetBoundsRect - ADD ESP, 16 - XCHG EAX, EBX - POP EBX -end; - -function TControl.AlignLeft(P: PControl): PControl; -asm - PUSH EAX - MOV EAX, EDX - CALL TControl.GetLeft - MOV EDX, EAX - POP EAX - PUSH EAX - CALL TControl.SetLeft - POP EAX -end; - -function TControl.AlignTop(P: PControl): PControl; -asm - PUSH EAX - MOV EAX, EDX - CALL TControl.GetTop - MOV EDX, EAX - POP EAX - PUSH EAX - CALL TControl.SetTop - POP EAX -end; - -function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -asm //cmd //opd - PUSH EBX - XCHG EBX, EAX - PUSH ESI - PUSH EDI - MOV EDI, EDX - MOV EDX, [EDI].TMsg.message - - SUB DX, CN_CTLCOLORMSGBOX - CMP DX, CN_CTLCOLORSTATIC-CN_CTLCOLORMSGBOX - JA @@chk_CM_COMMAND -@@2: - PUSH ECX - MOV EAX, [EBX].TControl.fTextColor - CALL Color2RGB - XCHG ESI, EAX - PUSH ESI - PUSH [EDI].TMsg.wParam - CALL SetTextColor - {$IFDEF USE_FLAGS} - TEST [EBX].TControl.fFlagsG2, (1 shl G2_Transparent) - {$ELSE} - CMP [EBX].TControl.fTransparent, 0 - {$ENDIF} - JZ @@opaque - - PUSH Windows.TRANSPARENT - PUSH [EDI].TMsg.wParam - CALL SetBkMode - PUSH NULL_BRUSH - CALL GetStockObject - JMP @@ret_rslt - -@@opaque: - MOV EAX, [EBX].TControl.fColor - CALL Color2RGB - XCHG ESI, EAX - PUSH OPAQUE - PUSH [EDI].TMsg.wParam - CALL SetBkMode - PUSH ESI - PUSH [EDI].TMsg.wParam - CALL SetBkColor - - MOV EAX, EBX - CALL Global_GetCtlBrushHandle -@@ret_rslt: - XCHG ECX, EAX -@@tmpbrushready: - POP EAX - MOV [EAX], ECX -@@ret_true: - MOV AL, 1 - - JMP @@ret_EAX - -@@chk_CM_COMMAND: - CMP word ptr [EDI].TMsg.message, CM_COMMAND - JNE @@chk_WM_SETFOCUS - - PUSH ECX - - MOVZX ECX, word ptr [EDI].TMsg.wParam+2 - {$IFDEF COMMANDACTIONS_OBJ} - MOV ESI, [EBX].TControl.fCommandActions - CMP CX, [ESI].TCommandActionsObj.aClick - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aClick - {$ENDIF} - JNE @@chk_aEnter - - CMP [EBX].TControl.fClickDisabled, 0 - JG @@calldef - MOV EAX, EBX - MOV DL, 1 - CALL TControl.SetFocused - MOV EAX, EBX - CALL TControl.DoClick - JMP @@calldef - -@@chk_aEnter: - {$IFDEF COMMANDACTIONS_OBJ} - MOV EAX, [EBX].TControl.fCommandActions - CMP CX, [EAX].TCommandActionsObj.aEnter - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aEnter - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - LEA EAX, [EAX].TEvents.fOnEnter - {$ELSE} - LEA EAX, [EBX].TControl.EV.fOnEnter - {$ENDIF} - JE @@goEvent - //LEA EAX, [EBX].TControl.EV.fOnLeave - ADD EAX, 8 - {$IFDEF COMMANDACTIONS_OBJ} - CMP CX, [ESI].TCommandActionsObj.aLeave - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aLeave - {$ENDIF} - JE @@goEvent - //LEA EAX, [EBX].TControl.EV.fOnChangeCtl - SUB EAX, 16 - {$IFDEF COMMANDACTIONS_OBJ} - CMP CX, [ESI].TCommandActionsObj.aChange - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aChange - {$ENDIF} - JNE @@chk_aSelChange -@@goEvent: - MOV ECX, [EAX].TMethod.Code - {$IFDEF NIL_EVENTS} - JECXZ @@2calldef - {$ENDIF} - MOV EAX, [EAX].TMethod.Data - MOV EDX, EBX - CALL ECX -@@2calldef: - JMP @@calldef - -@@chk_aSelChange: - {$IFDEF COMMANDACTIONS_OBJ} - CMP CX, [ESI].TCommandActionsObj.aSelChange - {$ELSE} - CMP CX, [EBX].TControl.fCommandActions.aSelChange - {$ENDIF} - JNE @@chk_WM_SETFOCUS_1 - MOV EAX, EBX - CALL TControl.DoSelChange - -@@calldef: - XCHG EAX, EBX - MOV EDX, EDI - CALL TControl.CallDefWndProc - JMP @@ret_rslt - -@@chk_WM_SETFOCUS_1: - POP ECX -@@chk_WM_SETFOCUS: - XOR EAX, EAX - CMP word ptr [EDI].TMsg.message, WM_SETFOCUS - JNE @@chk_WM_KEYDOWN - - MOV [ECX], EAX - MOV EAX, EBX - CALL TControl.ParentForm - TEST EAX, EAX - JZ @@ret_true - - PUSH EAX - MOV ECX, [EAX].TControl.DF.FCurrentControl - JECXZ @@a1 - CMP ECX, EBX - JZ @@a1 - XCHG EAX, ECX - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TControl.EV - MOV ECX, [EAX].TEvents.fLeave.TMethod.Code - {$ELSE} - MOV ECX, [EAX].TControl.EV.fLeave.TMethod.Code - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@a1 - {$ENDIF} - XCHG EDX, EAX - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EDX].TEvents.fLeave.TMethod.Data - {$ELSE} - MOV EAX, [EDX].TControl.EV.fLeave.TMethod.Data - {$ENDIF} - CALL ECX -@@a1: POP EAX - - MOV [EAX].TControl.DF.FCurrentControl, EBX - XOR EAX, EAX - - PUSH EDX -@@2ret_EAX: - POP EDX - -@@chk_WM_KEYDOWN: - {$IFDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS} - CMP word ptr [EDI].TMsg.message, WM_KEYDOWN - {$IFDEF KEY_PREVIEW} - JNE @@chk_other_KEYMSGS - {$ELSE} - JNE @@ret0 - {$ENDIF} - - {$IFDEF KEY_PREVIEW} - MOV EAX, EBX - CALL TControl.ParentForm - CMP EAX, EBX - JE @@kp_end - - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fFlagsG6, 1 shl G6_KeyPreview - {$ELSE} - CMP [EAX].TControl.fKeyPreview, 0 - {$ENDIF} - JZ @@kp_end - - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG4, 1 shl G4_Pushed - {$ELSE} - MOV [EAX].TControl.fKeyPreviewing, 1 - {$ENDIF} - INC [EAX].TControl.DF.fKeyPreviewCount - PUSH EAX - - PUSH [EDI].TMsg.lParam - PUSH [EDI].TMsg.wParam - PUSH WM_KEYDOWN - PUSH EAX - CALL TControl.Perform - POP EAX - DEC [EAX].TControl.DF.fKeyPreviewCount -@@kp_end: - {$ENDIF} - - {$IFDEF ESC_CLOSE_DIALOGS} - MOV EAX, EBX - CALL TControl.ParentForm - TEST [EAX].TControl.fExStyle, WS_EX_DLGMODALFRAME - JZ @@ecd_end - CMP [EDI].TMsg.wParam, 27 - JNE @@ecd_end - PUSH 0 - PUSH 0 - PUSH WM_CLOSE - PUSH EAX - CALL TControl.Perform -@@ecd_end: - {$ENDIF} - -@@ret0: - XOR EAX, EAX - {$IFDEF KEY_PREVIEW} - JMP @@ret_EAX -@@chk_other_KEYMSGS: - MOVZX EAX, word ptr [EDI].TMsg.message - SUB AX, WM_KEYDOWN - JB @@ret0 - CMP AX, 6 - JA @@ret0 - // all WM_KEYUP=$101, WM_CHAR=$102, WM_DEADCHAR=$103, WM_SYSKEYDOWN=$104, - // WM_SYSKEYUP=$105, WM_SYSCHAR=$106, WM_SYSDEADCHAR=$107 - MOV EAX, EBX - CALL TControl.ParentForm - CMP EAX, EBX - JE @@ret0 - - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fFlagsG6, 1 shl G6_KeyPreview - {$ELSE} - CMP [EAX].fKeyPreview, 0 - {$ENDIF} - JZ @@ret0 - - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG4, 1 shl G4_Pushed - {$ELSE} - MOV [EAX].TControl.fKeyPreviewing, 1 - {$ENDIF} - INC [EAX].TControl.DF.fKeyPreviewCount - PUSH EAX - PUSH [EDI].TMsg.lParam - PUSH [EDI].TMsg.wParam - PUSH [EDI].TMsg.message - PUSH EAX - CALL TControl.Perform - POP EAX - DEC [EAX].TControl.DF.fKeyPreviewCount - XOR EAX, EAX - {$ENDIF KEY_PREVIEW} - {$ENDIF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS} - -@@ret_EAX: - POP EDI - POP ESI - POP EBX -end; - -procedure TControl.DoClick; -asm - PUSH EAX - CALL [EAX].PP.fControlClick - POP EDX - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EDX].TControl.EV - MOV ECX, [EAX].TEvents.fOnClick.TMethod.Code - {$ELSE} - MOV ECX, [EDX].EV.fOnClick.TMethod.Code - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@exit - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnClick.TMethod.Data - {$ELSE} - MOV EAX, [EDX].EV.fOnClick.TMethod.Data - {$ENDIF} - CALL ECX -@@exit: -end; - -function TControl.ParentForm: PControl; -asm -@@1: {$IFDEF USE_FLAGS} - TEST [EAX].fFlagsG3, 1 shl G3_IsControl - {$ELSE} - CMP [EAX].fIsControl, 0 - {$ENDIF} - JZ @@exit - MOV EAX, [EAX].fParent - TEST EAX, EAX - JNZ @@1 -@@exit: -end; - -procedure TControl.SetProgressColor(const Value: TColor); -asm - PUSH EDX - PUSH EAX - MOV EAX, EDX - CALL Color2RGB - POP EDX - PUSH EDX - PUSH EAX - PUSH 0 - PUSH PBM_SETBARCOLOR - PUSH EDX - CALL Perform - TEST EAX, EAX - POP EAX - POP EDX - JZ @@exit - MOV [EAX].fTextColor, EDX -@@exit: -end; - -function TControl.GetFont: PGraphicTool; -asm - MOV ECX, [EAX].FFont - INC ECX - LOOP @@exit - PUSH EAX - CALL NewFont - {$IFDEF USE_AUTOFREE4CONTROLS} - POP EDX - PUSH EDX - PUSH EAX - XCHG eax, edx - CALL TObj.Add2AutoFree - POP EAX - {$ENDIF} - POP EDX - MOV [EDX].FFont, EAX - MOV ECX, [EDX].fTextColor - MOV [EAX].TGraphicTool.fData.Color, ECX - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Code, offset[FontChanged] - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Data, EDX - RET -@@exit: XCHG EAX, ECX -end; - -function TControl.GetBrush: PGraphicTool; -asm - MOV ECX, [EAX].FBrush - INC ECX - LOOP @@exit - PUSH EAX - CALL NewBrush - POP EDX // @ Self - MOV [EDX].FBrush, EAX - MOV ECX, [EDX].fColor - MOV [EAX].TGraphicTool.fData.Color, ECX - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Code, offset[BrushChanged] - MOV [EAX].TGraphicTool.fOnGTChange.TMethod.Data, EDX - {$IFDEF USE_AUTOFREE4CONTROLS} - PUSH EAX - XCHG EAX, EDX - CALL TControl.Add2AutoFree - POP ECX - {$ENDIF} -@@exit: XCHG EAX, ECX -end; - -procedure TControl.FontChanged(Sender: PGraphicTool); -asm - MOV ECX, [EDX].TGraphicTool.fData.Color - MOV [EAX].fTextColor, ECX - PUSH EAX - CALL [ApplyFont2Wnd_Proc] - POP EAX - CALL Invalidate -end; - -procedure TControl.BrushChanged(Sender: PGraphicTool); -asm - MOV ECX, [EDX].TGraphicTool.fData.Color - MOV [EAX].fColor, ECX - XOR ECX, ECX - XCHG ECX, [EAX].fTmpBrush - JECXZ @@inv - PUSH EAX - PUSH ECX - CALL DeleteObject - POP EAX -@@inv: CALL Invalidate -end; - -procedure DoApplyFont2Wnd( _Self: PControl ); -asm - PUSH EBX - XCHG EBX, EAX - - MOV ECX, [EBX].TControl.fFont - JECXZ @@exit - XCHG EAX, ECX - - MOV ECX, [EBX].TControl.fHandle - JECXZ @@0 - - MOV EDX, [EAX].TGraphicTool.fData.Color - MOV [EBX].TControl.fTextColor, EDX - - PUSH $FFFF - CALL TGraphicTool.GetHandle - PUSH EAX - PUSH WM_SETFONT - PUSH EBX - CALL TControl.Perform - -@@0: - XOR ECX, ECX - XCHG ECX, [EBX].TControl.fCanvas - JECXZ @@1 - - XCHG EAX, ECX - CALL TObj.RefDec -@@1: - XCHG EAX, EBX - CALL TControl.DoAutoSize -@@exit: - POP EBX -end; - -function TControl.ResizeParent: PControl; -asm - LEA EDX, [TControl.ResizeParentRight] - PUSH EDX - CALL EDX - CALL TControl.ResizeParentBottom -end; - -function TControl.ResizeParentBottom: PControl; -asm - PUSH EAX - PUSH EBX - MOV EBX, [EAX].fParent - TEST EBX, EBX - JZ @@exit - - MOV EDX, [EAX].fBoundsRect.Bottom - MOVSX ECX, [EBX].fMargin - ADD EDX, ECX - - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG2, (1 shl G2_ChangedH) - JZ @@1 - {$ELSE} - TEST [EBX].fChangedPosSz, 20h - JZ @@1 - {$ENDIF} - - PUSH EDX - MOV EAX, EBX - CALL GetClientHeight - POP EDX - - CMP EDX, EAX - JE @@exit -@@1: - MOV EAX, EBX - CALL TControl.SetClientHeight - {$IFDEF USE_FLAGS} - OR [EBX].fFlagsG2, (1 shl G2_ChangedH) - {$ELSE} - OR [EBX].fChangedPosSz, 20h - {$ENDIF} -@@exit: - POP EBX - POP EAX -end; - -function TControl.ResizeParentRight: PControl; -asm - PUSH EAX - PUSH EBX - MOV EBX, [EAX].fParent - TEST EBX, EBX - JZ @@exit - - MOV EDX, [EAX].fBoundsRect.Right - MOVSX ECX, [EBX].fMargin - ADD EDX, ECX - - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG2, (1 shl G2_ChangedW) - {$ELSE} - TEST [EBX].fChangedPosSz, 10h - {$ENDIF} - JZ @@1 - - PUSH EDX - MOV EAX, EBX - CALL GetClientWidth - POP EDX - - CMP EDX, EAX - JLE @@exit -@@1: - MOV EAX, EBX - CALL TControl.SetClientWidth - {$IFDEF USE_FLAGS} - OR [EBX].fFlagsG2, (1 shl G2_ChangedW) - {$ELSE} - OR [EBX].fChangedPosSz, 10h - {$ENDIF} -@@exit: - POP EBX - POP EAX -end; - -function TControl.GetClientHeight: Integer; -asm - ADD ESP, -size_TRect - MOV EDX, ESP - CALL TControl.ClientRect - POP EDX - POP ECX // Top - POP EDX - POP EAX // Bottom - SUB EAX, ECX // Result = Bottom - Top -end; - -function TControl.GetClientWidth: Integer; -asm - ADD ESP, -size_TRect - MOV EDX, ESP - CALL TControl.ClientRect - POP ECX // Left - POP EDX - POP EAX // Right - SUB EAX, ECX // Result = Right - Left - POP EDX -end; - -procedure TControl.SetClientHeight(const Value: Integer); -asm - PUSH EBX - PUSH EDX - - MOV EBX, EAX - CALL TControl.GetClientHeight - PUSH EAX - MOV EAX, EBX - CALL TControl.GetHeight // EAX = Height - - POP EDX // EDX = ClientHeight - SUB EAX, EDX // EAX = Delta - POP EDX // EDX = Value - ADD EDX, EAX // EDX = Value + Delta - XCHG EAX, EBX // EAX = @Self - CALL TControl.SetHeight - POP EBX -end; - -procedure TControl.SetClientWidth(const Value: Integer); -asm - PUSH EBX - PUSH EDX - - MOV EBX, EAX - CALL TControl.GetClientWidth - PUSH EAX - MOV EAX, EBX - CALL TControl.GetWidth // EAX = Width - - POP EDX // EDX = ClientWidth - SUB EAX, EDX // EAX = Width - ClientWidth - POP EDX // EDX = Value - ADD EDX, EAX // EDX = Value + Delta - XCHG EAX, EBX // EAX = @Self - CALL TControl.SetWidth - POP EBX -end; - -function TControl.CenterOnParent: PControl; -asm - PUSHAD - - XCHG ESI, EAX - MOV ECX, [ESI].fParent - JECXZ @@1 - {$IFDEF USE_FLAGS} - TEST [ESI].fFlagsG3, 1 shl G3_IsControl - {$ELSE} - CMP [ESI].fIsControl, 0 - {$ENDIF} - JNZ @@2 - -@@1: - PUSH SM_CYSCREEN - CALL GetSystemMetrics - PUSH EAX - - PUSH SM_CXSCREEN - CALL GetSystemMetrics - PUSH EAX - - PUSH 0 - PUSH 0 // ESP -> Rect( 0, 0, CX, CY ) - - JMP @@3 - -@@2: ADD ESP, -size_TRect - MOV EDX, ESP - XCHG EAX, ECX - CALL TControl.ClientRect - // ESP -> ClientRect -@@3: MOV EAX, ESI - CALL GetWindowHandle - - MOV EAX, ESI - CALL GetWidth - - POP EDX // left - ADD EAX, EDX // + width - - POP EDI // top - POP EDX // right - - SUB EDX, EAX - SAR EDX, 1 - - MOV EAX, ESI - CALL SetLeft - - MOV EAX, ESI - CALL GetHeight - - ADD EAX, EDI // height + top - - POP EDX // bottom - SUB EDX, EAX - SAR EDX, 1 - - XCHG EAX, ESI - CALL SetTop - - POPAD -end; - -function TControl.GetHasBorder: Boolean; -const style_mask = WS_BORDER or WS_THICKFRAME or WS_DLGFRAME; -asm - CALL UpdateWndStyles - MOV EDX, [EAX].fStyle - AND EDX, style_mask - SETNZ DL - MOV EAX, [EAX].fExStyle - AND EAX, WS_EX_CLIENTEDGE - SETNZ AL - OR AL, DL -end; - -function TControl.GetHasCaption: Boolean; -const style_mask1 = (WS_POPUP or WS_DLGFRAME) shr 16; - style_mask2 = WS_CAPTION shr 16; -asm - CALL UpdateWndStyles - MOV ECX, [EAX].fStyle + 2 - MOV EDX, ECX - MOV AL, 1 - AND DX, style_mask1 - JZ @@1 - AND CX, style_mask2 - JNZ @@1 - XOR EAX, EAX -@@1: -end; - -procedure TControl.SetHasCaption(const Value: Boolean); -const style_mask = not (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION - or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU); - exstyle_mask = not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME - or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE); -asm - PUSH EAX - PUSH EDX - - CALL GetHasCaption - POP ECX - CMP AL, CL - - POP EAX - JZ @@exit // Value = HasCaption - - MOV EDX, [EAX].fStyle - DEC CL - JNZ @@1 // if not Value -> @@1 - - AND EDX, not WS_POPUP - OR EDX, WS_CAPTION - JMP @@set_style - -@@1: - {$IFDEF USE_FLAGS} - TEST [EAX].fFlagsG3, 1 shl G3_IsControl - {$ELSE} - CMP [EAX].fIsControl, 0 - {$ENDIF} - JNZ @@2 // if fIsControl -> @@2 - - AND EDX, not (WS_CAPTION or WS_SYSMENU) - OR EDX, WS_POPUP - JMP @@3 - -@@2: - AND EDX, not WS_CAPTION - OR EDX, WS_DLGFRAME - -@@3: - PUSH EDX - - MOV EDX, [EAX].fExStyle - OR EDX, WS_EX_DLGMODALFRAME - - PUSH EAX - CALL SetExStyle - POP EAX - - POP EDX -@@set_style: - CALL SetStyle -@@exit: -end; - -function TControl.GetCanResize: Boolean; -asm - {$IFDEF USE_FLAGS} - TEST [EAX].fFlagsG1, (1 shl G1_PreventResize) - SETZ AL - {$ELSE} - MOV AL, [EAX].fPreventResize - {$IFDEF PARANOIA} DB $34,$01 {$ELSE} XOR AL, 1 {$ENDIF} - {$ENDIF USE_FLAGS} -end; - -procedure TControl.SetCanResize( const Value: Boolean ); -asm - PUSH EBX - MOV EBX, EAX - - CALL GetCanResize - CMP AL, DL - - JZ @@exit // Value = CanResize - {$IFDEF USE_FLAGS} - // AL:bit0 = can resize - SHL AL, G1_PreventResize - AND [EBX].fFlagsG1, not (1 shl G1_PreventResize) - OR [EBX].fFlagsG1, AL - {$ELSE} - MOV [EBX].fPreventResize, AL - {$ENDIF USE_FLAGS} - {$IFDEF CANRESIZE_THICKFRAME} - TEST DL, DL - - MOV EDX, [EBX].fStyle - JZ @@set_thick - - OR EDX, WS_THICKFRAME - JMP @@set_style - -@@set_thick: - AND EDX, not WS_THICKFRAME - -@@set_style: - MOV EAX, EBX - CALL SetStyle - {$ENDIF CANRESIZE_THICKFRAME} - - {$IFDEF FIX_WIDTH_HEIGHT} - MOV EAX, EBX - CALL GetWindowHandle - - MOV EAX, EBX - CALL GetWidth - MOV [EBX].FFixWidth, EAX - - MOV EAX, EBX - CALL GetHeight - MOV [EBX].FFixHeight, EAX - {$ENDIF FIX_WIDTH_HEIGHT} - - XCHG EAX, EBX - MOV EDX, offset[WndProcCanResize] - CALL TControl.AttachProc -@@exit: - POP EBX -end; - -function TControl.GetStayOnTop: Boolean; -asm - CALL UpdateWndStyles - TEST byte ptr [EAX].fExStyle, WS_EX_TOPMOST - SETNZ AL -end; - -procedure TControl.SetStayOnTop(const Value: Boolean); -asm - PUSH EAX - PUSH EDX - - CALL GetStayOnTop - POP ECX - MOVZX ECX, CL - CMP AL, CL - - POP EAX - JZ @@exit // Value = StayOnTop - - MOV EDX, [EAX].fHandle - TEST EDX, EDX - JZ @@1 - - PUSH SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE - XOR EAX, EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EAX - DEC ECX - DEC ECX - PUSH ECX - - PUSH EDX - CALL SetWindowPos - RET - -@@1: - JECXZ @@1and - - OR byte ptr [EAX].fExStyle, WS_EX_TOPMOST - RET - -@@1and: AND byte ptr [EAX].fExStyle, not WS_EX_TOPMOST - -@@exit: -end; - -function TControl.UpdateWndStyles: PControl; -asm - MOV ECX, [EAX].fHandle - JECXZ @@exit - - PUSH EBX - - XCHG EBX, EAX - PUSH GCL_STYLE - PUSH ECX - - PUSH GWL_EXSTYLE - PUSH ECX - - PUSH GWL_STYLE - PUSH ECX - - CALL GetWindowLong - MOV [EBX].fStyle, EAX - - CALL GetWindowLong - MOV [EBX].fExStyle, EAX - - CALL GetClassLong - MOV [EBX].fClsStyle, EAX - XCHG EAX, EBX - POP EBX -@@exit: -end; - -function TControl.GetChecked: Boolean; -asm - TEST [EAX].DF.fBitBtnOptions, 8 //1 shl Ord(bboFixed) - JZ @@1 - {$IFDEF USE_FLAGS} - TEST [EAX].fFlagsG4, 1 shl G4_Checked - SETNZ AL - {$ELSE} - MOV AL, [EAX].fChecked - {$ENDIF} - RET -@@1: - PUSH 0 - PUSH 0 - PUSH BM_GETCHECK - PUSH EAX - CALL Perform -@@exit: -end; - -procedure TControl.Set_Checked(const Value: Boolean); -asm - TEST [EAX].DF.fBitBtnOptions, 8 //1 shl Ord(bboFixed) - JZ @@1 - {$IFDEF USE_FLAGS} - SHL DL, G4_Checked - AND [EAX].fFlagsG4, not(1 shl G4_Checked) - OR [EAX].fFlagsG4, DL - {$ELSE} - MOV [EAX].fChecked, DL - {$ENDIF} - JMP Invalidate -@@1: - PUSH 0 - MOVZX EDX, DL - PUSH EDX - PUSH BM_SETCHECK - PUSH EAX - Call Perform -end; - -function TControl.SetRadioChecked: PControl; -asm - {$IFDEF USE_FLAGS} - PUSH DWORD PTR[EAX].fStyle - PUSH EAX - AND [EAX].fStyle.f2_Style, not(1 shl F2_Tabstop) - CALL DoClick - POP EAX - POP DWORD PTR[EAX].fStyle - {$ELSE} - PUSH EAX - PUSH DWORD PTR[EAX].fTabStop - MOV [EAX].fTabStop, 0 -@@1: - CALL DoClick - POP EDX - POP EAX - MOV [EAX].fTabStop, DL - {$ENDIF USE_FLAGS} -end; - -function TControl.GetSelStart: Integer; -asm - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aGetSelRange - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aGetSelRange - {$ENDIF} - JECXZ @@exit - XOR EDX, EDX - PUSH EDX // space for Result - PUSH EDX // 0 - LEA EDX, [ESP+4] - PUSH EDX // @ Result - PUSH ECX // EM_GETSEL - PUSH EAX - CALL Perform - POP ECX // Result -@@exit: - XCHG EAX, ECX -end; - -function TControl.GetSelLength: Integer; -asm - XOR EDX, EDX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, word ptr[ECX].TCommandActionsObj.aGetSelCount - {$ELSE} - MOVZX ECX, word ptr[EAX].fCommandActions.aGetSelCount - {$ENDIF} - JECXZ @@ret_ecx - - CMP CX, EM_GETSEL - JNZ @@1 - PUSH EDX - PUSH EDX - MOV EDX, ESP - PUSH EDX - ADD EDX, 4 - PUSH EDX - PUSH ECX - PUSH EAX - CALL Perform - POP ECX - POP EDX - SUB ECX, EDX -@@ret_ecx: - XCHG EAX, ECX - RET - -@@1: // LB_GETSELCOUNT, LVM_GETSELECTEDCOUNT - PUSH EDX // 0 - PUSH EDX // 0 - PUSH ECX // aGetSelCount - PUSH EAX // Handle - CALL Perform -@@fin_EAX: -end; - -procedure TControl.SetSelLength(const Value: Integer); -asm - PUSH EBP - MOV EBP, ESP - PUSH EAX - PUSH EDX - CALL GetSelStart - POP ECX - POP EDX - ADD ECX, EAX - PUSH ECX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EDX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aSetSelRange - {$ELSE} - MOVZX ECX, [EDX].fCommandActions.aSetSelRange - {$ENDIF} - JECXZ @@check_ex - PUSH EAX - JMP @@perform - -@@check_ex: - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EDX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aExSetSelRange - {$ELSE} - MOVZX ECX, [EDX].fCommandActions.aExSetSelRange - {$ENDIF} - JECXZ @@exit - PUSH EAX - PUSH ESP - PUSH 0 -@@perform: - PUSH ECX - PUSH EDX - CALL Perform -@@exit: MOV ESP, EBP - POP EBP -end; - -function TControl.GetItemsCount: Integer; -asm - PUSH 0 - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aGetCount - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aGetCount - {$ENDIF} - JECXZ @@ret_0 - PUSH 0 - PUSH ECX - PUSH EAX - CALL Perform - PUSH EAX - -@@ret_0: - POP EAX -end; - -procedure HelpConvertItem2Pos; -asm - JECXZ @@exit - PUSH 0 - PUSH EDX - PUSH ECX - PUSH EAX - CALL TControl.Perform - {XOR EDX, EDX - TEST EAX, EAX - JL @@exit - RET} - XCHG EDX, EAX -@@exit: - XCHG EAX, EDX -end; - -function TControl.Item2Pos(ItemIdx: Integer): DWORD; -asm - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.bItem2Pos - {$ELSE} - MOVZX ECX, BYTE PTR [EAX].fCommandActions.bItem2Pos - {$ENDIF} - JMP HelpConvertItem2Pos -end; - -function TControl.Pos2Item(Pos: Integer): DWORD; -asm - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.bPos2Item - {$ELSE} - MOVZX ECX, BYTE PTR [EAX].fCommandActions.bPos2Item - {$ENDIF} - JMP HelpConvertItem2Pos -end; - -procedure TControl.Delete(Idx: Integer); -asm - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aDeleteItem - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aDeleteItem - {$ENDIF} - JECXZ @@exit - - PUSH 0 - PUSH EDX - PUSH ECX - PUSH EAX - CALL Perform -@@exit: -end; - -function TControl.GetItemSelected(ItemIdx: Integer): Boolean; -asm - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aGetSelected - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aGetSelected - {$ENDIF} - JECXZ @@check_range - - PUSH 1 - CMP CL, CB_GETCURSEL and $FF - JNZ @@1 - MOV [ESP], EDX -@@1: - PUSH LVIS_SELECTED // 2 - PUSH EDX - PUSH ECX - PUSH EAX - CALL Perform - POP EDX - CMP EAX, EDX - SETZ AL - RET - -@@check_range: - PUSH EBX - PUSH ESI - XCHG ESI, EDX - MOV EBX, EAX - - CALL GetSelStart - XCHG EBX, EAX - CALL GetSelLength - - SUB ESI, EBX - JL @@ret_false - - CMP EAX, ESI -@@ret_false: - SETGE AL - POP ESI - POP EBX -end; - -procedure TControl.SetItemSelected(ItemIdx: Integer; const Value: Boolean); -asm - PUSH EDX - PUSH ECX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aSetSelected - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aSetSelected - {$ENDIF} - JECXZ @@chk_aSetCurrent - -@@0: - PUSH ECX - PUSH EAX - CALL Perform - RET - -@@chk_aSetCurrent: - POP ECX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aSetCurrent - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aSetCurrent - {$ENDIF} - JECXZ @@chk_aSetSelRange - - POP EDX - PUSH 0 - JMP @@3 - -@@chk_aSetSelRange: - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aSetSelRange - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aSetSelRange - {$ENDIF} - JECXZ @@chk_aExSetSelRange -@@3: - PUSH EDX - JMP @@0 - -@@else: MOV [EAX].FCurIndex, EDX - CALL TControl.Invalidate - JMP @@exit - -@@chk_aExSetSelRange: - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aExSetSelRange - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aExSetSelRange - {$ENDIF} - JECXZ @@else - - PUSH EDX - PUSH ESP - PUSH 0 - PUSH ECX - PUSH EAX - CALL Perform - POP ECX - -@@exit: - POP ECX -end; - -procedure TControl.SetCtl3D(const Value: Boolean); -asm - AND [EAX].fCtl3D_child, not 1 - OR [EAX].fCtl3D_child, DL - - PUSHAD - CALL UpdateWndStyles - POPAD - - MOV ECX, [EAX].fExStyle - DEC DL - MOV EDX, [EAX].fStyle - JNZ @@1 - AND EDX, not WS_BORDER - OR CH, WS_EX_CLIENTEDGE shr 8 - JMP @@2 -@@1: - OR EDX, WS_BORDER - AND CH, not(WS_EX_CLIENTEDGE shr 8) -@@2: - PUSH ECX - PUSH EAX - CALL SetStyle - POP EAX - POP EDX - JMP SetExStyle -@@exit: -end; - -function TControl.Shift(dX, dY: Integer): PControl; -asm - PUSHAD - ADD EDX, [EAX].fBoundsRect.TRect.Left - CALL SetLeft - POPAD - PUSH EAX - MOV EDX, [EAX].fBoundsRect.TRect.Top - ADD EDX, ECX - CALL SetTop - POP EAX -end; - -function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean; -const tk_Tab = 1; - tk_LR = 2; - tk_UD = 4; - tk_PuPd= 8; -asm - PUSH EBX - XCHG EBX, EAX - PUSH ESI - MOV ESI, offset[@@data] - XOR EAX, EAX -@@loop: - LODSW - TEST EAX, EAX - JZ @@exit_false - - CMP AL, DL - JNZ @@loop - - TEST [EBX].TControl.fLookTabKeys, AH - JZ @@exit_false - - TEST CL, CL - JNZ @@exit_true - - MOV DH, AH - PUSH EDX - XCHG EAX, EBX - CALL TControl.ParentForm - XCHG ESI, EAX - POP EAX - - CMP AL, 9 - JNZ @@test_flag - - PUSH EAX - PUSH VK_SHIFT - CALL GetKeyState - POP EDX - - AND AH, $80 - OR AH, DH -@@test_flag: - {XOR EDX, EDX - INC EDX - ADD AH, AH - JNC @@tabul_1 - NEG EDX -@@tabul_1:} //AH<80 //AH>=80 - ADD AH, AH // // - SBB EDX, EDX //EDX=0 //EDX=-1 - ADD EDX, EDX // 0 // -2 - INC EDX // 1 // -1 - - XCHG EAX, ESI - CALL Tabulate2Next -@@exit_true: - MOV AL, 1 - POP ESI - POP EBX - RET - -@@data: - DB VK_TAB, tk_Tab, VK_LEFT, tk_LR or $80, VK_RIGHT, tk_LR - DB VK_UP, tk_UD or $80, VK_DOWN, tk_UD - DB VK_PRIOR, tk_PuPd or $80, VK_NEXT, tk_PuPd, 0, 0 - -@@exit_false: - XOR EAX, EAX - POP ESI - POP EBX - RET -end; - -function TControl.Tabulate: PControl; -asm - PUSH EAX - CALL ParentForm - TEST EAX, EAX - JZ @@exit - MOV [EAX].PP.fGotoControl, offset[Tabulate2Control] -@@exit: POP EAX -end; - -function TControl.TabulateEx: PControl; -asm - PUSH EAX - CALL ParentForm - TEST EAX, EAX - JZ @@exit - MOV [EAX].PP.fGotoControl, offset[Tabulate2ControlEx] -@@exit: POP EAX -end; - -function TControl.GetCurIndex: Integer; -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, [EBX].fCurIndex - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EBX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aGetCurrent - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aGetCurrent - {$ENDIF} - JECXZ @@exit - XOR EAX, EAX - CDQ - CMP CX, LVM_GETNEXTITEM - JNE @@0 - INC EAX - INC EAX - JMP @@1 -@@0: - CMP CL, EM_LINEINDEX and $FF - JNZ @@2 -@@1: - DEC EDX -@@2: - PUSH EAX - PUSH EDX - PUSH ECX - PUSH EBX - CALL Perform - -@@exit: POP EBX -end; - -{procedure TControl.SetCurIndex(const Value: Integer); -asm - MOVZX ECX, [EAX].fCommandActions.aSetCurrent - JECXZ @@set_item_sel - PUSHAD - PUSH 0 - PUSH EDX - PUSH ECX - PUSH EAX - CALL Perform - POPAD - CMP CX, TCM_SETCURSEL - JNE @@exit - PUSH TCN_SELCHANGE - PUSH EAX // idfrom doesn't matter - PUSH [EAX].fHandle - PUSH ESP - PUSH 0 - PUSH WM_NOTIFY - PUSH EAX - CALL Perform - POP ECX - POP ECX - POP ECX -@@exit: - RET -@@set_item_sel: - INC ECX - CALL SetItemSelected -end;} - -procedure TControl.SetCurIndex(const Value: Integer); // fix av -asm - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aSetCurrent - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aSetCurrent - {$ENDIF} - JECXZ @@set_item_sel - PUSH ECX //+aSetCurrent - PUSH EAX //+self - PUSH 0 - PUSH EDX - PUSH ECX - PUSH EAX - CALL Perform - POP EDX //+self - POP ECX //+aSetCurrent - CMP CX, TCM_SETCURSEL - JNE @@exit - MOV [EDX].fCurIndex,EAX - PUSH TCN_SELCHANGE // NMHdr.code - PUSH EDX // NMHdr.idfrom - doesn't matter - PUSH [EDX].fHandle // NMHdr.hwndFrom - PUSH ESP - PUSH 0 - PUSH WM_NOTIFY - PUSH EDX - CALL Perform - ADD ESP,12 //NMHdr destroy -@@exit: - RET -@@set_item_sel: - INC ECX - CALL SetItemSelected -end; - -function TControl.GetTextAlign: TTextAlign; -asm - PUSH EAX - CALL UpdateWndStyles - MOV ECX, [EAX].fStyle - {$IFDEF COMMANDACTIONS_OBJ} - MOV EDX, [EAX].fCommandActions - MOV EDX, dword ptr [EDX].TCommandActionsObj.aTextAlignRight - {$ELSE} - MOV EDX, dword ptr [EAX].fCommandActions.aTextAlignRight - {$ENDIF} - XOR EAX, EAX - AND DX, CX - JNZ @@ret_1 - SHR EDX, 16 - AND ECX, EDX - JNZ @@ret_2 - POP EAX - MOVZX EAX, [EAX].fTextAlign - RET - -@@ret_2:INC EAX -@@ret_1:INC EAX -@@ret_0:POP ECX -end; - -procedure TControl.SetTextAlign(const Value: TTextAlign); -asm - {$IFDEF COMMANDACTIONS_OBJ} - PUSH EBX - {$ENDIF} - MOV [EAX].fTextAlign, DL - XOR ECX, ECX - {$IFDEF COMMANDACTIONS_OBJ} - MOV EBX, [EAX].fCommandActions - MOV CX, [EBX].TCommandActionsObj.aTextAlignLeft - OR CX, [EBX].TCommandActionsObj.aTextAlignCenter - OR CX, [EBX].TCommandActionsObj.aTextAlignRight - {$ELSE} - MOV CX, [EAX].fCommandActions.aTextAlignLeft - OR CX, [EAX].fCommandActions.aTextAlignCenter - OR CX, [EAX].fCommandActions.aTextAlignRight - {$ENDIF} - NOT ECX - AND ECX, [EAX].fStyle - - AND EDX, 3 - {$IFDEF COMMANDACTIONS_OBJ} - OR CX, [EBX + EDX * 2].TCommandActionsObj.aTextAlignLeft - MOV DL, BYTE PTR [EBX].TCommandActionsObj.bTextAlignMask - {$ELSE} - OR CX, [EAX + EDX * 2].fCommandActions.aTextAlignLeft - MOV DL, BYTE PTR [EAX].fCommandActions.bTextAlignMask - {$ENDIF} - - NOT EDX - AND EDX, ECX - CALL SetStyle - {$IFDEF COMMANDACTIONS_OBJ} - POP EBX - {$ENDIF} -end; - -function TControl.GetVerticalAlign: TVerticalAlign; -asm - PUSH EAX - CALL UpdateWndStyles - {$IFDEF COMMANDACTIONS_OBJ} - MOV EDX, [EAX].fCommandActions - MOV EDX, dword ptr [EDX].TCommandActionsObj.bVertAlignCenter - {$ELSE} - MOV EDX, dword ptr [EAX].fCommandActions.bVertAlignCenter - {$ENDIF} - MOV ECX, [EAX].fStyle - XOR EAX, EAX - MOV DH, DL - AND DL, CH - JZ @@1 - CMP DL, DH - JE @@ret_0 -@@1: SHR EDX, 16 - MOV DH, DL - AND DL, CH - JZ @@2 - CMP DL, DH - JE @@ret_2 -@@2: POP EAX - MOVZX EAX, [EAX].fVerticalAlign - RET -@@ret_2:INC EAX -@@ret_1:INC EAX -@@ret_0:POP ECX -end; - -procedure TControl.SetVerticalAlign(const Value: TVerticalAlign); -asm - MOVZX EDX, DL - MOV [EAX].fVerticalAlign, DL - - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, byte ptr [ECX+EDX].TCommandActionsObj.bVertAlignTop - {$ELSE} - MOVZX ECX, byte ptr [EAX+EDX].fCommandActions.bVertAlignTop - {$ENDIF} - SHL ECX, 8 - - MOV EDX, [EAX].fStyle - AND DH, $F3 - OR EDX, ECX - - CALL SetStyle -end; - -function TControl.Dc2Canvas( Sender: PCanvas ): HDC; -asm - MOV ECX, [EAX].fPaintDC - JECXZ @@chk_fHandle - - PUSH ECX - XCHG EAX, EDX // EAX <= Sender - MOV EDX, ECX // EDX <= fPaintDC - PUSH EAX - CALL TCanvas.SetHandle - POP EAX - MOV [EAX].TCanvas.fIsPaintDC, 1 - POP ECX -@@ret_ECX: - XCHG EAX, ECX - RET - -@@chk_fHandle: - MOV ECX, [EDX].TCanvas.fHandle - INC ECX - LOOP @@ret_ECX - - CALL GetWindowHandle - PUSH EAX - CALL GetDC -end; - -function TControl.GetCanvas: PCanvas; -asm - PUSH EBX - PUSH ESI - {$IFDEF SAFE_CODE} - MOV EBX, EAX - CALL CreateWindow - {$ELSE} - XCHG EBX, EAX - {$ENDIF} - - MOV ESI, [EBX].fCanvas - TEST ESI, ESI - JNZ @@exit - - XOR EAX, EAX - CALL NewCanvas - MOV [EBX].fCanvas, EAX - MOV [EAX].TCanvas.fOwnerControl, EBX - MOV [EAX].TCanvas.fOnGetHandle.TMethod.Code, offset[ DC2Canvas ] - MOV [EAX].TCanvas.fOnGetHandle.TMethod.Data, EBX - XCHG ESI, EAX - - MOV ECX, [EBX].fFont - JECXZ @@exit - - MOV EAX, [ESI].TCanvas.fFont - MOV EDX, ECX - CALL TGraphicTool.Assign - MOV [ESI].TCanvas.fFont, EAX - - MOV ECX, [EBX].fBrush - JECXZ @@exit - - MOV EAX, [ESI].TCanvas.fBrush - MOV EDX, ECX - CALL TGraphicTool.Assign - MOV [ESI].TCanvas.fBrush, EAX - -@@exit: XCHG EAX, ESI - POP ESI - POP EBX -end; - -procedure TControl.SetDoubleBuffered(const Value: Boolean); -asm - {$IFDEF USE_FLAGS} - TEST [EAX].fFlagsG1, 1 shl G1_CanNotDoubleBuf - JNZ @@exit - {$ELSE} - CMP [EAX].fCannotDoubleBuf, 0 - JNZ @@exit - {$ENDIF} - {$IFDEF USE_FLAGS} - SHL DL, G2_DoubleBuffered - AND [EAX].fFlagsG2, not(1 shl G2_DoubleBuffered) - OR [EAX].fFlagsG2, DL - {$ELSE} - MOV [EAX].fDoubleBuffered, DL - {$ENDIF} - MOV EDX, offset[WndProcTransparent] - CALL TControl.AttachProc - {$IFnDEF SMALLEST_CODE} - LEA EAX, [TransparentAttachProcExtension] - MOV [Global_AttachProcExtension], EAX - {$ENDIF} -@@exit: -end; - -procedure TControl.SetTransparent(const Value: Boolean); -asm - MOV ECX, [EAX].fParent - JECXZ @@exit - {$IFDEF USE_FLAGS} - AND [EAX].fFlagsG2, not(1 shl G2_Transparent) - TEST DL, DL - JZ @@exit - OR [EAX].fFlagsG2, 1 shl G2_Transparent - {$ELSE} - MOV [EAX].fTransparent, DL - TEST DL, DL - JZ @@exit - {$ENDIF} - -{$IFDEF GRAPHCTL_XPSTYLES} - CMP AppTheming, FALSE - JNE @@not_th - {$IFDEF USE_FLAGS} - OR [EAX].fFlagsG3, G3_ClassicTransparent - {$ELSE} - MOV [EAX].fClassicTransparent, DL - {$ENDIF USE_FLAGS} -@@not_th: -{$ENDIF} - - PUSH EAX - XCHG EAX, ECX - CALL SetDoubleBuffered - POP EAX - MOV EDX, offset[WndProcTransparent] - CALL AttachProc -@@exit: -end; - -function _NewTrayIcon: PTrayIcon; -begin - New(Result,Create); -end; -function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon; -asm - PUSH EBX - PUSH EDX // push Icon - PUSH EAX // push Wnd - CALL _NewTrayIcon - XCHG EBX, EAX - - MOV EAX, [FTrayItems] - TEST EAX, EAX - JNZ @@1 - CALL NewList - MOV [FTrayItems], EAX -@@1: - MOV EDX, EBX - CALL TList.Add - - POP EAX //Wnd - MOV [EBX].TTrayIcon.fControl, EAX - POP [EBX].TTrayIcon.fIcon //Icon - - MOV EDX, offset[WndProcTray] - TEST EAX, EAX - JZ @@2 - CALL TControl.AttachProc -@@2: - MOV DL, 1 - MOV EAX, EBX - CALL TTrayIcon.SetActive - XCHG EAX, EBX - POP EBX -end; - -function WndProcRecreateTrayIcons( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm //cmd //opd - MOV ECX, [fRecreateMsg] - CMP word ptr [EDX].TMsg.message, CX - JNE @@ret_false - PUSH ESI - MOV ESI, [FTrayItems] - MOV ECX, [ESI].TList.fCount - MOV ESI, [ESI].TList.fItems -@@loo: PUSH ECX - LODSD - MOV DL, [EAX].TTrayIcon.fAutoRecreate - AND DL, [EAX].TTrayIcon.fActive - JZ @@nx - DEC [EAX].TTrayIcon.fActive - CALL TTrayIcon.SetActive -@@nx: POP ECX - LOOP @@loo -@@e_loo:POP ESI -@@ret_false: - XOR EAX, EAX -end; - -procedure TTrayIcon.SetAutoRecreate(const Value: Boolean); -asm //cmd //opd - MOV [EAX].fAutoRecreate, DL - MOV EAX, [EAX].FControl - CALL TControl.ParentForm - MOV EDX, offset[WndProcRecreateTrayIcons] - CALL TControl.AttachProc - PUSH offset[TaskbarCreatedMsg] - CALL RegisterWindowMessage - MOV [fRecreateMsg], EAX -end; - -destructor TTrayIcon.Destroy; -asm - PUSH EBX - PUSH ESI - MOV EBX, EAX - XOR EDX, EDX - CALL SetActive - - MOV ECX, [EBX].fIcon - JECXZ @@icon_destroyed - PUSH ECX - CALL DestroyIcon -@@icon_destroyed: - - MOV EDX, EBX - MOV ESI, [FTrayItems] - MOV EAX, ESI - CALL TList.IndexOf - TEST EAX, EAX - JL @@fin - XCHG EDX, EAX - MOV EAX, ESI - CALL TList.Delete - MOV EAX, [ESI].TList.fCount - TEST EAX, EAX - JNZ @@fin - XCHG EAX, [FTrayItems] - CALL TObj.RefDec -@@fin: LEA EAX, [EBX].FTooltip - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrClr - {$ELSE} - CALL System.@LStrClr - {$ENDIF} - XCHG EAX, EBX - CALL TObj.Destroy - POP ESI - POP EBX -end; - -procedure TTrayIcon.SetActive(const Value: Boolean); -asm - CMP [EAX].fActive, DL - JE @@exit - MOV ECX, [EAX].fIcon - JECXZ @@exit - PUSH EDX - PUSH EAX - MOV ECX, [EAX].FWnd - INC ECX - LOOP @@1 - MOV ECX, [EAX].fControl - XOR EAX, EAX - JECXZ @@1 - XCHG EAX, ECX - CALL TControl.GetWindowHandle -@@1: - POP ECX - POP EDX - XCHG EAX, ECX - JECXZ @@exit - MOV [EAX].fActive, DL - MOVZX EDX, DL - XOR DL, 1 - ADD EDX, EDX - CALL SetTrayIcon -@@exit: -end; - -procedure TTrayIcon.SetIcon(const Value: HIcon); -asm - MOV ECX, [EAX].fIcon - CMP ECX, EDX - JE @@exit - MOV [EAX].fIcon, EDX - XOR EDX, EDX - JECXZ @@nim_add - INC EDX // NIM_MODIFY = 1 -@@nim_add: - MOVZX ECX, [EAX].fActive - JECXZ @@exit - CALL SetTrayIcon -@@exit: -end; - -function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; -asm - MOV ECX, [EDX].TMsg.message - SUB ECX, WM_CLOSE - JE @@1 - SUB ECX, WM_NCDESTROY - WM_CLOSE - JNE @@exit -@@1: - MOV ECX, [EDX].TMsg.hwnd - SUB ECX, [EAX].TControl.fHandle - JNE @@exit - - XCHG ECX, [JustOneMutex] - JECXZ @@exit - - PUSH ECX - CALL CloseHandle - -@@exit: - XOR EAX, EAX -end; - -destructor TStrList.Destroy; -asm - PUSH EAX - CALL Clear - POP EAX - CALL TObj.Destroy -end; - -function TStrList.Add(const S: Ansistring): integer; -asm - MOV ECX, EDX - MOV EDX, [EAX].fCount - PUSH EDX - CALL Insert - POP EAX -end; - -procedure TStrList.AddStrings(Strings: PStrList); -asm - PUSH EAX - XCHG EAX, EDX - PUSH 0 - MOV EDX, ESP - CALL GetTextStr - POP EDX - POP EAX - MOV CL, 1 - PUSH EDX - CALL SetText - CALL RemoveStr -end; - -procedure TStrList.Assign(Strings: PStrList); -asm - PUSHAD - CALL Clear - POPAD - JMP AddStrings -end; - -procedure TStrList.Clear; -asm - PUSH EBX - XCHG EBX, EAX - MOV EDX, [EBX].fCount -@@loo: DEC EDX - JL @@eloo - PUSH EDX - MOV EAX, EBX - CALL Delete - POP EDX - JMP @@loo -@@eloo: - XOR EAX, EAX - MOV [EBX].fTextSiz, EAX - XCHG EAX, [EBX].fTextBuf - TEST EAX, EAX - JZ @@1 - CALL System.@FreeMem - {$IFNDEF _D2orD3} //???// - XOR EAX, EAX // not needed for Delphi4 and Higher: if OK, EAX = 0 - {$ENDIF} -@@1: XCHG EAX, [EBX].fList - CALL TObj.RefDec - POP EBX -end; - -{$IFDEF TStrList_Delete_ASM} -procedure TStrList.Delete(Idx: integer); -asm - DEC [EAX].fCount - PUSH EAX - MOV EAX, [EAX].fList - MOV ECX, [EAX].TList.fItems - PUSH dword ptr [ECX+EDX*4] - CALL TList.Delete - POP EAX - POP EDX - MOV ECX, [EDX].fTextSiz - JECXZ @@fremem - CMP EAX, [EDX].fTextBuf - JB @@fremem - ADD ECX, [EDX].fTextBuf - CMP EAX, ECX - JB @@exit -@@fremem: - CALL System.@FreeMem -@@exit: -end; -{$ENDIF} - -function TStrList.Get(Idx: integer): Ansistring; -asm - PUSH ECX - MOV EAX, [EAX].fList - TEST EAX, EAX - JZ @@1 - CALL TList.Get -@@1: XCHG EDX, EAX - POP EAX - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: safe? - {$ENDIF} - JMP System.@LStrFromPChar -end; - -procedure TStrList.Insert(Idx: integer; const S: Ansistring); -asm - PUSH EBX - PUSH EDX - PUSH ECX - XCHG EBX, EAX - MOV EAX, [EBX].fList - TEST EAX, EAX - JNZ @@1 - CALL NewList - MOV [EBX].fList, EAX -@@1: - POP EAX - PUSH EAX // push S - CALL System.@LStrLen - INC EAX - PUSH EAX // push L - CALL System.@GetMem - MOV byte ptr[EAX], 0 - XCHG EDX, EAX - POP ECX - POP EAX - PUSH EDX // push Mem - TEST EAX, EAX - JE @@2 - CALL System.Move -@@2: POP ECX - POP EDX - MOV EAX, [EBX].fList - CALL TList.Insert - INC [EBX].fCount - POP EBX -end; - -procedure TStrList.Put(Idx: integer; const Value: Ansistring); -asm - PUSH EAX - PUSH EDX - CALL Insert - POP EDX - POP EAX - INC EDX - JMP Delete -end; - -procedure LowerCaseStrFromPCharEDX; -asm - { <- EDX = PChar string - -> [ESP] = LowerCase( PChar( EDX ) ), - EAX, EDX, ECX - ? - } - POP EAX - PUSH 0 - PUSH EAX - LEA EAX, [ESP+4] - PUSH EAX - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: fixme - {$ENDIF} - CALL System.@LStrFromPChar - POP EDX - MOV EAX, [EDX] - JMP LowerCase -end; - -procedure TStrList.Sort(CaseSensitive: Boolean); -asm - MOV [EAX].fCaseSensitiveSort, DL - MOV [EAX].fAnsiSort, 0 - {$IFDEF SPEED_FASTER} - {$DEFINE SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF TLIST_FAST} - {$UNDEF SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF SORT_STRLIST_ARRAY} - MOV ECX, offset[StrComp] - CMP DL, 0 - JNZ @@01 - {$IFDEF SMALLER_CODE} - MOV ECX, offset[StrComp_NoCase] - {$ELSE} - MOV ECX, [StrComp_NoCase] - {$ENDIF} -@@01: - MOV EAX, [EAX].fList - TEST EAX, EAX - JZ @@exit - MOV EDX, [EAX].TList.fCount - CMP EDX, 1 - JLE @@02 - MOV EAX, [EAX].TList.fItems - CALL SortArray -@@02: - {$ELSE} - PUSH Offset[TStrList.Swap] - MOV ECX, Offset[CompareStrListItems_Case] - CMP DL, 0 - JNZ @1 - MOV ECX, Offset[CompareStrListItems_NoCase] -@1: MOV EDX, [EAX].fCount - CALL SortData - {$ENDIF} -@@exit: -end; - -procedure TStrList.MergeFromFile(const FileName: KOLString); -asm - PUSH EAX - XCHG EAX, EDX - CALL NewReadFileStream - XCHG EDX, EAX - POP EAX - MOV CL, 1 - PUSH EDX - CALL LoadFromStream - POP EAX - JMP TObj.RefDec -end; - -procedure TStrList.SaveToStream(Stream: PStream); -asm - PUSH EDX - PUSH 0 - MOV EDX, ESP - CALL GetTextStr - POP EAX - PUSH EAX - CALL System.@LStrLen - XCHG ECX, EAX - POP EDX - POP EAX - PUSH EDX - JECXZ @@1 - CALL TStream.Write -@@1: - CALL RemoveStr -end; - -procedure SortData( const Data: Pointer; const uNElem: Dword; - const CompareFun: TCompareEvent; - const SwapProc: TSwapEvent ); -asm - CMP EDX, 2 - JL @@exit - - PUSH EAX // [EBP-4] = Data - PUSH ECX // [EBP-8] = CompareFun - PUSH EBX // EBX = pivotP - XOR EBX, EBX - INC EBX // EBX = 1 to pass to qSortHelp as PivotP - MOV EAX, EDX // EAX = nElem - CALL @@qSortHelp - POP EBX - POP ECX - POP ECX -@@exit: - POP EBP - RET 4 - -@@qSortHelp: - PUSH EBX // EBX (in) = PivotP - PUSH ESI // ESI = leftP - PUSH EDI // EDI = rightP - -@@TailRecursion: - CMP EAX, 2 - JG @@2 - JNE @@exit_qSortHelp - LEA ECX, [EBX+1] - MOV EDX, EBX - CALL @@Compare - JLE @@exit_qSortHelp -@@swp_exit: - CALL @@Swap -@@exit_qSortHelp: - POP EDI - POP ESI - POP EBX - RET - - // ESI = leftP - // EDI = rightP -@@2: LEA EDI, [EAX+EBX-1] - MOV ESI, EAX - SHR ESI, 1 - ADD ESI, EBX - MOV ECX, ESI - MOV EDX, EDI - CALL @@CompareLeSwap - MOV EDX, EBX - CALL @@Compare - - JG @@4 - CALL @@Swap - JMP @@5 -@@4: MOV ECX, EBX - MOV EDX, EDI - CALL @@CompareLeSwap -@@5: - CMP EAX, 3 - JNE @@6 - MOV EDX, EBX - MOV ECX, ESI - JMP @@swp_exit -@@6: // classic Horae algorithm - - PUSH EAX // EAX = pivotEnd - LEA EAX, [EBX+1] - MOV ESI, EAX -@@repeat: - MOV EDX, ESI - MOV ECX, EBX - CALL @@Compare - JG @@while2 -@@while1: - JNE @@7 - MOV EDX, ESI - MOV ECX, EAX - CALL @@Swap - INC EAX -@@7: - CMP ESI, EDI - JGE @@qBreak - INC ESI - JMP @@repeat -@@while2: - CMP ESI, EDI - JGE @@until - MOV EDX, EBX - MOV ECX, EDI - CALL @@Compare - JGE @@8 - DEC EDI - JMP @@while2 -@@8: - MOV EDX, ESI - MOV ECX, EDI - PUSHFD - CALL @@Swap - POPFD - JE @@until - INC ESI - DEC EDI -@@until: - CMP ESI, EDI - JL @@repeat -@@qBreak: - MOV EDX, ESI - MOV ECX, EBX - CALL @@Compare - JG @@9 - INC ESI -@@9: - PUSH EBX // EBX = PivotTemp - PUSH ESI // ESI = leftTemp - DEC ESI -@@while3: - CMP EBX, EAX - JGE @@while3_break - CMP ESI, EAX - JL @@while3_break - MOV EDX, EBX - MOV ECX, ESI - CALL @@Swap - INC EBX - DEC ESI - JMP @@while3 -@@while3_break: - POP ESI - POP EBX - - MOV EDX, EAX - POP EAX // EAX = nElem - PUSH EDI // EDI = lNum - MOV EDI, ESI - SUB EDI, EDX - ADD EAX, EBX - SUB EAX, ESI - - PUSH EBX - PUSH EAX - CMP EAX, EDI - JGE @@10 - - MOV EBX, ESI - CALL @@qSortHelp - POP EAX - MOV EAX, EDI - POP EBX - JMP @@11 - -@@10: MOV EAX, EDI - CALL @@qSortHelp - POP EAX - POP EBX - MOV EBX, ESI -@@11: - POP EDI - JMP @@TailRecursion - -@@Compare: - PUSH EAX - PUSH EDX - PUSH ECX - MOV EAX, [EBP-4] - DEC EDX - DEC ECX - CALL dword ptr [EBP-8] - POP ECX - POP EDX - TEST EAX, EAX - POP EAX - RET - -@@CompareLeSwap: - CALL @@Compare - JG @@ret - -@@Swap: PUSH EAX - PUSH EDX - PUSH ECX - MOV EAX, [EBP-4] - DEC EDX - DEC ECX - CALL dword ptr [SwapProc] - POP ECX - POP EDX - TEST EAX, EAX - POP EAX -@@ret: - RET - -end; - -procedure SortArray( const Data: Pointer; const uNElem: Dword; - const CompareFun: TCompareArrayEvent ); -asm - PUSH EBP - MOV EBP, ESP - CMP EDX, 2 - JL @@exit - - SUB EAX, 4 - PUSH EAX // [EBP-4] = Data - PUSH ECX // [EBP-8] = CompareFun - PUSH EBX // EBX = pivotP - XOR EBX, EBX - INC EBX // EBX = 1 to pass to qSortHelp as PivotP - MOV EAX, EDX // EAX = nElem - CALL @@qSortHelp - POP EBX - POP ECX - POP ECX -@@exit: - POP EBP - RET - -@@qSortHelp: - PUSH EBX // EBX (in) = PivotP - PUSH ESI // ESI = leftP - PUSH EDI // EDI = rightP - -@@TailRecursion: - CMP EAX, 2 - JG @@2 - JNE @@exit_qSortHelp - LEA ECX, [EBX+1] - MOV EDX, EBX - //CALL @@Compare - PUSH EAX - PUSH EDX - PUSH ECX - MOV EAX, [EBP-4] - MOV EAX, [EAX + EDX*4] - MOV EDX, [EBP-4] - MOV EDX, [EDX + ECX*4] - CALL dword ptr [EBP-8] - POP ECX - POP EDX - TEST EAX, EAX - POP EAX - - JLE @@exit_qSortHelp -@@swp_exit: - //CALL @@Swap - PUSH EAX - PUSH ESI - MOV ESI, [EBP-4] - MOV EAX, [ESI+EDX*4] - XCHG EAX, [ESI+ECX*4] - MOV [ESI+EDX*4], EAX - POP ESI - POP EAX - -@@exit_qSortHelp: - POP EDI - POP ESI - POP EBX - RET - - // ESI = leftP - // EDI = rightP -@@2: LEA EDI, [EAX+EBX-1] - MOV ESI, EAX - SHR ESI, 1 - ADD ESI, EBX - MOV ECX, ESI - MOV EDX, EDI - CALL @@CompareLeSwap - MOV EDX, EBX - //CALL @@Compare - PUSH EAX - PUSH EDX - PUSH ECX - MOV EAX, [EBP-4] - MOV EAX, [EAX + EDX*4] - MOV EDX, [EBP-4] - MOV EDX, [EDX + ECX*4] - CALL dword ptr [EBP-8] - POP ECX - POP EDX - TEST EAX, EAX - POP EAX - - JG @@4 - //CALL @@Swap - PUSH EAX - PUSH ESI - MOV ESI, [EBP-4] - MOV EAX, [ESI+EDX*4] - XCHG EAX, [ESI+ECX*4] - MOV [ESI+EDX*4], EAX - POP ESI - POP EAX - - JMP @@5 -@@4: MOV ECX, EBX - MOV EDX, EDI - CALL @@CompareLeSwap -@@5: - CMP EAX, 3 - JNE @@6 - MOV EDX, EBX - MOV ECX, ESI - JMP @@swp_exit -@@6: // classic Horae algorithm - - PUSH EAX // EAX = pivotEnd - LEA EAX, [EBX+1] - MOV ESI, EAX -@@repeat: - MOV EDX, ESI - MOV ECX, EBX - //CALL @@Compare - PUSH EAX - PUSH EDX - PUSH ECX - MOV EAX, [EBP-4] - MOV EAX, [EAX + EDX*4] - MOV EDX, [EBP-4] - MOV EDX, [EDX + ECX*4] - CALL dword ptr [EBP-8] - POP ECX - POP EDX - TEST EAX, EAX - POP EAX - - JG @@while2 -@@while1: - JNE @@7 - MOV EDX, ESI - MOV ECX, EAX - //CALL @@Swap - PUSH EAX - PUSH ESI - MOV ESI, [EBP-4] - MOV EAX, [ESI+EDX*4] - XCHG EAX, [ESI+ECX*4] - MOV [ESI+EDX*4], EAX - POP ESI - POP EAX - - INC EAX -@@7: - CMP ESI, EDI - JGE @@qBreak - INC ESI - JMP @@repeat -@@while2: - CMP ESI, EDI - JGE @@until - MOV EDX, EBX - MOV ECX, EDI - //CALL @@Compare - PUSH EAX - PUSH EDX - PUSH ECX - MOV EAX, [EBP-4] - MOV EAX, [EAX + EDX*4] - MOV EDX, [EBP-4] - MOV EDX, [EDX + ECX*4] - CALL dword ptr [EBP-8] - POP ECX - POP EDX - TEST EAX, EAX - POP EAX - - JGE @@8 - DEC EDI - JMP @@while2 -@@8: - MOV EDX, ESI - MOV ECX, EDI - //PUSHFD - //CALL @@Swap - PUSH EAX - PUSH ESI - MOV ESI, [EBP-4] - MOV EAX, [ESI+EDX*4] - XCHG EAX, [ESI+ECX*4] - MOV [ESI+EDX*4], EAX - POP ESI - POP EAX - - //POPFD - JE @@until - INC ESI - DEC EDI -@@until: - CMP ESI, EDI - JL @@repeat -@@qBreak: - MOV EDX, ESI - MOV ECX, EBX - //CALL @@Compare - PUSH EAX - PUSH EDX - PUSH ECX - MOV EAX, [EBP-4] - MOV EAX, [EAX + EDX*4] - MOV EDX, [EBP-4] - MOV EDX, [EDX + ECX*4] - CALL dword ptr [EBP-8] - POP ECX - POP EDX - TEST EAX, EAX - POP EAX - - JG @@9 - INC ESI -@@9: - PUSH EBX // EBX = PivotTemp - PUSH ESI // ESI = leftTemp - DEC ESI -@@while3: - CMP EBX, EAX - JGE @@while3_break - CMP ESI, EAX - JL @@while3_break - MOV EDX, EBX - MOV ECX, ESI - //CALL @@Swap - PUSH EAX - PUSH ESI - MOV ESI, [EBP-4] - MOV EAX, [ESI+EDX*4] - XCHG EAX, [ESI+ECX*4] - MOV [ESI+EDX*4], EAX - POP ESI - POP EAX - - INC EBX - DEC ESI - JMP @@while3 -@@while3_break: - POP ESI - POP EBX - - MOV EDX, EAX - POP EAX // EAX = nElem - PUSH EDI // EDI = lNum - MOV EDI, ESI - SUB EDI, EDX - ADD EAX, EBX - SUB EAX, ESI - - PUSH EBX - PUSH EAX - CMP EAX, EDI - JGE @@10 - - MOV EBX, ESI - CALL @@qSortHelp - POP EAX - MOV EAX, EDI - POP EBX - JMP @@11 - -@@10: MOV EAX, EDI - CALL @@qSortHelp - POP EAX - POP EBX - MOV EBX, ESI -@@11: - POP EDI - JMP @@TailRecursion - -{@@Compare: - PUSH EAX - PUSH EDX - PUSH ECX - MOV EAX, [EBP-4] - MOV EAX, [EAX + EDX*4] - MOV EDX, [EBP-4] - MOV EDX, [EDX + ECX*4] - CALL dword ptr [EBP-8] - POP ECX - POP EDX - TEST EAX, EAX - POP EAX - RET} - -@@CompareLeSwap: - //CALL @@Compare - PUSH EAX - PUSH EDX - PUSH ECX - MOV EAX, [EBP-4] - MOV EAX, [EAX + EDX*4] - MOV EDX, [EBP-4] - MOV EDX, [EDX + ECX*4] - CALL dword ptr [EBP-8] - POP ECX - POP EDX - TEST EAX, EAX - POP EAX - - JG @@ret - -@@Swap: PUSH EAX - PUSH ESI - MOV ESI, [EBP-4] - MOV EAX, [ESI+EDX*4] - XCHG EAX, [ESI+ECX*4] - MOV [ESI+EDX*4], EAX - POP ESI - //TEST EAX, EAX - POP EAX -@@ret: - RET - -end; - - -function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -asm - MOV EDX, [EAX+EDX*4] - SUB EDX, [EAX+ECX*4] - XCHG EAX, EDX -end; - -function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -asm - MOV EDX, [EAX+EDX*4] - SUB EDX, [EAX+ECX*4] - XCHG EAX, EDX - JNB @@1 - SBB EAX, EAX -@@1: -end; - -function Compare2Dwords( e1, e2 : DWORD ) : Integer; -asm - SUB EAX, EDX - JZ @@exit - MOV EAX, 0 - JB @@neg - INC EAX - INC EAX -@@neg: - DEC EAX -@@exit: -end; - -procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD ); -asm - LEA EDX, [EAX+EDX*4] - LEA ECX, [EAX+ECX*4] - MOV EAX, [EDX] - XCHG EAX, [ECX] - MOV [EDX], EAX -end; - -function _NewStatusbar( AParent: PControl ): PControl; -const STAT_CLS_NAM: PKOLChar = STATUSCLASSNAME; -asm - PUSH 0 - {$IFDEF COMMANDACTIONS_OBJ} - PUSH OTHER_ACTIONS - {$ELSE} - PUSH 0 - {$ENDIF} - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fFlagsG3, (1 shl G3_SizeGrip) - {$ELSE} - CMP [EAX].TControl.fSizeGrip, 0 - {$ENDIF} - MOV ECX, WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or 3 or WS_VISIBLE - JZ @@1 - INC CH - AND CL, not 3 -@@1: - MOV EDX, [STAT_CLS_NAM] - CALL _NewCommonControl - PUSH EBX - XCHG EBX, EAX - PUSH EDI - LEA EDI, [EBX].TControl.fBoundsRect - XOR EAX, EAX - STOSD - STOSD - STOSD - STOSD - MOV [EBX].TControl.fAlign, caBottom - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG4, 1 shl G4_NotUseAlign - {$ELSE} - INC [EBX].TControl.fNotUseAlign - {$ENDIF} - POP EDI - MOV EAX, EBX - CALL InitCommonControlSizeNotify - XCHG EAX, EBX - POP EBX -end; - -procedure TControl.RemoveStatus; -asm - MOV ECX, [EAX].fStatusCtl - JECXZ @@exit - PUSH EBX - MOV EBX, EAX - CALL GetClientHeight - PUSH EAX - XOR EAX, EAX - XCHG [EBX].fStatusCtl, EAX - CALL TObj.RefDec - POP EAX - CDQ - MOV [EBX].fClientBottom, DL - XCHG EDX, EAX - XCHG EAX, EBX - POP EBX - CALL SetClientHeight -@@exit: -end; - -function TControl.StatusPanelCount: Integer; -asm - MOV ECX, [EAX].fStatusCtl - JECXZ @@exit - PUSH 0 - PUSH 0 - PUSH SB_GETPARTS - PUSH ECX - CALL Perform -@@exit: -end; - -function TControl.GetStatusPanelX(Idx: Integer): Integer; -asm - MOV ECX, [EAX].fStatusCtl - JECXZ @@exit - PUSH EBX - MOV EBX, EDX - ADD ESP, -1024 - PUSH ESP - XOR EDX, EDX - DEC DL - PUSH EDX - MOV DX, SB_GETPARTS - PUSH EDX - PUSH ECX - CALL Perform - CMP EAX, EBX - MOV ECX, [ESP+EBX*4] - JG @@1 - XOR ECX, ECX -@@1: ADD ESP, 1024 - POP EBX -@@exit: - XCHG EAX, ECX -end; - -procedure TControl.SetStatusPanelX(Idx: Integer; const Value: Integer); -asm - ADD ESP, -1024 - MOV EAX, [EAX].fStatusCtl - TEST EAX, EAX - JZ @@exit - - PUSH ESP - PUSH EDX - PUSH SB_SETPARTS - PUSH EAX - - PUSH EDX - PUSH ECX - - LEA EDX, [ESP+24] - PUSH EDX - PUSH 255 - PUSH SB_GETPARTS - PUSH EAX - CALL Perform - - POP ECX - POP EDX - CMP EAX, EDX - JG @@1 - ADD ESP, 16 - JMP @@exit - -@@1: MOV [ESP+8], EAX - MOV [ESP+16+EDX*4], ECX - CALL Perform - -@@exit: ADD ESP, 1024 -end; - -destructor TImageList.Destroy; -asm - PUSH EAX - XOR EDX, EDX - CALL SetHandle - POP EAX - MOV EDX, [EAX].fNext - MOV ECX, [EAX].fPrev - TEST EDX, EDX - JZ @@nonext - MOV [EDX].fPrev, ECX -@@nonext: - JECXZ @@noprev - MOV [ECX].fNext, EDX -@@noprev: - MOV ECX, [EAX].fControl - JECXZ @@fin - CMP [ECX].TControl.fImageList, EAX - JNZ @@fin - MOV [ECX].TControl.fImageList, EDX - {$IFDEF USE_AUTOFREE4CONTROLS} - PUSH EAX - XCHG EAX, ECX - MOV EDX, ECX - CALL TControl.RemoveFromAutoFree - POP EAX - {$ENDIF} -@@fin: CALL TObj.Destroy -end; - -function TImageList.GetHandle: THandle; -asm - PUSH EAX - CALL HandleNeeded - POP EAX - MOV EAX, [EAX].FHandle -end; - -procedure TImageList.SetHandle(const Value: THandle); -asm - PUSH EBX - XCHG EBX, EAX - MOV ECX, [EBX].FHandle - CMP ECX, EDX - JZ @@exit - JECXZ @@set_handle - CMP [EBX].fShareImages, 0 - JNZ @@set_handle - PUSH EDX - PUSH ECX - CALL ImageList_Destroy - POP EDX - -@@set_handle: - MOV [EBX].FHandle, EDX - TEST EDX, EDX - JZ @@set_sz0 - LEA EAX, [EBX].FImgHeight - PUSH EAX - LEA EAX, [EBX].FImgWidth - PUSH EAX - PUSH EDX - CALL ImageList_GetIconSize - JMP @@exit - -@@set_sz0: - MOV [EBX].fImgWidth, EDX - MOV [EBX].fImgHeight, EDX - -@@exit: - POP EBX -end; - -function TControl.Perform(msgcode: DWORD; wParam, lParam: Integer): Integer; stdcall; -asm - PUSH [lParam] - PUSH [wParam] - PUSH [msgcode] - MOV EAX, [EBP+8] - CALL TControl.GetWindowHandle - PUSH EAX - {$IFDEF UNICODE_CTRLS} - CALL Windows.SendMessageW - {$ELSE} - CALL Windows.SendMessageA - {$ENDIF} -end; - -function TControl.Postmsg(msgcode: DWORD; wParam, lParam: Integer): Boolean; stdcall; -asm - PUSH [lParam] - PUSH [wParam] - PUSH [msgcode] - MOV EAX, [EBP+8] - CALL TControl.GetWindowHandle - PUSH EAX - CALL Windows.PostMessageA -end; - -function TControl.GetChildCount: Integer; -asm - MOV EAX, [EAX].fChildren - MOV EAX, [EAX].TList.fCount -end; - -procedure TControl.SetItemVal(Item: Integer; const Index: Integer; const Value: Integer); -asm - PUSH EAX - PUSH [Value] - PUSH EDX - MOV EDX, ECX - SHR EDX, 16 - JNZ @@1 - MOV EDX, ECX - INC EDX -@@1: - MOV EBP, EDX - AND EDX, 7FFFh - PUSH EDX - PUSH EAX - CALL Perform - MOV EAX, EBP - ADD AX, AX - POP EAX - JNB @@2 - CALL Invalidate -@@2: -end; - -destructor TOpenSaveDialog.Destroy; -asm //cmd //opd - PUSH EAX - PUSH 0 - LEA EDX, [EAX].FFilter - PUSH EDX - LEA EDX, [EAX].FInitialDir - PUSH EDX - LEA EDX, [EAX].FDefExtension - PUSH EDX - LEA EDX, [EAX].FFileName - PUSH EDX - LEA EAX, [EAX].FTitle -@@loo: - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrClr - {$ELSE} - CALL System.@LStrClr - {$ENDIF} - POP EAX - TEST EAX, EAX - JNZ @@loo - POP EAX - CALL TObj.Destroy -end; - -destructor TOpenDirDialog.Destroy; -asm //cmd //opd - PUSH EAX - PUSH 0 - LEA EDX, [EAX].FTitle - PUSH EDX - LEA EDX, [EAX].FInitialPath - PUSH EDX - LEA EAX, [EAX].FStatusText -@@loo: - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrClr - {$ELSE} - CALL System.@LStrClr - {$ENDIF} - POP EAX - TEST EAX, EAX - JNZ @@loo - POP EAX - CALL TObj.Destroy -end; - -{$IFNDEF NEW_OPEN_DIR_STYLE_EX} -function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer; - stdcall; -asm - MOV EAX, [Wnd] - MOV EDX, [lpData] - - MOV [EDX].TOpenDirDialog.FDialogWnd, EAX - - MOV ECX, [Msg] - LOOP @@chk_sel_chg - // Msg = 1 -> BFFM_Initialized - - MOV ECX, [EDX].TOpenDirDialog.FCenterProc - JECXZ @@1 - PUSH EDX - CALL ECX - POP EDX -@@1: MOV ECX, [EDX].TOpenDirDialog.FInitialPath - JECXZ @@exit - PUSH ECX - PUSH 1 - {$IFDEF UNICODE_CTRLS} - PUSH BFFM_SETSELECTIONW - {$ELSE} - PUSH BFFM_SETSELECTION - {$ENDIF} - PUSH [Wnd] - CALL SendMessage - JMP @@exit - -@@chk_sel_chg: - LOOP @@exit - // Msg = 2 -> BFFM_SelChanged - - MOV ECX, [EDX].TOpenDirDialog.FDoSelChanged - JECXZ @@exit - POP EBP - JMP ECX - -@@exit: XOR EAX, EAX -end; -{$ENDIF} - -procedure OpenDirDlgCenter( Wnd: HWnd ); -asm - PUSH EBX - MOV EBX, EAX - - ADD ESP, -16 - PUSH ESP - PUSH EAX - CALL GetWindowRect - POP EDX // EDX = Left - POP ECX // ECX = Top - POP EAX // EAX = Right - SUB EAX, EDX // EAX = W - POP EDX // EDX = Bottom - SUB EDX, ECX // EDX = H - XOR ECX, ECX - INC ECX - PUSH ECX // prepare True - PUSH EDX // prepare H - PUSH EAX // prepare W - - INC ECX -@@1: - PUSH ECX - - DEC ECX - PUSH ECX - CALL GetSystemMetrics - - POP ECX - SUB EAX, [ESP+4] - SAR EAX, 1 - PUSH EAX - - LOOP @@1 - - PUSH EBX - CALL MoveWindow - POP EBX -end; - -procedure TOpenDirDialog.SetCenterOnScreen(const Value: Boolean); -asm - MOV [EAX].FCenterOnScreen, DL - MOVZX ECX, DL - JECXZ @@1 - MOV ECX, Offset[OpenDirDlgCenter] -@@1: MOV [EAX].FCenterProc, ECX -end; - -function TControl.TBAddButtons(const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer): Integer; -asm - PUSH dword ptr [EBP+8] - PUSH dword ptr [EBP+12] - PUSH ECX - PUSH EDX - PUSH -1 - PUSH EAX - CALL TBAddInsButtons -end; - -function TControl.TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean; -asm - PUSH 0 - PUSH ECX - PUSH EAX - CALL GetTBBtnGoodID - POP EDX - POP ECX - PUSH EAX - ADD ECX, 8 - PUSH ECX - PUSH EDX - CALL Perform - TEST EAX, EAX - SETNZ AL -end; - -function TControl.TBIndex2Item(Idx: Integer): Integer; -const // - _sizeof_TTBButton = sizeof( TTBButton ); // -asm - ADD ESP, -_sizeof_TTBButton // - PUSH ESP - PUSH EDX - PUSH TB_GETBUTTON - PUSH EAX - CALL Perform - TEST EAX, EAX - MOV EAX, [ESP].TTBButton.idCommand - JNZ @@1 - OR EAX, -1 -@@1: ADD ESP, _sizeof_TTBButton // -end; - -// TODO: testcase -//{$IFDEF ASM_UNICODE} -procedure TControl.TBSetTooltips(BtnID1st: Integer; - const Tooltips: array of PKOLChar); -asm - PUSH EBX - PUSH ESI - MOV ESI, ECX - MOV EBX, EAX - PUSHAD - MOV ECX, [EBX].DF.fTBttCmd - INC ECX - LOOP @@1 - CALL NewList - MOV [EBX].DF.fTBttCmd, EAX - {$IFDEF USE_AUTOFREE4CONTROLS} - XCHG EDX, EAX - MOV EAX, EBX - CALL TControl.Add2AutoFree - {$ENDIF} - {$IFDEF UNICODE_CTRLS} - CALL NewWStrList - {$ELSE} - CALL NewStrList - {$ENDIF} - MOV [EBX].DF.fTBttTxt, EAX - {$IFDEF USE_AUTOFREE4CONTROLS} - XCHG EDX, EAX - MOV EAX, EBX - CALL TControl.Add2AutoFree - {$ENDIF} -@@1: POPAD - MOV ECX, [EBP+8] - INC ECX - JZ @@exit -@@loop: - PUSH ECX - PUSH EDX - PUSH 0 - LODSD - MOV EDX, EAX - MOV EAX, ESP - {$IFDEF UNICODE_CTRLS} - CALL System.@WStrFromPWChar - {$ELSE} - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: safe? - {$ENDIF} - CALL System.@LStrFromPChar - {$ENDIF} - - MOV EDX, [ESP+4] - MOV EAX, [EBX].DF.fTBttCmd - CALL TList.IndexOf - TEST EAX, EAX - JGE @@2 - - MOV EDX, [ESP+4] - MOV EAX, [EBX].DF.fTBttCmd - CALL TList.Add - POP EDX - PUSH EDX - MOV EAX, [EBX].DF.fTBttTxt - {$IFDEF UNICODE_CTRLS} - CALL TWStrList.Add - {$ELSE} - CALL TStrList.Add - {$ENDIF} - JMP @@3 - -@@2: - MOV EDX, EAX - POP ECX - PUSH ECX - MOV EAX, [EBX].DF.fTBttTxt - {$IFDEF UNICODE_CTRLS} - CALL TWStrList.Put - {$ELSE} - CALL TStrList.Put - {$ENDIF} -@@3: - {$IFDEF UNICODE_CTRLS} - CALL RemoveWStr - {$ELSE} - CALL RemoveStr - {$ENDIF} - - POP EDX - POP ECX - INC EDX - LOOP @@loop -@@exit: - POP ESI - POP EBX -end; -//{$ENDIF} - -function TControl.TBButtonAtPos(X, Y: Integer): Integer; -asm - PUSH EAX - CALL TBBtnIdxAtPos - TEST EAX, EAX - MOV EDX, EAX - POP EAX - JGE TBIndex2Item - MOV EAX, EDX -end; - -function TControl.TBBtnIdxAtPos(X, Y: Integer): Integer; -asm - PUSH EBX - PUSH ECX - PUSH EDX - MOV EBX, EAX - CALL GetItemsCount - MOV ECX, EAX - JECXZ @@fin -@@1: PUSH ECX - ADD ESP, -16 - PUSH ESP - DEC ECX - PUSH ECX - PUSH TB_GETITEMRECT - PUSH EBX - CALL Perform - MOV EDX, ESP - LEA EAX, [ESP+20] - CALL PointInRect - ADD ESP, 16 - POP ECX - TEST AL, AL - {$IFDEF USE_CMOV} - CMOVNZ EAX, ECX - {$ELSE} - JZ @@2 - MOV EAX, ECX - JMP @@fin -@@2: {$ENDIF} - JNZ @@fin - - LOOP @@1 -@@fin: DEC EAX - POP EDX - POP EDX - POP EBX -end; - -procedure TControl.TBSetButtonText(BtnID: Integer; const Value: KOLString); -asm - PUSH 0 - PUSH ECX - PUSH EAX - CALL GetTBBtnGoodID - POP EDX - - ADD ESP, -16 - PUSH TBIF_TEXT - PUSH 32 //Sizeof( TTBButtonInfo ) - PUSH ESP - PUSH EAX - PUSH TB_SETBUTTONINFO - PUSH EDX - CALL Perform - ADD ESP, 32 //sizeof( TTBButtonInfo ) -end; - -function TControl.TBGetBtnWidth(BtnID: Integer): Integer; -asm - ADD ESP, -16 - MOV ECX, ESP - CALL TBGetButtonRect - POP EDX - POP ECX - POP EAX - SUB EAX, EDX - POP EDX -end; - -procedure TControl.TBSetBtnWidth(BtnID: Integer; const Value: Integer); -asm - PUSH EBX - MOV EBX, ECX - - PUSH EAX - CALL GetTBBtnGoodID - POP EDX - - ADD ESP, -24 - PUSH TBIF_SIZE or TBIF_STYLE - PUSH 32 - MOV ECX, ESP - - PUSH ECX - PUSH EAX - PUSH TB_SETBUTTONINFO - PUSH EDX - - PUSH ECX - PUSH EAX - PUSH TB_GETBUTTONINFO - PUSH EDX - CALL Perform - - MOV [ESP+16+18], BX - AND byte ptr [ESP+16].TTBButtonInfo.fsStyle, not TBSTYLE_AUTOSIZE - CALL Perform - ADD ESP, 32 - POP EBX -end; - -procedure TControl.AddDirList(const Filemask: KOLString; Attrs: DWORD); -asm - CALL EDX2PChar - PUSH EDX - PUSH ECX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aDir - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aDir - {$ENDIF} - JECXZ @@exit - PUSH ECX - PUSH EAX - CALL Perform - RET -@@exit: - POP ECX - POP ECX -end; - -{$IFDEF noASM_VERSION} -function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - CMP word ptr [EDX].TMsg.message, WM_CLOSE - JNZ @@ret_false - - XCHG EDX, EAX - XOR EAX, EAX - CMP [EDX].TControl.fModalResult, EAX - JNZ @@1 - OR [EDX].TControl.fModalResult, -1 -@@1: - MOV [ECX], EAX - INC EAX - RET -@@ret_false: - XOR EAX, EAX - -end; -{$ENDIF} - -function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer; - stdcall; -asm //cmd //opd - {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED} - CMP [AppletTerminated], 0 - JNZ @@exit - {$ENDIF} - MOV EDX, T - MOV ECX, [EDX].TTimer.fOnTimer.TMethod.Code - JECXZ @@exit - MOV EAX, [EDX].TTimer.fOnTimer.TMethod.Data - CALL ECX -@@exit: XOR EAX, EAX -end; - -destructor TTimer.Destroy; -asm - PUSH EAX - XOR EDX, EDX - CALL TTimer.SetEnabled - POP EAX - CALL TObj.Destroy - DEC [TimerCount] - JNZ @@exit - XOR EAX, EAX - XCHG EAX, [TimerOwnerWnd] - CALL TObj.RefDec -@@exit: -end; - -procedure TTimer.SetEnabled(const Value: Boolean); -asm - PUSH EBX - XCHG EBX, EAX - - CMP [EBX].fEnabled, DL - JZ @@exit - - {$IFDEF TIMER_APPLETWND} - - MOV ECX, [Applet] - JECXZ @@exit - - MOV [EBX].fEnabled, DL - TEST DL, DL - JZ @@disable - - {$ELSE} - - MOV [EBX].fEnabled, DL - TEST DL, DL - JZ @@disable - - MOV ECX, [TimerOwnerWnd] - INC ECX - LOOP @@owner_ready - - INC ECX - MOV EDX, offset[EmptyString] - XOR EAX, EAX - PUSH EAX - CALL _NewWindowed - MOV [TimerOwnerWnd], EAX - MOV [EAX].TControl.fStyle, 0 - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG3, 1 shl G3_IsControl - {$ELSE} - INC [EAX].TControl.fIsControl - {$ENDIF} - XCHG ECX, EAX - - {$ENDIF} - -@@owner_ready: - - PUSH offset[TimerProc] - PUSH [EBX].fInterval - PUSH EBX - XCHG EAX, ECX - CALL TControl.GetWindowHandle - PUSH EAX - CALL SetTimer - MOV [EBX].fHandle, EAX - - JMP @@exit - -@@disable: - XOR ECX, ECX - XCHG ECX, [EBX].TTimer.fHandle - JECXZ @@exit - - PUSH ECX - {$IFDEF TIMER_APPLETWND} - MOV EAX, [Applet] - {$ELSE} - MOV EAX, [TimerOwnerWnd] - {$ENDIF} - PUSH [EAX].TControl.fHandle - CALL KillTimer - -@@exit: - POP EBX -end; - -function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo; -const szIH = sizeof(TBitmapInfoHeader); - szHd = szIH + 256 * Sizeof(TRGBQuad); -asm - PUSH EDI - - PUSH ECX // BitsPerPixel - PUSH EDX // H - PUSH EAX // W - - MOV EAX, szHd - CALL AllocMem - - MOV EDI, EAX - XCHG ECX, EAX - - XOR EAX, EAX - MOV AL, szIH - STOSD // biSize = Sizeof( TBitmapInfoHeader ) - POP EAX // ^ W - STOSD // -> biWidth - POP EAX // ^ H - STOSD // -> biHeight - XOR EAX, EAX - INC EAX - STOSW // 1 -> biPlanes - POP EAX // ^ BitsPerPixel - STOSW // -> biBitCount - - XCHG EAX, ECX // EAX = Result - POP EDI -end; - -function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat; -asm - PUSH ESI - MOV ESI, offset[ BitsPerPixel_By_PixelFormat + 1 ] - XOR ECX, ECX - XCHG EDX, EAX -@@loo: INC ECX - LODSB - CMP AL, DL - JZ @@exit - TEST AL, AL - JNZ @@loo -@@exit: XCHG EAX, ECX - POP ESI -end; - -function _NewBitmap( W, H: Integer ): PBitmap; -begin - New( Result, Create ); - Result.fDetachCanvas := DummyDetachCanvas; - Result.fWidth := W; - Result.fHeight := H; -end; -function NewBitmap( W, H: Integer ): PBitmap; -asm - PUSH EAX - PUSH EDX - CALL _NewBitmap - POP EDX - POP ECX - PUSH EAX - INC [EAX].TBitmap.fHandleType - JECXZ @@exit - TEST EDX, EDX - JZ @@exit - PUSH EBX - PUSH EAX - PUSH EDX - PUSH ECX - PUSH 0 - CALL GetDC - PUSH EAX - XCHG EBX, EAX - CALL CreateCompatibleBitmap - POP EDX - MOV [EDX].TBitmap.fHandle, EAX - PUSH EBX - PUSH 0 - CALL ReleaseDC - POP EBX -@@exit: POP EAX -end; - -procedure PreparePF16bit( DIBHeader: PBitmapInfo ); -const szBIH = sizeof(TBitmapInfoHeader); -asm - MOV byte ptr [EAX].TBitmapInfoHeader.biCompression, BI_BITFIELDS - ADD EAX, szBIH - XCHG EDX, EAX - MOV EAX, offset[InitColors] - XOR ECX, ECX - MOV CL, 19*4 - CALL System.Move -end; - -function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap; -asm - PUSH EBX - - PUSH ECX - PUSH EDX - PUSH EAX - CALL _NewBitmap - XCHG EBX, EAX - POP EAX //W - POP EDX //H - POP ECX //PixelFormat - - TEST EAX, EAX - JZ @@exit - TEST EDX, EDX - JZ @@exit - - PUSH EAX - MOVZX EAX, CL - JMP @@loadBitsPixel -@@loadDefault: - MOVZX EAX, [DefaultPixelFormat] -@@loadBitsPixel: - MOVZX ECX, byte ptr [ BitsPerPixel_By_PixelFormat + EAX ] - JECXZ @@loadDefault - MOV [EBX].TBitmap.fNewPixelFormat, AL - {$IFDEF PARANOIA} DB $3C, pf16bit {$ELSE} CMP AL, pf16bit {$ENDIF} - POP EAX - - PUSHFD - CALL PrepareBitmapHeader - MOV [EBX].TBitmap.fDIBHeader, EAX - POPFD - JNZ @@2 - - CALL PreparePF16bit - -@@2: - MOV EAX, EBX - CALL TBitmap.GetScanLineSize - MOV EDX, [EBX].TBitmap.fHeight - MUL EDX - MOV [EBX].TBitmap.fDIBSize, EAX - ADD EAX, 16 - PUSH EAX - PUSH GMEM_FIXED or GMEM_ZEROINIT - CALL GlobalAlloc - MOV [EBX].TBitmap.fDIBBits, EAX -@@exit: - XCHG EAX, EBX - POP EBX -end; - -procedure TBitmap.ClearData; -asm - PUSH EBX - MOV EBX, EAX - CALL [EBX].fDetachCanvas - XOR ECX, ECX - XCHG ECX, [EBX].fHandle - JECXZ @@1 - PUSH ECX - CALL DeleteObject - XOR ECX, ECX - MOV [EBX].fDIBBits, ECX -@@1: XCHG ECX, [EBX].fDIBBits - JECXZ @@2 - CMP [EBX].fDIBAutoFree, 0 - JNZ @@2 - PUSH ECX - CALL GlobalFree -@@2: XOR ECX, ECX - XCHG ECX, [EBX].fDIBHeader - JECXZ @@3 - XCHG EAX, ECX - CALL System.@FreeMem -@@3: XOR EAX, EAX - MOV [EBX].fScanLineSize, EAX - MOV [EBX].fGetDIBPixels, EAX - MOV [EBX].fSetDIBPixels, EAX - XCHG EAX, EBX - POP EBX - CALL ClearTransImage -end; - -procedure TBitmap.Clear; -asm - PUSH EAX - CALL RemoveCanvas - POP EAX - PUSH EAX - CALL ClearData - POP EAX - XOR EDX, EDX - MOV [EAX].fWidth, EDX - MOV [EAX].fHeight, EDX - MOV [EAX].fDIBAutoFree, DL -end; - -destructor TBitmap.Destroy; -asm - PUSH EAX - CALL Clear - POP EAX - CALL TObj.Destroy -end; - -procedure TBitmap.Draw(DC: HDC; X, Y: Integer); -const szBitmap = sizeof( tagBitmap ); -asm // [EBP+8] = Y - PUSH EDX // [EBP-4] = DC - PUSH ECX // [EBP-8] = X - PUSH EBX - PUSH ESI -@@try_again: - MOV EBX, EAX - CALL GetEmpty // GetEmpty must be assembler version ! - JZ @@exit - - MOV ECX, [EBX].fHandle - JECXZ @@2 - //MOV EAX, EBX - //CALL [EBX].fDetachCanvas // detached in StartDC - ADD ESP, -szBitmap - PUSH ESP - PUSH szBitmap - PUSH [EBX].fHandle - CALL GetObject - TEST EAX, EAX - MOV ESI, [ESP].tagBitmap.bmHeight - {$IFDEF USE_CMOV} - CMOVZ ESI, [EBX].fHeight - {$ELSE} - JNZ @@1 - MOV ESI, [EBX].fHeight -@@1: {$ENDIF} - - ADD ESP, szBitmap - CALL StartDC - - PUSH SRCCOPY - PUSH 0 - PUSH 0 - PUSH EAX - CALL @@prepare - CALL BitBlt - CALL FinishDC - JMP @@exit - -@@prepare: - XCHG ESI, [ESP] - PUSH [EBX].fWidth - PUSH Y - PUSH dword ptr [EBP-8] - PUSH dword ptr [EBP-4] - JMP ESI - -@@2: - MOV ECX, [EBX].fDIBHeader - JECXZ @@exit - - MOV ESI, [ECX].TBitmapInfoHeader.biHeight - TEST ESI, ESI - JGE @@20 - NEG ESI -@@20: - PUSH SRCCOPY - PUSH DIB_RGB_COLORS - PUSH ECX - PUSH [EBX].fDIBBits - PUSH ESI - PUSH [EBX].fWidth - PUSH 0 - PUSH 0 - CALL @@prepare - CALL StretchDIBits - TEST EAX, EAX - JNZ @@exit - MOV EAX, EBX - CALL GetHandle - TEST EAX, EAX - XCHG EAX, EBX - JNZ @@try_again -@@exit: - POP ESI - POP EBX - MOV ESP, EBP -end; - -procedure TBitmap.StretchDraw(DC: HDC; const Rect: TRect); -asm - PUSH EBX - PUSH EDI - PUSH EBP - MOV EBP, ESP - PUSH EDX - PUSH ECX - MOV EBX, EAX - CALL GetEmpty - JZ @@exit - - MOV ECX, [EBX].fHandle - JECXZ @@2 - -@@0: - CALL StartDC - PUSH SRCCOPY - PUSH [EBX].fHeight - PUSH [EBX].fWidth - PUSH 0 - PUSH 0 - PUSH EAX - - CALL @@prepare - CALL StretchBlt - CALL FinishDC - JMP @@exit - -@@prepare: - POP EDI - MOV EAX, [EBP-8] - MOV EDX, [EAX].TRect.Bottom - MOV ECX, [EAX].TRect.Top - SUB EDX, ECX - PUSH EDX - MOV EDX, [EAX].TRect.Right - MOV EAX, [EAX].TRect.Left - SUB EDX, EAX - PUSH EDX - PUSH ECX - PUSH EAX - PUSH dword ptr [EBP-4] - JMP EDI - - -@@2: MOV ECX, [EBX].fDIBHeader - JECXZ @@exit - - PUSH SRCCOPY - PUSH DIB_RGB_COLORS - PUSH ECX - PUSH [EBX].fDIBBits - PUSH [EBX].fHeight - PUSH [EBX].fWidth - PUSH 0 - PUSH 0 - CALL @@prepare - CALL StretchDIBits - TEST EAX, EAX - JG @@exit - - MOV EAX, EBX - CALL GetHandle - MOV ECX, [EBX].fHandle - JECXZ @@exit - JMP @@0 - -@@exit: MOV ESP, EBP - POP EBP - POP EDI - POP EBX -end; - -procedure TBitmap.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor); -asm - PUSH ECX - MOV ECX, TranspColor - INC ECX - MOV ECX, [Y] - JNZ @@2 - XCHG ECX, [ESP] - CALL Draw - JMP @@exit -@@2: - ADD ECX, [EAX].fHeight - PUSH ECX - MOV ECX, [EBP-4] - ADD ECX, [EAX].fWidth - PUSH ECX - PUSH [Y] - PUSH dword ptr [EBP-4] - MOV ECX, ESP - PUSH [TranspColor] - CALL StretchDrawTransparent -@@exit: - MOV ESP, EBP -end; - -procedure TBitmap.StretchDrawTransparent(DC: HDC; const Rect: TRect; TranspColor: TColor); -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, [TranspColor] - INC EAX - MOV EAX, EBX - JNZ @@2 - CALL StretchDraw - JMP @@exit -@@2: - PUSH EDX - PUSH ECX - CALL GetHandle - TEST EAX, EAX - JZ @@exit2 - - MOV EAX, [TranspColor] - CALL Color2RGB - MOV ECX, [EBX].fTransMaskBmp - JECXZ @@makemask0 - CMP EAX, [EBX].fTransColor - JE @@3 -@@makemask0: - MOV [EBX].fTransColor, EAX - INC ECX - LOOP @@20 - XOR EAX, EAX // pass height = 0 - // absolutely no matter what to pass as width - CALL NewBitmap - MOV [EBX].fTransMaskBmp, EAX -@@20: - MOV EAX, [EBX].fTransMaskBmp - PUSH EAX - MOV EDX, EBX - CALL Assign - POP EAX - MOV EDX, [EBX].fTransColor - CALL Convert2Mask -@@3: - MOV EAX, [EBX].fTransMaskBmp - CALL GetHandle - POP ECX - POP EDX - PUSH EAX - XCHG EAX, EBX - CALL StretchDrawMasked - JMP @@exit -@@exit2: - POP ECX - POP EDX -@@exit: - POP EBX -end; - -procedure TBitmap.StretchDrawMasked(DC: HDC; const Rect: TRect; Mask: HBitmap); -asm - PUSH EDX // [EBP-4] = DC - PUSH ECX // [EBP-8] = Rect - PUSH EBX // save EBX - MOV EBX, EAX // EBX = @ Self - PUSH ESI // save ESI - {$IFDEF FIX_TRANSPBMPPALETTE} - CALL GetPixelFormat - CMP AL, pf4bit - JZ @@draw_fixed - CMP AL, pf8bit - JNZ @@draw_normal - @@draw_fixed: - XOR EAX, EAX - XOR EDX, EDX - CALL NewBitmap - MOV ESI, EAX - MOV EDX, EBX - CALL Assign - MOV EAX, ESI - XOR EDX, EDX - MOV DL, pf32bit - CALL SetPixelFormat - MOV EAX, ESI - MOV EDX, [EBP-4] - MOV ECX, [EBP-8] - PUSH [Mask] - CALL StretchDrawMasked - XCHG EAX, ESI - CALL TObj.RefDec - JMP @@exit - @@draw_normal: - MOV EAX, EBX - {$ENDIF FIX_TRANSPBMPPALETTE} - CALL GetHandle - TEST EAX, EAX - JZ @@to_exit - - PUSH 0 - CALL CreateCompatibleDC - PUSH EAX // [EBP-20] = MaskDC - - PUSH [Mask] - PUSH EAX - CALL SelectObject - PUSH EAX // [EBP-24] = Save4Mask - - CALL StartDC // [EBP-28] = DCfrom; [EBP-32] = Save4From - - PUSH [EBX].fHeight - PUSH [EBX].fWidth - PUSH EAX - CALL CreateCompatibleBitmap - PUSH EAX // [EBP-36] = MemBmp - - PUSH 0 - CALL CreateCompatibleDC - PUSH EAX // [EBP-40] = MemDC - - PUSH dword ptr [EBP-36] //MemBmp - PUSH EAX - CALL SelectObject - PUSH EAX // [EBP-44] = Save4Mem - - PUSH SRCCOPY - MOV EAX, [EBP-20] //MaskDC - CALL @@stretch1 - - PUSH SRCERASE - MOV EAX, [EBP-28] //DCfrom - CALL @@stretch1 - - PUSH 0 - PUSH dword ptr [EBP-4] //DC - CALL SetTextColor - PUSH EAX // [EBP-48] = crText - - PUSH $FFFFFF - PUSH dword ptr [EBP-4] //DC - CALL Windows.SetBkColor - PUSH EAX // [EBP-52] = crBack - - PUSH SRCAND - MOV EAX, [EBP-20] //MaskDC - CALL @@stretch2 - - PUSH SRCINVERT - MOV EAX, [EBP-40] //MemDC - CALL @@stretch2 - - PUSH dword ptr [EBP-4] //DC - CALL Windows.SetBkColor - - PUSH dword ptr [EBP-4] //DC - CALL SetTextColor - - MOV ESI, offset[FinishDC] - CALL ESI - CALL DeleteObject // DeleteObject( MemBmp ) - CALL ESI - CALL ESI -@@to_exit: - STC - JC @@exit - -@@stretch1: - POP ESI - PUSH [EBX].fHeight - PUSH [EBX].fWidth - XOR EDX, EDX - PUSH EDX - PUSH EDX - PUSH EAX - PUSH [EBX].fHeight - PUSH [EBX].fWidth - PUSH EDX - PUSH EDX - PUSH dword ptr [EBP-40] //MemDC - JMP @@stretch3 - -@@stretch2: - POP ESI - PUSH [EBX].fHeight - PUSH [EBX].fWidth - PUSH 0 - PUSH 0 - PUSH EAX - MOV EAX, [EBP-8] //Rect - MOV EDX, [EAX].TRect.Bottom - MOV ECX, [EAX].TRect.Top - SUB EDX, ECX - PUSH EDX - MOV EDX, [EAX].TRect.Right - MOV EAX, [EAX].TRect.Left - SUB EDX, EAX - PUSH EDX - PUSH ECX - PUSH EAX - PUSH dword ptr [EBP-4] //DC -@@stretch3: - CALL StretchBlt - JMP ESI - -@@exit: - POP ESI - POP EBX - MOV ESP, EBP -end; - -procedure DetachBitmapFromCanvas( Sender: PBitmap ); -asm - XOR ECX, ECX - XCHG ECX, [EAX].TBitmap.fCanvasAttached - JECXZ @@exit - PUSH ECX - MOV EAX, [EAX].TBitmap.fCanvas - PUSH [EAX].TCanvas.fHandle - CALL SelectObject -@@exit: -end; - -function TBitmap.GetCanvas: PCanvas; -asm - PUSH EBX - MOV EBX, EAX - CALL GetEmpty - JZ @@exit - MOV EAX, EBX - CALL GetHandle - TEST EAX, EAX - JZ @@exit - MOV ECX, [EBX].fCanvas - INC ECX - LOOP @@ret_Canvas - - MOV [EBX].fApplyBkColor2Canvas, offset[ApplyBitmapBkColor2Canvas] - //CALL CreateCompatibleDC - XOR EAX, EAX - //PUSH EAX - CALL NewCanvas - MOV [EBX].fCanvas, EAX - //MOV [EAX].TCanvas.fIsAlienDC, 0 - MOV [EAX].TCanvas.fOnChangeCanvas.TMethod.Code, offset[CanvasChanged] - MOV [EAX].TCanvas.fOnChangeCanvas.TMethod.Data, EBX - CALL TCanvas.GetBrush - XOR EDX, EDX - MOV ECX, [EBX].fBkColor - JECXZ @@ret_Canvas - CALL TGraphicTool.SetInt - -@@ret_Canvas: - MOV EAX, [EBX].fCanvas - MOV ECX, [EAX].TCanvas.fHandle - INC ECX - LOOP @@attach_Canvas - PUSH EAX - MOV [EBX].fCanvasAttached, ECX - PUSH ECX - CALL CreateCompatibleDC - XCHG EDX, EAX - POP EAX - CALL TCanvas.SetHandle - -@@attach_Canvas: - MOV ECX, [EBX].fCanvasAttached - INC ECX - LOOP @@2 - PUSH [EBX].fHandle - MOV EAX, [EBX].fCanvas - CALL TCanvas.GetHandle - PUSH EAX - CALL SelectObject - MOV [EBX].fCanvasAttached, EAX - -@@2: MOV [EBX].fDetachCanvas, offset[DetachBitmapFromCanvas] - MOV EAX, [EBX].fCanvas -@@exit: POP EBX -end; - -function TBitmap.GetEmpty: Boolean; -asm - PUSH ECX - MOV ECX, [EAX].fWidth - JECXZ @@1 - MOV ECX, [EAX].fHeight -@@1: TEST ECX, ECX - POP ECX - SETZ AL -end; - -procedure TBitmap.LoadFromFile(const Filename: KOLString); -asm - PUSH EAX - XCHG EAX, EDX - CALL NewReadFileStream - XCHG EDX, EAX - POP EAX - PUSH EDX - CALL LoadFromStream - POP EAX - CALL TObj.RefDec -end; - -function TBitmap.ReleaseHandle: HBitmap; -asm - PUSH EBX - MOV EBX, EAX - XOR EDX, EDX - CALL SetHandleType - MOV EAX, EBX - CALL GetHandle - TEST EAX, EAX - JZ @@exit - - CMP [EBX].fDIBAutoFree, 0 - JZ @@1 - MOV EAX, [EBX].fDIBSize - PUSH EAX - PUSH EAX - PUSH GMEM_FIXED {or GMEM_ZEROINIT} - CALL GlobalAlloc - MOV EDX, EAX - XCHG EAX, [EBX].fDIBBits - POP ECX - CALL System.Move -@@1: - XOR EAX, EAX - MOV [EBX].fDIBAutoFree, AL - XCHG EAX, [EBX].fHandle - -@@exit: POP EBX -end; - -procedure TBitmap.SaveToFile(const Filename: KOLString); -asm - PUSH EAX - PUSH EDX - CALL GetEmpty - POP EAX - JZ @@exit - CALL NewWriteFileStream - XCHG EDX, EAX - POP EAX - PUSH EDX - CALL SaveToStream - POP EAX - CALL TObj.RefDec - PUSH EAX -@@exit: POP EAX -end; - -procedure TBitmap.SetHandle(const Value: HBitmap); -const szB = sizeof( tagBitmap ); - szDIB = sizeof( TDIBSection ); - szBIH = sizeof( TBitmapInfoHeader ); // = 40 -asm - PUSH EBX - MOV EBX, EAX - PUSH EDX - CALL Clear - POP ECX - TEST ECX, ECX - JZ @@exit - PUSH ECX - ADD ESP, -szDIB - - CALL WinVer - CMP AL, wvNT - JB @@ddb - - PUSH ESP - PUSH szDIB - PUSH ECX - CALL GetObject - CMP EAX, szDIB - JNZ @@ddb - - MOV [EBX].fHandleType, 0 - MOV EAX, [ESP].TDIBSection.dsBm.bmWidth - MOV [EBX].fWidth, EAX - MOV EDX, [ESP].TDIBSection.dsBm.bmHeight - MOV [EBX].fHeight, EDX - MOVZX ECX, [ESP].TDIBSection.dsBm.bmBitsPixel - CALL PrepareBitmapHeader - MOV [EBX].fDIBHeader, EAX - LEA EDX, [EAX].TBitmapInfo.bmiColors - LEA EAX, [ESP].TDIBSection.dsBitfields - XOR ECX, ECX - MOV CL, 12 - CALL System.Move - - MOV EDX, [ESP].TDIBSection.dsBm.bmBits - MOV [EBX].fDIBBits, EDX - MOV EDX, [ESP].TDIBSection.dsBmih.biSizeImage - MOV [EBX].fDIBSize, EDX - MOV [EBX].fDIBAutoFree, 1 - ADD ESP, szDIB - POP [EBX].fHandle - JMP @@exit - -@@ddb: - MOV ECX, [ESP+szDIB] - PUSH ESP - PUSH szB - PUSH ECX - CALL GetObject - POP EDX - POP EDX // bmWidth - POP ECX // bmHeight - ADD ESP, szDIB-12 - TEST EAX, EAX - JZ @@exit - MOV [EBX].fWidth, EDX - MOV [EBX].fHeight, ECX - POP dword ptr [EBX].fHandle - MOV [EBX].fHandleType, 1 -@@exit: POP EBX -end; - -procedure TBitmap.SetHeight(const Value: Integer); -var - pf : TPixelFormat; -asm - CMP EDX, [EAX].fHeight - JE @@exit - - PUSHAD - CALL GetPixelFormat - MOV pf, AL - POPAD - - PUSHAD - XOR EDX, EDX - INC EDX - CALL SetHandleType - POPAD - MOV [EAX].fHeight, EDX - CALL FormatChanged - - PUSHAD - MOV DL, pf - CALL SetPixelFormat - POPAD -@@exit: -end; - -procedure TBitmap.SetPixelFormat(Value: TPixelFormat); -asm - PUSH EBX - MOV EBX, EAX - CALL GetEmpty // if Empty then Exit; - JZ @@exit // - MOV EAX, EBX // - PUSH EDX - CALL GetPixelFormat - POP EDX - CMP EAX, EDX - JE @@exit - TEST EDX, EDX - MOV EAX, EBX - JNE @@2 - POP EBX - INC EDX // EDX = bmDDB - JMP SetHandleType -@@2: - MOV [EBX].fNewPixelFormat, DL -@@3: - XOR EDX, EDX - CALL SetHandleType - XCHG EAX, EBX - CMP EAX, 0 -@@exit: - POP EBX - JNE FormatChanged -end; - -function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer; -asm - MOVZX EDX, [EAX].TBitmapInfoHeader.biBitCount - MOV EAX, [EAX].TBitmapInfoHeader.biWidth - MUL EDX - ADD EAX, 31 - SHR EAX, 3 - AND EAX, -4 -end; - -procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer ); -asm - PUSH EBX - PUSH ESI - XCHG EAX, EBX - PUSH EDX // [EBP-12] = DC2 - PUSH ECX // [EBP-16] = oldWidth - MOV EAX, [EBX].TBitmap.fBkColor - CALL Color2RGB - TEST EAX, EAX - JZ @@exit - XCHG ESI, EAX // ESI = Color2RGB( Bmp.fBkColor ) - MOV EAX, EBX - CALL TBitmap.GetHandle - TEST EAX, EAX - JZ @@exit - PUSH EAX //fHandle - PUSH dword ptr [EBP-12] //DC2 - CALL SelectObject - PUSH EAX // [EBP-20] = oldBmp - PUSH ESI - CALL CreateSolidBrush - XCHG ESI, EAX // ESI = Br - PUSH [EBX].TBitmap.fHeight - PUSH [EBX].TBitmap.fWidth - MOV EAX, [oldHeight] - MOV EDX, [EBP-16] //oldWidth - CMP EAX, [EBX].TBitmap.fHeight - JL @@fill - CMP EDX, [EBX].TBitmap.fWidth - JGE @@nofill -@@fill: CMP EAX, [EBX].TBitmap.fHeight - JNE @@1 - XOR EAX, EAX -@@1: - CMP EDX, [EBX].TBitmap.fWidth - JNZ @@2 - CDQ -@@2: PUSH EAX - PUSH EDX - - MOV EDX, ESP - PUSH ESI - PUSH EDX - PUSH dword ptr [EBP-12] //DC2 - CALL Windows.FillRect - POP ECX - POP ECX -@@nofill: - POP ECX - POP ECX - PUSH ESI //Br - CALL DeleteObject - PUSH dword ptr [EBP-12] //DC2 - CALL SelectObject -@@exit: - POP ECX - POP EDX - POP ESI - POP EBX -end; - -procedure TBitmap.FormatChanged; -type tBIH = TBitmapInfoHeader; - tBmp = tagBitmap; -const szBIH = Sizeof( tBIH ); - szBmp = Sizeof( tBmp ); -asm - PUSH EAX - CALL GetEmpty - POP EAX - JZ @@exit - PUSHAD - MOV EBX, EAX - CALL [EBX].fDetachCanvas - XOR EAX, EAX - MOV [EBX].fScanLineSize, EAX - MOV [EBX].fGetDIBPixels, EAX - MOV [EBX].fSetDIBPixels, EAX - MOV ESI, [EBX].fWidth // ESI := oldWidth - MOV EDI, [EBX].fHeight // EDI := oldHeight - MOV ECX, [EBX].fDIBBits - JECXZ @@noDIBBits - MOV EAX, [EBX].fDIBHeader - MOV ESI, [EAX].TBitmapInfo.bmiHeader.biWidth - MOV EDI, [EAX].TBitmapInfo.bmiHeader.biHeight - TEST EDI, EDI - JGE @@1 - NEG EDI -@@1: JMP @@createDC2 -@@noDIBBits: - MOV ECX, [EBX].fHandle - JECXZ @@createDC2 - ADD ESP, -24 // -szBmp - PUSH ESP - PUSH 24 //szBmp - PUSH ECX - CALL GetObject - XCHG ECX, EAX - JECXZ @@2 - MOV ESI, [ESP].tBmp.bmWidth - MOV EDI, [ESP].tBmp.bmHeight -@@2: ADD ESP, 24 //szBmp -@@createDC2: - PUSH 0 - CALL CreateCompatibleDC - PUSH EAX // > DC2 - CMP [EBX].fHandleType, bmDDB - JNE @@DIB_handle_type - PUSH 0 - CALL GetDC - PUSH EAX // > DC0 - PUSH [EBX].fHeight - PUSH [EBX].fWidth - PUSH EAX - CALL CreateCompatibleBitmap - XCHG EBP, EAX // EBP := NewHandle - PUSH 0 - CALL ReleaseDC // < - POP EDX - PUSH EDX // EDX := DC2 - PUSH EBP - PUSH EDX - CALL SelectObject - PUSH EAX // > OldBmp - PUSH [EBX].fHeight // prepare Rect(0,0,fWidth,fHeight) - PUSH [EBX].fWidth - PUSH 0 - PUSH 0 - MOV EAX, [EBX].fBkColor - CALL Color2RGB - PUSH EAX - CALL CreateSolidBrush - MOV EDX, ESP - PUSH EAX // > Br - PUSH EAX - PUSH EDX - PUSH dword ptr [ESP+32] // (DC2) - CALL Windows.FillRect - CALL DeleteObject // < - ADD ESP, 16 // remove Rect - MOV ECX, [EBX].fDIBBits - JECXZ @@draw - PUSH dword ptr [ESP+4] // (DC2) - CALL SelectObject // < (OldBmp) - PUSH DIB_RGB_COLORS // : DIB_RGB_COLORS - PUSH [EBX].fDIBHeader // : fDIBHeader - PUSH [EBX].fDIBBits // : fDIBBits - PUSH [EBX].fHeight // : fHeight - PUSH 0 // : 0 - PUSH EBP // : NewHandle - PUSH dword ptr [ESP+24] // (DC2) - CALL SetDIBits - JMP @@clearData -@@draw: - MOV EDX, [ESP+4] - PUSH EDX // prepare DC2 for SelectObject - MOV EAX, EBX - XOR ECX, ECX - PUSH ECX - CALL Draw - CALL SelectObject -@@clearData: - MOV EAX, EBX - CALL ClearData - MOV [EBX].fHandle, EBP - - JMP @@fillBkColor - -@@DIB_handle_type: // [ESP] = DC2 - MOVZX EAX, [EBX].fNewPixelFormat -@@getBitsPixel: - XCHG ECX, EAX - MOV CL, [ECX] + offset BitCounts - MOVZX EAX, [DefaultPixelFormat] - JECXZ @@getBitsPixel - XOR EBP, EBP // NewHandle := 0 - MOV EAX, [EBX].fWidth // EAX := fWidth - MOV EDX, [EBX].fHeight // EDX := fHeight - CALL PrepareBitmapHeader - PUSH EAX // > NewHeader - CMP [EBX].fNewPixelFormat, pf16bit - JNE @@newHeaderReady - CALL PreparePF16bit -@@newHeaderReady: - POP EAX - PUSH EAX - CALL CalcScanLineSize - MOV EDX, [EBX].fHeight - MUL EDX - PUSH EAX // > sizeBits - - PUSH EAX - PUSH GMEM_FIXED - CALL GlobalAlloc - - PUSH EAX // > NewBits - PUSH DIB_RGB_COLORS - PUSH dword ptr [ESP+12] // (NewHeader) - PUSH EAX - MOV EAX, [EBX].fHeight - CMP EAX, EDI - {$IFDEF USE_CMOV} - CMOVG EAX, EDI - {$ELSE} - JLE @@3 - MOV EAX, EDI -@@3: {$ENDIF} - - PUSH EAX - PUSH 0 - MOV EAX, EBX - CALL GetHandle - PUSH EAX - PUSH dword ptr [ESP+36] // (DC2) - CALL GetDIBits - - MOV EDX, [EBX].fHeight - CMP EDX, EDI - {$IFDEF USE_CMOV} - CMOVG EDX, EDI - {$ELSE} - JLE @@30 - MOV EDX, EDI -@@30: {$ENDIF} - - CMP EAX, EDX - JE @@2clearData - - CALL GlobalFree - - XOR EAX, EAX - PUSH EAX - - MOV EDX, ESP // EDX = @NewBits - MOV ECX, [ESP+8] // ECX = @NewHeader - PUSH EAX // -> 0 - PUSH EAX // -> 0 - PUSH EDX // -> @NewBits - PUSH DIB_RGB_COLORS // -> DIB_RGB_COLORS - PUSH ECX // -> @NewHeader - PUSH dword ptr [ESP+32] // -> DC2 - CALL CreateDIBSection - - XOR ESI, -1 // use OldWidth to store NewDIBAutoFree flag - - XCHG EBP, EAX // EBP := NewHandle - PUSH EBP - PUSH dword ptr [ESP+16] // -> DC2 - CALL SelectObject - PUSH EAX // save oldBmp - MOV EDX, [ESP+16] // DC2 -> EDX (DC) - XOR ECX, ECX // 0 -> ECX (X) - PUSH ECX // 0 -> stack (Y) - MOV EAX, EBX - CALL TBitmap.Draw - PUSH dword ptr [ESP+16] // -> DC2 - CALL SelectObject - -@@2clearData: - MOV EAX, EBX - CALL ClearData - - POP [EBX].fDIBBits - POP [EBX].fDIBSize - POP [EBX].fDIBHeader - MOV [EBX].fHandle, EBP - - TEST ESI, ESI - MOV [EBX].fDIBAutoFree, 0 - JGE @@noDIBautoFree - INC [EBX].fDIBAutoFree -@@noDIBautoFree: - -@@fillBkColor: - MOV ECX, [EBX].fFillWithBkColor - JECXZ @@deleteDC2 - POP EDX // (DC2) - PUSH EDX - PUSH EDI - XCHG ECX, ESI - XCHG EAX, EBX - CALL ESI -@@deleteDC2: - CALL DeleteDC - POPAD -@@exit: -end; - -function TBitmap.GetScanLine(Y: Integer): Pointer; -asm - MOV ECX, [EAX].fDIBHeader - JECXZ @@exit - MOV ECX, [ECX].TBitmapInfoHeader.biHeight - TEST ECX, ECX - JL @@1 - - SUB ECX, EDX - DEC ECX - MOV EDX, ECX - -@@1: MOV ECX, [EAX].fScanLineSize - INC ECX - PUSH [EAX].fDIBBits - LOOP @@2 - - PUSH EDX - CALL GetScanLineSize - POP EDX - XCHG ECX, EAX - -@@2: XCHG EAX, ECX - MUL EDX - POP ECX - ADD ECX, EAX - -@@exit: XCHG EAX, ECX -end; - -function TBitmap.GetScanLineSize: Integer; -asm - MOV ECX, [EAX].fDIBHeader - JECXZ @@exit - - PUSH EAX - XCHG EAX, ECX - CALL CalcScanLineSize - XCHG ECX, EAX - POP EAX - MOV [EAX].fScanLineSize, ECX - -@@exit: XCHG EAX, ECX -end; - -procedure TBitmap.CanvasChanged( Sender : PObj ); -asm - PUSH EAX - - XCHG EAX, EDX - CALL TCanvas.GetBrush - MOV EDX, [EAX].TGraphicTool.fData.Color - - POP EAX - MOV [EAX].fBkColor, EAX - CALL ClearTransImage -end; - -procedure TBitmap.Dormant; -asm - PUSH EAX - CALL RemoveCanvas - POP EAX - MOV ECX, [EAX].fHandle - JECXZ @@exit - CALL ReleaseHandle - PUSH EAX - CALL DeleteObject -@@exit: -end; - -procedure TBitmap.SetBkColor(const Value: TColor); -asm - CMP [EAX].fBkColor, EDX - JE @@exit - MOV [EAX].fBkColor, EDX - MOV [EAX].fFillWithBkColor, offset[FillBmpWithBkColor] - MOV ECX, [EAX].fApplyBkColor2Canvas - JECXZ @@exit - CALL ECX -@@exit: -end; - -function TBitmap.Assign(SrcBmp: PBitmap): Boolean; -const szBIH = sizeof(TBitmapInfoHeader); -asm - PUSHAD - XCHG EBX, EAX -@@clear: - MOV ESI, EDX - MOV EAX, EBX - CALL Clear - MOV EAX, ESI - OR EAX, EAX - JZ @@exit - CALL GetEmpty - JZ @@exit - MOV EAX, [ESI].fWidth - MOV [EBX].fWidth, EAX - MOV EAX, [ESI].fHeight - MOV [EBX].fHeight, EAX - MOVZX ECX, [ESI].fHandleType - MOV [EBX].fHandleType, CL - JECXZ @@fmtDIB - - DEC ECX // ECX = 0 - PUSH ECX - PUSH ECX - PUSH ECX - PUSH ECX //IMAGE_BITMAP=0 - PUSH [ESI].fHandle - CALL CopyImage - MOV [EBX].fHandle, EAX - TEST EAX, EAX - XCHG EDX, EAX - JZ @@clear - JMP @@exit - -@@fmtDIB: - XCHG EAX, ECX - MOV AX, szBIH+1024 - PUSH EAX - CALL System.@GetMem - MOV [EBX].fDIBHeader, EAX - XCHG EDX, EAX - POP ECX - MOV EAX, [ESI].fDIBHeader - CALL System.Move - MOV EAX, [ESI].fDIBSize - MOV [EBX].fDIBSize, EAX - PUSH EAX - PUSH EAX - PUSH GMEM_FIXED - CALL GlobalAlloc - MOV [EBX].fDIBBits, EAX - XCHG EDX, EAX - POP ECX - MOV EAX, [ESI].fDIBBits - CALL System.Move - - INC EBX // reset "ZF" - -@@exit: - POPAD - SETNZ AL -end; - -procedure TBitmap.RemoveCanvas; -asm - PUSH EAX - CALL [EAX].fDetachCanvas - POP EDX - XOR EAX, EAX - XCHG EAX, [EDX].fCanvas - CALL TObj.RefDec -end; - -function TBitmap.DIBPalNearestEntry(Color: TColor): Integer; -const szBIH = sizeof(TBitmapInfoHeader); -asm - PUSH EBX - PUSH ESI - PUSH EDI - XCHG ESI, EAX - XCHG EAX, EDX - CALL Color2RGBQuad - XCHG EDI, EAX - MOV EAX, ESI - CALL GetDIBPalEntryCount - XCHG ECX, EAX - XOR EAX, EAX - JECXZ @@exit - - MOV ESI, [ESI].fDIBHeader - ADD ESI, szBIH - XOR EDX, EDX - PUSH EDX - DEC DX - -@@loo: LODSD - XOR EAX, EDI - MOV EBX, EAX - SHR EBX, 16 - MOV BH, 0 - ADD AL, AH - MOV AH, 0 - ADC AX, BX - CMP AX, DX - JAE @@1 - MOV DX, AX - POP EBX - PUSH EDX // save better index (in high order word) -@@1: ADD EDX, $10000 // increment index - LOOP @@loo - - XCHG EAX, ECX - POP AX - POP AX -@@exit: - POP EDI - POP ESI - POP EBX -end; - -function TBitmap.GetDIBPalEntries(Idx: Integer): TColor; -const szBIH = sizeof(TBitmapInfoHeader); -asm - MOV ECX, [EAX].fDIBHeader - JECXZ @@exit - - MOV ECX, [ECX+szBIH+EDX*4] - INC ECX - -@@exit: DEC ECX - XCHG EAX, ECX -end; - -function TBitmap.GetDIBPalEntryCount: Integer; -asm - PUSH EAX - CALL GetEmpty - POP EAX - JZ @@ret0 - CALL GetPixelFormat - MOVZX ECX, AL - MOV EAX, ECX - LOOP @@1 - // pf1bit: - INC EAX - RET -@@1: - LOOP @@2 - // pf4bit: - MOV AL, 16 - RET -@@2: - LOOP @@ret0 - // pf8bit: - XOR EAX, EAX - INC AH - RET -@@ret0: - XOR EAX, EAX -end; - -procedure TBitmap.ClearTransImage; -asm - OR [EAX].fTransColor, -1 - XOR EDX, EDX - XCHG [EAX].fTransMaskBmp, EDX - XCHG EAX, EDX - CALL TObj.RefDec -end; - -{$IFDEF USE_OLDCONVERT2MASK} -procedure TBitmap.Convert2Mask(TranspColor: TColor); -asm - PUSH EBX - PUSH ESI - MOV EBX, EAX - MOV ESI, EDX - CALL GetHandle - TEST EAX, EAX - JZ @@exit - - PUSH 0 - PUSH 1 - PUSH 1 - PUSH [EBX].fHeight - PUSH [EBX].fWidth - CALL CreateBitmap - PUSH EAX // MonoHandle - PUSH 0 - CALL CreateCompatibleDC - POP EDX - PUSH EDX - PUSH EAX // MonoDC - - PUSH EDX - PUSH EAX - CALL SelectObject - PUSH EAX // SaveMono - - CALL StartDC // DCfrom, SaveFrom - XCHG EAX, ESI - CALL Color2RGB - PUSH EAX // Color2RGB(TranspColor) - PUSH dword ptr [ESP+8] //DCfrom - CALL Windows.SetBkColor - PUSH EAX // SaveBkColor - - PUSH SRCCOPY - PUSH 0 - PUSH 0 - PUSH dword ptr [ESP+12+4+4] //DCfrom - PUSH [EBX].fHeight - PUSH [EBX].fWidth - PUSH 0 - PUSH 0 - PUSH dword ptr [ESP+32+16] //MonoDC - CALL BitBlt - - PUSH dword ptr [ESP+8] //DCfrom - CALL Windows.SetBkColor // ESP-> SaveFrom - CALL FinishDC // ESP-> SaveMono - CALL FinishDC // ESP-> MonoHandle - - MOV EAX, EBX - CALL ClearData - POP [EBX].fHandle - MOV [EBX].fHandleType, bmDDB -@@exit: - POP ESI - POP EBX -end; -{$ELSE USE_OLDCONVERT2MASK} //Pascal -procedure TBitmap.Convert2Mask(TranspColor: TColor); -asm - PUSH EBX - PUSH ESI - PUSH EBP - PUSH EDI - XCHG EBP, EAX // EBP = @ Self - XCHG EAX, EDX // EAX = TranspColor - CALL Color2RGB - XCHG EBX, EAX // EBX := Color2RGB( TranspColor ); - MOV EAX, EBP // EAX := @ Self; - CALL GetPixelFormat - CMP AL, pf15bit - JB @@SwapRB - CMP AL, pf24bit - JB @@noSwapRB -@@SwapRB: - BSWAP EBX - SHR EBX, 8 -@@noSwapRB: - MOV DL, pf4bit - CMP AL, DL - JB @@setpixelformat -@@1: MOV DL, pf32bit - CMP AL, DL - JBE @@translate -@@setpixelformat: - MOV EAX, EBP - CALL SetPixelFormat -@@translate: - MOV EAX, [EBP].fWidth - MOV EDX, [EBP].fHeight - MOV CL, pf1bit - CALL NewDibBitmap - PUSH EAX - XOR EDX, EDX - INC EDX - MOV ECX, $FFFFFF - CALL SetDIBPalEntries - XOR EDX, EDX -@@Yloop:CMP EDX, [EBP].fHeight - JGE @@exit - PUSH EDX - MOV EAX, EBP - CALL GetScanLine - XCHG ESI, EAX - MOV EAX, [ESP+4] - POP EDX - PUSH EDX - CALL GetScanLine - XCHG EDI, EAX - MOV EAX, EBP - CALL GetPixelFormat - MOVZX ECX, AL - SUB ECX, pf4bit - MOV DL, 8 - JNE @@chk_pf8bit - //-------- pf4bit: - CMP dword ptr [ESP], 0 - JNZ @@4_0 - XOR EDX, EDX -@@4_searchentry: - PUSH EDX - MOV EAX, EBP //[ESP+8] - CALL GetDIBPalEntries - CMP EAX, EBX - POP EDX - JZ @@4_foundentry - INC EDX - CMP EDX, 16 - JB @@4_searchentry -@@4_foundentry: - XCHG EBX, EDX - MOV DL, 8 -@@4_0: MOV ECX, [EBP].fWidth - INC ECX - SHR ECX, 1 -@@Xloop_pf4bit: - MOV AH, [ESI] - SHR AH, 4 - CMP AH, BL - SETZ AH - SHL AL, 1 - OR AL, AH - MOV AH, [ESI] - AND AH, $0F - CMP AH, BL - SETZ AH - SHL AL, 1 - OR AL, AH - DEC DL - DEC DL - JNZ @@4_1 - STOSB - MOV DL, 8 -@@4_1: INC ESI - LOOP @@Xloop_pf4bit - JMP @@nextline -@@chk_pf8bit: - LOOP @@chk_pf15bit - //-------- pf4bit: - CMP dword ptr [ESP], 0 - JNZ @@8_0 - XOR EDX, EDX -@@8_searchentry: - PUSH EDX - MOV EAX, EBP //[ESP+8] - CALL GetDIBPalEntries - CMP EAX, EBX - POP EDX - JZ @@8_foundentry - INC DL - JNZ @@8_searchentry -@@8_foundentry: - XCHG EBX, EDX - MOV DL, 8 -@@8_0: MOV ECX, [EBP].fWidth - INC ECX -@@Xloop_pf8bit: - CMP BL, [ESI] - SETZ AH - SHL AL, 1 - OR AL, AH - DEC DL - JNZ @@8_1 - STOSB - MOV DL, 8 -@@8_1: INC ESI - LOOP @@Xloop_pf8bit - JMP @@nextline -@@chk_pf15bit: - LOOP @@chk_pf16bit - //-------- pf15bit: - CMP dword ptr [ESP], 0 - JNZ @@15_0 - XCHG EAX, EBX - PUSH EDX - CALL Color2Color15 - POP EDX - XCHG EBX, EAX -@@15_0: MOV ECX, [EBP].fWidth -@@Xloop_pf15bit: - CMP word ptr [ESI], BX - SETZ AH - SHL AL, 1 - OR AL, AH - DEC DL - JNZ @@15_1 - STOSB - MOV DL, 8 -@@15_1: ADD ESI, 2 - LOOP @@Xloop_pf15bit - JMP @@nextline -@@chk_pf16bit: - LOOP @@chk_pf24bit - //-------- pf16bit: - CMP dword ptr [ESP], 0 - JNZ @@16_0 - XCHG EAX, EBX - PUSH EDX - CALL Color2Color16 - POP EDX - XCHG EBX, EAX -@@16_0: MOV ECX, [EBP].fWidth -@@Xloop_pf16bit: - CMP word ptr [ESI], BX - SETZ AH - SHL AL, 1 - OR AL, AH - DEC DL - JNZ @@16_1 - STOSB - MOV DL, 8 -@@16_1: ADD ESI, 2 - LOOP @@Xloop_pf16bit - JMP @@nextline -@@chk_pf24bit: - LOOP @@chk_pf32bit - //-------- pf24bit: - MOV ECX, [EBP].fWidth - PUSH EBP - //AND EBX, $FFFFFF -@@Xloop_pf24bit: - MOV EBP, dword ptr [ESI] - AND EBP, $FFFFFF - CMP EBP, EBX - SETZ AH - SHL AL, 1 - OR AL, AH - DEC DL - JNZ @@24_1 - STOSB - MOV DL, 8 -@@24_1: ADD ESI, 3 - LOOP @@Xloop_pf24bit - POP EBP - JMP @@nextline -@@chk_pf32bit: - //-------- pf32bit: - MOV ECX, [EBP].fWidth -@@Xloop_pf32bit: - and dword ptr [ESI], $FFFFFF - CMP EBX, dword ptr [ESI] - SETZ AH - SHL AL, 1 - OR AL, AH - DEC DL - JNZ @@32_1 - STOSB - MOV DL, 8 -@@32_1: ADD ESI, 4 - LOOP @@Xloop_pf32bit -@@nextline: - TEST DL, DL - JZ @@nx1 - CMP DL, 8 - JE @@nx1 -@@finloop1: - SHL AL, 1 - DEC DL - JNZ @@finloop1 - STOSB -@@nx1: - POP EDX - INC EDX - JMP @@Yloop -@@exit: - POP EDX - PUSH EDX - XCHG EAX, EBP - CALL Assign - POP EAX - CALL TObj.RefDec - POP EDI - POP EBP - POP ESI - POP EBX -end; -{$ENDIF USE_OLDCONVERT2MASK} //Pascal - -procedure _PrepareBmp2Rotate; -const szBIH = sizeof(TBitmapInfoHeader); -asm - { <- BL = increment to height } - XCHG EDI, EAX - MOV ESI, EDX // ESI = SrcBmp - - XCHG EAX, EDX - CALL TBitmap.GetPixelFormat - MOVZX ECX, AL - PUSH ECX - - MOV EDX, [ESI].TBitmap.fWidth - MOVZX EBX, BL - ADD EDX, EBX - - MOV EAX, [ESI].TBitmap.fHeight - CALL NewDIBBitmap - STOSD - XCHG EDI, EAX - - MOV EAX, [ESI].TBitmap.fDIBHeader - ADD EAX, szBIH - MOV EDX, [EDI].TBitmap.fDIBHeader - ADD EDX, szBIH - XOR ECX, ECX - MOV CH, 4 - CALL System.Move - - MOV EAX, EDI - XOR EDX, EDX - CALL TBitmap.GetScanLine - MOV EBX, [EDI].TBitmap.fWidth - DEC EBX // EBX = DstBmp.fWidth - 1 - XCHG EDI, EAX // EDI = DstBmp.ScanLine[ 0 ] - - XOR EDX, EDX - INC EDX - CALL TBitmap.GetScanLine - XCHG EDX, EAX - SUB EDX, EDI // EDX = BytesPerDstLine - - MOV EBP, [ESI].TBitmap.fWidth - DEC EBP // EBP = SrcBmp.fWidth - 1 - - POP ECX // ECX = PixelFormat -end; -procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap ); -const szBIH = sizeof(TBitmapInfoHeader); -asm - PUSHAD - MOV BL, 7 - CALL _PrepareBmp2Rotate - - SHR EBP, 3 - SHL EBP, 8 // EBP = (WBytes-1) * 256 - - MOV ECX, EBX // ECX and 7 = Shf - SHR EBX, 3 - ADD EDI, EBX // EDI = Dst - - XOR EBX, EBX // EBX = temp mask - XOR EAX, EAX // Y = 0 -@@looY: - PUSH EAX - PUSH EDI // Dst1 = Dst (Dst1 in EDI, Dst saved) - PUSH ESI // SrcBmp - - PUSH EDX //BytesPerDstLine - PUSH ECX //Shf - - XCHG EDX, EAX - XCHG EAX, ESI - CALL TBitmap.GetScanLine - XCHG ESI, EAX // ESI = Src - - POP ECX // CL = Shf - AND ECX, 7 // ECX = Shf - OR ECX, EBP // ECX = (Wbytes-1)*8 + Shf - POP EDX // EDX = BytesPerDstLine - - MOV BH, $80 - SHR EBX, CL // BH = mask, BL = mask & Tmp -@@looX: - XOR EAX, EAX - - LODSB - - MOV AH, AL - SHR EAX, CL - OR EAX,$01000000 - -@@looBits: - MOV BL, AH - AND BL, BH - OR [EDI], BL - ADD EDI, EDX - ADD EAX, EAX - JNC @@looBits - - SUB ECX, 256 - JGE @@looX - - POP ESI // ESI = SrcBmp - POP EDI // EDI = Dst - POP EAX // EAX = Y - - ADD ECX, 256-1 - JGE @@1 - DEC EDI -@@1: - INC EAX - CMP EAX, [ESI].TBitmap.fHeight - JL @@looY - - POPAD -end; - -procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); -const szBIH = sizeof(TBitmapInfoHeader); -asm - PUSHAD - MOV BL, 1 - CALL _PrepareBmp2Rotate - - SHR EBP, 1 // EBP = WBytes - 1 - SHL EBP, 8 // EBP = (WBytes - 1) * 256 - - // EBX = DstBmp.fWidth - 1 - MOV ECX, EBX - SHL ECX, 2 // ECX and 7 = Shf (0 or 4) - SHR EBX, 1 - ADD EDI, EBX // EDI = Dst - - XOR EAX, EAX // Y = 0 - XOR EBX, EBX - -@@looY: - PUSH EAX // save Y - PUSH EDI // Dst1 = Dst (Dst1 in EDI, Dst saved) - PUSH ESI // SrcBmp - - PUSH EDX // BytesPerDstLine - PUSH ECX // Shf - - XCHG EDX, EAX - XCHG EAX, ESI - CALL TBitmap.GetScanLine - XCHG ESI, EAX // ESI = Src - - POP ECX - AND ECX, 7 // CL = Shf - OR ECX, EBP // ECX = (WBytes-1)*256 + Shf - POP EDX // EDX = BytesPerDstLine - - MOV BH, $F0 - SHR EBX, CL // shift mask right 4 or 0 - -@@looX: - XOR EAX, EAX - LODSB - MOV AH, AL - SHR EAX, CL - - MOV BL, AH - AND BL, BH - OR [EDI], BL - ADD EDI, EDX - - SHL EAX, 4 - AND AH, BH - OR [EDI], AH - ADD EDI, EDX - - SUB ECX, 256 - JGE @@looX - - POP ESI // ESI = SrcBmp - POP EDI // EDI = Dst - POP EAX // EAX = Y - - ADD ECX, 256 - 4 - JGE @@1 - - DEC EDI -@@1: - INC EAX - CMP EAX, [ESI].TBitmap.fHeight - JL @@looY - - POPAD -end; - -procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); -const szBIH = sizeof(TBitmapInfoHeader); -asm - PUSHAD - XOR EBX, EBX - CALL _PrepareBmp2Rotate - - ADD EDI, EBX // EDI = Dst - - MOV EBX, EDX // EBX = BytesPerDstLine - DEC EBX - MOV EBP, ESI // EBP = SrcBmp - - XOR EDX, EDX // Y = 0 - -@@looY: - PUSH EDX - PUSH EDI - - MOV EAX, EBP - CALL TBitmap.GetScanLine - XCHG ESI, EAX - MOV ECX, [EBP].TBitmap.fWidth - -@@looX: - MOVSB - ADD EDI, EBX - LOOP @@looX - - POP EDI - POP EDX - - DEC EDI - INC EDX - CMP EDX, [EBP].TBitmap.fHeight - JL @@looY - - POPAD -end; - -procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); -asm - PUSHAD - XOR EBX, EBX - CALL _PrepareBmp2Rotate - - ADD EBX, EBX - ADD EDI, EBX // EDI = Dst - MOV EBX, EDX // EBX = BytesPerDstLine - DEC EBX - DEC EBX - MOV EBP, ESI // EBP = SrcBmp - - XOR EDX, EDX // Y = 0 - -@@looY: - PUSH EDX - PUSH EDI - - MOV EAX, EBP - CALL TBitmap.GetScanLine - XCHG ESI, EAX - MOV ECX, [EBP].TBitmap.fWidth - -@@looX: - MOVSW - ADD EDI, EBX - LOOP @@looX - - POP EDI - POP EDX - - DEC EDI - DEC EDI - INC EDX - CMP EDX, [EBP].TBitmap.fHeight - JL @@looY - - POPAD -end; - -procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); -asm - PUSHAD - XOR EBX, EBX - CALL _PrepareBmp2Rotate - - SUB ECX, pf24bit - JNZ @@10 - LEA EBX, [EBX+EBX*2] - JMP @@11 -@@10: - LEA EBX, [EBX*4] -@@11: ADD EDI, EBX // EDI = Dst - - MOV EBX, EDX // EBX = BytesPerDstLine - DEC EBX - DEC EBX - DEC EBX - - MOV EBP, ESI // EBP = SrcBmp - - XOR EDX, EDX // Y = 0 - -@@looY: - PUSH EDX - PUSH EDI - PUSH ECX // ECX = 0 if pf24bit (1 if pf32bit) - - MOV EAX, EBP - CALL TBitmap.GetScanLine - XCHG ESI, EAX - MOV ECX, [EBP].TBitmap.fWidth - POP EAX - PUSH EAX - -@@looX: - MOVSW - MOVSB - ADD ESI, EAX - ADD EDI, EBX - LOOP @@looX - - POP ECX - POP EDI - POP EDX - - DEC EDI - DEC EDI - DEC EDI - SUB EDI, ECX - INC EDX - CMP EDX, [EBP].TBitmap.fHeight - JL @@looY - - POPAD -end; - -procedure _RotateBitmapRight( SrcBmp: PBitmap ); -asm - PUSH EBX - PUSH EDI - MOV EBX, EAX - CMP [EBX].TBitmap.fHandleType, bmDIB - JNZ @@exit - - CALL TBitmap.GetPixelFormat - MOVZX ECX, AL - LOOP @@not1bit - MOV EAX, [RotateProcs.proc_RotateBitmapMono] -@@not1bit: - LOOP @@not4bit - MOV EAX, [RotateProcs.proc_RotateBitmap4bit] -@@not4bit: - LOOP @@not8bit - MOV EAX, [RotateProcs.proc_RotateBitmap8bit] -@@not8bit: - LOOP @@not15bit - INC ECX -@@not15bit: - LOOP @@not16bit - MOV EAX, [RotateProcs.proc_RotateBitmap16bit] -@@not16bit: - LOOP @@not24bit - INC ECX -@@not24bit: - LOOP @@not32bit - MOV EAX, [RotateProcs.proc_RotateBitmap2432bit] -@@not32bit: - TEST EAX, EAX - JZ @@exit - - PUSH ECX - XCHG ECX, EAX - MOV EAX, ESP - MOV EDX, EBX - CALL ECX - - POP EDI - MOV EAX, [EBX].TBitmap.fWidth - CMP EAX, [EDI].TBitmap.fHeight - JGE @@noCutHeight - - MOV EDX, [EDI].TBitmap.fScanLineSize - MUL EDX - MOV [EDI].TBitmap.fDIBSize, EAX - - MOV EDX, [EDI].TBitmap.fDIBHeader - MOV EDX, [EDX].TBitmapInfoHeader.biHeight - TEST EDX, EDX - JL @@noCorrectImg - - PUSH EAX - - MOV EDX, [EDI].TBitmap.fHeight - DEC EDX - MOV EAX, EDI - CALL TBitmap.GetScanLine - PUSH EAX - - MOV EDX, [EBX].TBitmap.fWidth - DEC EDX - MOV EAX, EDI - CALL TBitmap.GetScanLine - POP EDX - - POP ECX - CALL System.Move - -@@noCorrectImg: - MOV EAX, [EBX].TBitmap.fWidth - MOV [EDI].TBitmap.fHeight, EAX - MOV EDX, [EDI].TBitmap.fDIBHeader - MOV [EDX].TBitmapInfoHeader.biHeight, EAX - -@@noCutHeight: - MOV EAX, EBX - CALL TBitmap.ClearData - - XOR EAX, EAX - XCHG EAX, [EDI].TBitmap.fDIBHeader - XCHG [EBX].TBitmap.fDIBHeader, EAX - - XCHG EAX, [EDI].TBitmap.fDIBBits - XCHG [EBX].TBitmap.fDIBBits, EAX - - MOV AL, [EDI].TBitmap.fDIBAutoFree - MOV [EBX].TBitmap.fDIBAutoFree, AL - - MOV EAX, [EDI].TBitmap.fDIBSize - MOV [EBX].TBitmap.fDIBSize, EAX - - MOV EAX, [EDI].TBitmap.fWidth - MOV [EBX].TBitmap.fWidth, EAX - - MOV EAX, [EDI].TBitmap.fHeight - MOV [EBX].TBitmap.fHeight, EAX - - XCHG EAX, EDI - CALL TObj.RefDec -@@exit: - POP EDI - POP EBX -end; - -function TBitmap.GetPixels(X, Y: Integer): TColor; -asm - PUSH EBX - MOV EBX, EAX - PUSH ECX - PUSH EDX - CALL GetEmpty - PUSHFD - OR EAX, -1 - POPFD - JZ @@exit - - CALL StartDC - PUSH dword ptr [ESP+12] - PUSH dword ptr [ESP+12] - PUSH EAX - CALL Windows.GetPixel - XCHG EBX, EAX - CALL FinishDC - XCHG EAX, EBX -@@exit: - POP EDX - POP EDX - POP EBX -end; - -procedure TBitmap.SetPixels(X, Y: Integer; const Value: TColor); -asm - PUSH EBX - MOV EBX, EAX - PUSH ECX - PUSH EDX - CALL GetEmpty - JZ @@exit - - CALL StartDC - MOV EAX, Value - CALL Color2RGB - PUSH EAX - PUSH dword ptr [ESP+16] - PUSH dword ptr [ESP+16] - PUSH dword ptr [ESP+16] - CALL Windows.SetPixel - CALL FinishDC -@@exit: - POP EDX - POP ECX - POP EBX -end; - -function _GetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer ): TColor; -const szBIH = Sizeof(TBitmapInfoHeader); -asm - PUSH EBX - PUSH EDI - PUSH EDX - XCHG EBX, EAX - - XCHG EAX, EDX - MOV EDI, [EBX].TBitmap.fPixelsPerByteMask - INC EDI - CDQ - DIV EDI - DEC EDI - XCHG ECX, EAX // EAX = Y, ECX = X div (Bmp.fPixeldPerByteMask+1) - - MOV EDX, [EBX].TBitmap.fScanLineDelta - IMUL EDX - - ADD EAX, [EBX].TBitmap.fScanLine0 - MOVZX EAX, byte ptr[EAX+ECX] - - POP EDX - MOV ECX, [EBX].TBitmap.fPixelsPerByteMask - AND EDX, ECX - SUB ECX, EDX - - PUSH EAX - MOV EDI, [EBX].TBitmap.fDIBHeader - MOVZX EAX, [EDI].TBitmapInfoHeader.biBitCount - MUL ECX - XCHG ECX, EAX - POP EAX - SHR EAX, CL - AND EAX, [EBX].TBitmap.fPixelMask - - MOV EAX, [EDI+szBIH+EAX*4] - CALL Color2RGBQuad - - POP EDI - POP EBX -end; - -function _GetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer ): TColor; -asm - PUSH [EAX].TBitmap.fPixelMask - PUSH EDX // X - PUSH EAX - MOV EAX, [EAX].TBitmap.fScanLineDelta - IMUL ECX - POP EDX - ADD EAX, [EDX].TBitmap.fScanLine0 - POP ECX - MOVZX EAX, word ptr [EAX+ECX*2] - POP EDX - CMP DL, 15 - JNE @@16bit - - MOV EDX, EAX - SHR EDX, 7 - SHL EAX, 6 - MOV DH, AH - AND DH, $F8 - SHL EAX, 13 - JMP @@1516bit - -@@16bit: - MOV DL, AH - SHL EAX, 5 - MOV DH, AH - SHL EAX, 14 -@@1516bit: - AND EAX, $F80000 - OR EAX, EDX - AND AX, $FCF8 -end; - -function _GetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer ): TColor; -asm - PUSH EBX - XCHG EBX, EAX - PUSH EDX - MOV EAX, [EBX].TBitmap.fScanLineDelta - IMUL ECX - XCHG ECX, EAX - POP EDX - MOV EAX, [EBX].TBitmap.fBytesPerPixel - MUL EDX - ADD EAX, [EBX].TBitmap.fScanLine0 - MOV EAX, [EAX+ECX] - AND EAX, $FFFFFF - CALL Color2RGBQuad - POP EBX -end; - -function _GetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer ): TColor; -asm - PUSH EBX - XCHG EBX, EAX - PUSH EDX - MOV EAX, [EBX].TBitmap.fScanLineDelta - IMUL ECX - XCHG ECX, EAX - POP EDX - MOV EAX, [EBX].TBitmap.fBytesPerPixel - MUL EDX - ADD EAX, [EBX].TBitmap.fScanLine0 - MOV EAX, [EAX+ECX] - MOV EDX, EAX - AND EDX, $FF00FF - AND EAX, $FF00FF00 - ROL EDX, 16 - OR EAX, EDX - POP EBX -end; - -function TBitmap.GetDIBPixels(X, Y: Integer): TColor; -asm - CMP word ptr [EAX].fGetDIBPixels+2, 0 - JNZ @@assigned - - // if not assigned, this preparing will be performed for first call: - CMP [EAX].fHandleType, bmDDB - JZ @@GetPixels - - PUSHAD - MOV EBX, EAX - XOR EDX, EDX - CALL GetScanLine - MOV [EBX].fScanLine0, EAX - XOR EDX, EDX - INC EDX - MOV EAX, EBX - CALL GetScanLine - SUB EAX, [EBX].fScanLine0 - MOV [EBX].fScanLineDelta, EAX - MOV EAX, EBX - CALL GetPixelFormat - MOVZX ECX, AL - MOV DX, $0F00 - MOV byte ptr [EBX].fBytesPerPixel, 4 - XOR EAX, EAX - LOOP @@if4bit - MOV DX, $0107 - JMP @@1bit4bit8bit -@@if4bit: - LOOP @@if8bit - INC EDX // MOV DX, $0F01 - JMP @@1bit4bit8bit -@@if8bit: - LOOP @@if15bit - MOV DH, $FF //MOV DX, $FF00 -@@1bit4bit8bit: - MOV EAX, offset[_GetDIBPixelsPalIdx] -@@if15bit: - LOOP @@if16bit - //MOV DH, $0F - DEC DH - INC ECX -@@if16bit: - LOOP @@if24bit - INC DH - MOV EAX, offset[_GetDIBPixels16bit] -@@if24bit: - LOOP @@if32bit - DEC [EBX].fBytesPerPixel - INC ECX - DEC EDX -@@if32bit: - LOOP @@iffin - INC EDX - {$IFDEF DIBPixels32bitWithAlpha} - MOV EAX, offset[_GetDIBPixelsTrueColorAlpha] - {$ELSE} - MOV EAX, offset[_GetDIBPixelsTrueColor] - {$ENDIF} -@@iffin: - MOV byte ptr [EBX].fPixelMask, DH - MOV byte ptr [EBX].fPixelsPerByteMask, DL - MOV [EBX].fGetDIBPixels, EAX - TEST EAX, EAX - POPAD -@@GetPixels: - JZ GetPixels - -@@assigned: - JMP [EAX].fGetDIBPixels -end; - -procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -asm - PUSH EDX - PUSH [EAX].TBitmap.fScanLine0 - PUSH ECX - PUSH [EAX].TBitmap.fScanLineDelta - MOV EAX, Value - CALL Color2RGB - MOV EDX, EAX - SHR EAX, 16 - ADD AL, DL - ADC AL, DH - CMP EAX, 170 - SETGE CL - AND ECX, 1 - SHL ECX, 7 - POP EAX - POP EDX - IMUL EDX - POP EDX - ADD EAX, EDX - POP EDX - PUSH ECX - MOV ECX, EDX - SHR EDX, 3 - ADD EAX, EDX - AND ECX, 7 - MOV DX, $FF7F - SHR EDX, CL - AND byte ptr [EAX], DL - POP EDX - SHR EDX, CL - OR byte ptr [EAX], DL -end; - -procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -asm - XCHG EAX, EBP - PUSH EDX // -> X - PUSH ECX // -> Y - MOV ECX, [EBP].TBitmap.fPixelsPerByteMask - INC ECX - XCHG EAX, EDX - CDQ - DIV ECX - XCHG ECX, EAX // ECX = X div (fPixelsPerByteMask+1) - POP EAX // <- Y - MOV EDX, [EBP].TBitmap.fScanLineDelta - IMUL EDX - ADD ECX, EAX - ADD ECX, [EBP].TBitmap.fScanLine0 // ECX = Pos - PUSH ECX // -> Pos - - MOV EDX, [ESP+16] // Value - MOV EAX, EBP - CALL TBitmap.DIBPalNearestEntry // EAX = Pixel - - POP ECX // <- Pos - POP EDX // <- X - - PUSH EAX // -> Pixel - - MOV EAX, [EBP].TBitmap.fPixelsPerByteMask - AND EDX, EAX - SUB EAX, EDX - MOV EDX, [EBP].TBitmap.fDIBHeader - MOVZX EDX, [EDX].TBitmapInfoHeader.biBitCount - MUL EDX // EAX = Shf - - XCHG ECX, EAX // ECX = Shf, EAX = Pos - MOV EDX, [EBP].TBitmap.fPixelMask - SHL EDX, CL - NOT EDX - AND byte ptr [EAX], DL - - POP EDX // <- Pixel - SHL EDX, CL - OR byte ptr [EAX], DL -end; - -procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -asm - ADD EDX, EDX - ADD EDX, [EAX].TBitmap.fScanLine0 - PUSH EDX // -> X*2 + Bmp.fScanLine0 - PUSH [EAX].TBitmap.fPixelMask - MOV EAX, [EAX].TBitmap.fScanLineDelta - IMUL ECX - PUSH EAX // -> Y* Bmp.fScanLineDelta - MOV EAX, Value - CALL Color2RGB - POP EBP // <- Y* Bmp.fScanLineDelta - POP EDX - XOR ECX, ECX - SUB DL, 16 - JZ @@16bit - - MOV CH, AL - SHR CH, 1 - SHR EAX, 6 - MOV EDX, EAX - AND DX, $3E0 - SHR EAX, 13 - JMP @@1516 - -@@16bit: - {$IFDEF PARANOIA} DB $24, $F8 {$ELSE} AND AL, $F8 {$ENDIF} - MOV CH, AL - SHR EAX, 5 - MOV EDX, EAX - AND DX, $7E0 - SHR EAX, 14 - -@@1516: - MOV AH, CH - AND AX, $FC1F - OR AX, DX - - POP EDX - MOV [EBP+EDX], AX -end; - -procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -asm - PUSH [EAX].TBitmap.fScanLineDelta - PUSH [EAX].TBitmap.fScanLine0 - MOV EAX, [EAX].TBitmap.fBytesPerPixel - MUL EDX - POP EDX - ADD EDX, EAX - POP EAX - PUSH EDX - IMUL ECX - POP EDX - ADD EDX, EAX - PUSH EDX - MOV EAX, Value - CALL Color2RGBQuad - POP EDX - AND dword ptr [EDX], $FF000000 - OR [EDX], EAX -end; - -procedure _SetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -asm - PUSH [EAX].TBitmap.fScanLineDelta - PUSH [EAX].TBitmap.fScanLine0 - MOV EAX, [EAX].TBitmap.fBytesPerPixel - MUL EDX - POP EDX - ADD EDX, EAX - POP EAX - PUSH EDX - IMUL ECX - POP EDX - ADD EDX, EAX - MOV EAX, Value - MOV ECX, EAX - AND ECX, $FF00FF - AND EAX, $FF00FF00 - ROL ECX, 16 - OR EAX, ECX - MOV [EDX], EAX -end; - -procedure TBitmap.SetDIBPixels(X, Y: Integer; const Value: TColor); -asm - CMP word ptr [EAX].fSetDIBPixels+2, 0 - JNZ @@assigned - PUSHAD - MOV EBX, EAX - XOR EDX, EDX - CMP [EBX].fHandleType, DL // bmDIB = 0 - JNE @@ddb - CALL GetScanLine - MOV [EBX].fScanLine0, EAX - XOR EDX, EDX - INC EDX - MOV EAX, EBX - CALL GetScanLine - SUB EAX, [EBX].fScanLine0 - MOV [EBX].fScanLineDelta, EAX - MOV EAX, EBX - CALL GetPixelFormat - MOVZX ECX, AL - MOV DX, $0F01 - MOV EAX, offset[_SetDIBPixelsPalIdx] - MOV byte ptr [EBX].fBytesPerPixel, 4 - LOOP @@if4bit - MOV EAX, offset[_SetDIBPixels1bit] -@@if4bit: - LOOP @@if8bit -@@if8bit: - LOOP @@if15bit - DEC DL - MOV DH, $FF -@@if15bit: - LOOP @@if16bit - DEC DH - INC ECX -@@if16bit: - LOOP @@if24bit - INC DH - MOV EAX, offset[_SetDIBPixels16bit] -@@if24bit: - LOOP @@if32bit - DEC EDX - DEC [EBX].fBytesPerPixel - INC ECX -@@if32bit: - LOOP @@ifend - INC EDX - {$IFDEF DIBPixels32bitWithAlpha} - MOV EAX, offset[_SetDIBPixelsTrueColor] - {$ELSE} - MOV EAX, offset[_SetDIBPixelsTrueColor] - {$ENDIF} -@@ifend: - MOV byte ptr [EBX].fPixelMask, DH - MOV byte ptr [EBX].fPixelsPerByteMask, DL - MOV [EBX].fSetDIBPixels, EAX - TEST EAX, EAX -@@ddb: - POPAD - JNZ @@assigned - PUSH Value - CALL SetPixels - JMP @@exit -@@assigned: - PUSH Value - CALL [EAX].fSetDIBPixels -@@exit: -end; - -procedure TBitmap.FlipVertical; -asm - PUSH EBX - MOV EBX, EAX - MOV ECX, [EBX].fHandle - JECXZ @@noHandle - - CALL StartDC - PUSH SrcCopy - MOV EDX, [EBX].fHeight - PUSH EDX - MOV ECX, [EBX].fWidth - PUSH ECX - PUSH 0 - PUSH 0 - PUSH EAX - NEG EDX - PUSH EDX - PUSH ECX - NEG EDX - DEC EDX - PUSH EDX - PUSH 0 - PUSH EAX - CALL StretchBlt - CALL FinishDC - POP EBX - RET - -@@noHandle: - MOV ECX, [EBX].fDIBBits - JECXZ @@exit - - PUSHAD //----------------------------------------\ - XOR EBP, EBP // Y = 0 - //+++++++++++++++++++++++++++ provide fScanLineSize - MOV EAX, EBX - MOV EDX, EBP - CALL GetScanLine // - SUB ESP, [EBX].fScanLineSize - -@@loo: LEA EAX, [EBP*2] - CMP EAX, [EBX].fHeight - JGE @@finloo - - MOV EAX, EBX - MOV EDX, EBP - CALL GetScanLine - MOV ESI, EAX // ESI = ScanLine[ Y ] - MOV EDX, ESP - MOV ECX, [EBX].fScanLineSize - PUSH ECX - CALL System.Move - - MOV EAX, EBX - MOV EDX, [EBX].fHeight - SUB EDX, EBP - DEC EDX - CALL GetScanLine - MOV EDI, EAX - MOV EDX, ESI - POP ECX - PUSH ECX - CALL System.Move - - POP ECX - MOV EAX, ESP - MOV EDX, EDI - CALL System.Move - - INC EBP - JMP @@loo - -@@finloo: - ADD ESP, [EBX].fScanLineSize - POPAD -@@exit: - POP EBX -end; - -procedure TBitmap.FlipHorizontal; -asm - PUSH EBX - MOV EBX, EAX - CALL GetHandle - TEST EAX, EAX - JZ @@exit - - CALL StartDC - PUSH SrcCopy - MOV EDX, [EBX].fHeight - PUSH EDX - MOV ECX, [EBX].fWidth - PUSH ECX - PUSH 0 - PUSH 0 - PUSH EAX - PUSH EDX - NEG ECX - PUSH ECX - PUSH 0 - NEG ECX - DEC ECX - PUSH ECX - PUSH EAX - CALL StretchBlt - CALL FinishDC -@@exit: - POP EBX -end; - -procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap; - const SrcRect: TRect); -asm - PUSHAD - MOV EBX, EAX - MOV ESI, ECX - MOV EDI, EDX - CALL GetHandle - TEST EAX, EAX - JZ @@exit - MOV EAX, ESI - CALL GetHandle - TEST EAX, EAX - JZ @@exit - CALL StartDC - XCHG EBX, ESI - CMP EBX, ESI - JNZ @@diff1 - PUSH EAX - PUSH 0 - JMP @@nodiff1 -@@diff1: - CALL StartDC -@@nodiff1: - PUSH SrcCopy // -> - MOV EBP, [SrcRect] - MOV EAX, [EBP].TRect.Bottom - MOV EDX, [EBP].TRect.Top - SUB EAX, EDX - PUSH EAX // -> - MOV EAX, [EBP].TRect.Right - MOV ECX, [EBP].TRect.Left - SUB EAX, ECX - PUSH EAX // -> - PUSH EDX // -> - PUSH ECX // -> - PUSH dword ptr [ESP+24] // -> DCsrc - MOV EAX, [EDI].TRect.Bottom - MOV EDX, [EDI].TRect.Top - SUB EAX, EDX - PUSH EAX // -> - MOV EAX, [EDI].TRect.Right - MOV ECX, [EDI].TRect.Left - SUB EAX, ECX - PUSH EAX // -> - PUSH EDX // -> - PUSH ECX // -> - PUSH dword ptr [ESP+13*4] // -> DCdst - CALL StretchBlt - CMP EBX, ESI - JNE @@diff2 - POP ECX - POP ECX - JMP @@nodiff2 -@@diff2: - CALL FinishDC -@@nodiff2: - CALL FinishDC -@@exit: - POPAD -end; - -procedure asmIconEmpty( Icon: PIcon ); -asm - CMP [EAX].TIcon.fHandle, 0 -end; - -procedure TIcon.Clear; -asm //cmd //opd - XOR ECX, ECX - XCHG ECX, [EAX].fHandle - JECXZ @@1 - CMP [EAX].fShareIcon, 0 - JNZ @@1 - PUSH EAX - PUSH ECX - CALL DestroyIcon - POP EAX -@@1: MOV [EAX].fShareIcon, 0 -end; - -{$IFNDEF ICON_DIFF_WH} -function TIcon.Convert2Bitmap(TranColor: TColor): HBitmap; -asm //cmd //opd - PUSH EBX - PUSH ESI - PUSH EDI - PUSH EBP - MOV EBX, EAX - MOV EBP, EDX - XOR EDX, EDX - CALL asmIconEmpty - JZ @@ret_0 - PUSH 0 - CALL GetDC - PUSH EAX //> DC0 - PUSH EAX - CALL CreateCompatibleDC - XCHG EDI, EAX - MOV EDX, [EBX].fSize - - POP EAX - PUSH EAX - PUSH EDX //>Bottom - PUSH EDX //>Right - PUSH 0 //>Top - PUSH 0 //>Left - - PUSH EDX - PUSH EDX - PUSH EAX - CALL CreateCompatibleBitmap - XCHG EBP, EAX - - CALL Color2RGB - PUSH EAX - - PUSH EBP - PUSH EDI - CALL SelectObject - XCHG ESI, EAX - - CALL CreateSolidBrush - - MOV EDX, ESP - PUSH EAX - PUSH EAX - PUSH EDX - PUSH EDI - CALL Windows.FillRect - CALL DeleteObject - - XCHG EAX, EBX - MOV EDX, EDI - XOR ECX, ECX - PUSH ECX - CALL Draw - - PUSH EDI - PUSH ESI - CALL FinishDC - - ADD ESP, 16 - PUSH 0 - CALL ReleaseDC - MOV EDX, EBP - -@@ret_0: - XCHG EAX, EDX - POP EBP - POP EDI - POP ESI - POP EBX -end; -{$ENDIF} - -destructor TIcon.Destroy; -asm //cmd //opd - PUSH EAX - CALL Clear - POP EAX - CALL TObj.Destroy -end; - -procedure TIcon.Draw(DC: HDC; X, Y: Integer); -asm //cmd //opd - CALL asmIconEmpty - JZ @@exit - PUSH DI_NORMAL - PUSH 0 - PUSH 0 - {$IFDEF ICON_DIFF_WH} - PUSH [EAX].fHeight - PUSH [EAX].fWidth - {$ELSE} - PUSH [EAX].fSize - PUSH [EAX].fSize - {$ENDIF} - PUSH [EAX].fHandle - PUSH Y - PUSH ECX - PUSH EDX - CALL DrawIconEx -@@exit: -end; - -procedure TIcon.StretchDraw(DC: HDC; Dest: TRect); -asm //cmd //opd - CALL asmIconEmpty - JZ @@exit - PUSH DI_NORMAL - PUSH 0 - PUSH 0 - PUSH ECX - PUSH ECX - PUSH [EAX].fHandle - PUSH [ECX].TRect.Top - PUSH [ECX].TRect.Left - PUSH EDX - MOV EAX, [ECX].TRect.Bottom - SUB EAX, [ECX].TRect.Top - MOV [ESP+20], EAX - MOV EAX, [ECX].TRect.Right - SUB EAX, [ECX].TRect.Left - MOV [ESP+16], EAX - CALL DrawIconEx -@@exit: -end; - -procedure TIcon.SaveToFile(const FileName: KOLString); -asm //cmd //opd - PUSH EAX - MOV EAX, ESP - MOV ECX, EDX - XOR EDX, EDX - CALL SaveIcons2File - POP EAX -end; - -procedure TIcon.SaveToStream(Strm: PStream); -asm //cmd //opd - PUSH EAX - MOV EAX, ESP - MOV ECX, EDX - XOR EDX, EDX - CALL SaveIcons2Stream - POP EAX -end; - -function ColorBits( ColorsCount : Integer ) : Integer; -asm //cmd //opd - PUSH EBX - MOV EDX, offset[PossibleColorBits] -@@loop: MOVZX ECX, byte ptr [EDX] - JECXZ @@e_loop - INC EDX - XOR EBX, EBX - INC EBX - SHL EBX, CL - CMP EBX, EAX - JL @@loop -@@e_loop: - XCHG EAX, ECX - POP EBX -end; - -function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm //cmd //opd - PUSH EBX - XCHG EBX, EAX - MOVZX EAX, [EBX].TControl.fUpdateCount - TEST EAX, EAX - JZ @@exit - - XOR EAX, EAX - MOV EDX, [EDX].TMsg.message - CMP DX, WM_PAINT - JNE @@chk_erasebkgnd - - MOV [ECX], EAX - PUSH EAX - PUSH [EBX].TControl.fHandle - CALL ValidateRect - JMP @@rslt_1 -@@chk_erasebkgnd: - CMP DX, WM_ERASEBKGND - JNE @@exit - INC EAX - MOV [ECX], EAX -@@rslt_1: - MOV AL, 1 -@@exit: - POP EBX -end; - -procedure TControl.SetFocused(const Value: Boolean); -asm - PUSH ESI - MOV ESI, EAX - TEST DL, DL - JZ @@1 - {$IFDEF USE_FLAGS} - TEST [ESI].fStyle.f2_Style, 1 shl F2_Tabstop - {$ELSE} - CMP [ESI].fTabstop, 0 - {$ENDIF} - JZ @@exit -@@1: {$IFDEF USE_FLAGS} - TEST [ESI].fFlagsG3, 1 shl G3_IsControl - {$ELSE} - CMP [ESI].fIsControl, 0 - {$ENDIF} - JZ @@SetForegroundWindow - CALL TControl.ParentForm - PUSH EAX - MOV ECX, [EAX].DF.fCurrentControl - JECXZ @@PF_setCurCtl - CMP ECX, ESI - JZ @@PF_setCurCtl - MOV EAX, [EAX].DF.fCurrentControl - {$IFDEF EVENTS_DYNAMIC} - MOV ECX, [EAX].EV - MOV EDX, [ECX].TEvents.fLeave.TMethod.Data - MOV ECX, [ECX].TEvents.fLeave.TMethod.Code - {$ELSE} - MOV ECX, [EAX].EV.fLeave.TMethod.Code - MOV EDX, [EAX].EV.fLeave.TMethod.Data - {$ENDIF} - JECXZ @@SetFocus0 - XCHG EAX, EDX - CALL ECX - JMP @@PF_setCurCtl -@@setFocus0: - PUSH 0 - CALL Windows.SetFocus -@@PF_setCurCtl: - POP EAX - MOV [EAX].DF.fCurrentControl, ESI - {$IFDEF USE_GRAPHCTLS} - MOV ECX, [ESI].fSetFocus.TMethod.Code - MOV EAX, [ESI].fSetFocus.TMethod.Data - JECXZ @@SetFocus_GetwindowHandle - MOV EDX, ESI - CALL ECX - {$ENDIF} -@@SetFocus_GetwindowHandle: - XCHG EAX, ESI - CALL TControl.GetWindowHandle - PUSH EAX - CALL Windows.SetFocus - JMP @@exit -@@SetForegroundWindow: - XCHG EAX, ESI - CALL TControl.GetWindowHandle - PUSH EAX - CALL SetForegroundWindow -@@exit: POP ESI -end; - -procedure TControl.AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean ); -asm PUSH EBX - PUSH EDI - PUSH ECX - XCHG EBX, EAX - MOV EDI, EDX - MOV [EBX].PP.fOnDynHandlers, offset[EnumDynHandlers] - MOV EAX, [EBX].fDynHandlers - MOV EDX, EDI - CALL TList.IndexOf - TEST EAX, EAX - JGE @@exit - - MOV EAX, [EBX].fDynHandlers - PUSH EAX - MOV EDX, EDI - CALL TList.Add - POP EAX - POP EDX - PUSH EDX - CALL TList.Add -@@exit: {$IFNDEF SMALLEST_CODE} - MOV EAX, [EBX].fDynHandlers - CALL [Global_AttachProcExtension] - {$ENDIF} - POP ECX - POP EDI - POP EBX -end; - -function TControl.IsProcAttached(Proc: TWindowFunc): Boolean; -asm //cmd //opd - MOV EAX, [EAX].TControl.fDynHandlers - CALL TList.IndexOf - TEST EAX, EAX - SETGE AL -end; - -{$IFDEF nASM_VERSION} -function WndProcAutoPopupMenu( Control: PControl; var Msg: TMsg; var MsgRslt: Integer ): Boolean; -asm - CMP WORD PTR[EDX].TMsg.message, WM_CONTEXTMENU - JNZ @@ret_0 - CMP DWORD PTR[EAX].TControl.fAutoPopupMenu, 0 - JZ @@ret_0 - PUSH ESI - PUSH EDI - PUSH EBX - XCHG ESI, EAX // ESI = Control - MOV EDI, EDX - - MOVSX EAX, WORD PTR[EDX].TMsg.lParam+2 - PUSH EAX // P.Y - MOVSX EAX, WORD PTR[EDX].TMsg.lParam - PUSH EAX // P.X - - CMP DWORD PTR[EDX].TMsg.lParam, -1 - JNZ @@auto_popup - - MOV EAX, ESI - CALL TControl.GetCurIndex - CMP EAX, 0 - JL @@coords_2screen - // EAX = I - - MOVZX EBX, WORD PTR[ESI].TControl.fCommandActions.aItem2XY - CMP EBX, 0 - JZ @@coords_2screen - - CMP BX, EM_POSFROMCHAR - JNZ @@chk_LB_LV_TC - - PUSH 1 - MOV EAX, ESI - CALL TControl.GetSelStart - PUSH EAX - MOV EAX, ESI - CALL TControl.GetSelLength - ADD DWORD PTR[ESP], EAX - PUSH EBX - PUSH ESI - CALL TControl.Perform - MOVSX EBX, AX - SHR EAX, 16 - MOVSX EAX, AX - POP ECX - POP ECX - PUSH EAX - PUSH EBX - JMP @@check_bounds - -@@chk_LB_LV_TC: - CMP BX, LB_GETITEMRECT - JZ @@LB_LV_TC - CMP BX, LVM_GETITEMRECT - JZ @@LB_LV_TC - CMP BX, TCM_GETITEMRECT - JNZ @@chk_TVM -@@LB_LV_TC: // EAX = I - PUSH ECX - PUSH LVIR_BOUNDS - PUSH ESP // @R - PUSH EAX // I - JMP @@get_2 - -@@chk_TVM: - CMP BX, TVM_GETITEMRECT - JNZ @@check_bounds - - MOV EDX, TVGN_CARET - MOV EAX, ESI - CALL TControl.TVGetItemIdx - PUSH ECX - PUSH EAX - PUSH ESP // @R - PUSH 1 // 1 -@@get_2: - PUSH EBX // M - PUSH ESI // Control - CALL TControl.Perform - POP EAX - POP ECX - POP ECX - PUSH EAX - -@@check_bounds: - POP EBX // P.X - POP EDI // P.Y - SUB ESP, 16 - MOV EDX, ESP - MOV EAX, ESI - CALL TControl.ClientRect - - POP EAX // R.Left == 0 - POP EAX // R.Top == 0 - POP EAX // R.Right - CMP EBX, EAX - JLE @@1 - XCHG EBX, EAX -@@1:POP EAX // R.Bottom - CMP EDI, EAX - JLE @@2 - XCHG EDI, EAX -@@2:PUSH EDI // P.Y - PUSH EBX // P.X - -@@coords_2screen: - MOV EDX, ESP - MOV EAX, ESI - MOV ECX, EDX - CALL TControl.Client2Screen - -@@auto_popup: - POP EDX // P.X - POP ECX // P.Y - MOV EAX, [ESI].TControl.fAutoPopupMenu - CALL TMenu.Popup - - POP EBX - POP EDI - POP ESI - OR EAX, -1 - RET -@@ret_0: - XOR EAX, EAX -end; -{$ENDIF nASM_VERSION} - -function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - PUSH ESI - XCHG ESI, EAX - - MOV AX, word ptr [EDX].TMsg.message - CMP AX, WM_MOUSELEAVE - JE @@MOUSELEAVE - SUB AX, WM_MOUSEFIRST - CMP AX, WM_MOUSELEAVE-WM_MOUSEFIRST - JA @@retFalse - - {$IFDEF USE_FLAGS} - TEST [ESI].TControl.fFlagsG3, 1 shl G3_MouseInCtl - SETNZ AL - {$ELSE} - MOV AL, [ESI].TControl.fMouseInControl - {$ENDIF} - PUSH EAX - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [ESI].TControl.EV - MOV ECX, [EAX].TEvents.fOnTestMouseOver.TMethod.Code - {$ELSE} - MOV ECX, [ESI].TControl.EV.fOnTestMouseOver.TMethod.Code - {$ENDIF} - JECXZ @@1 - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnTestMouseOver.TMethod.Data - {$ELSE} - MOV EAX, [ESI].TControl.EV.fOnTestMouseOver.TMethod.Data - {$ENDIF} - MOV EDX, ESI - CALL ECX - JMP @@2 -@@1: - PUSH ECX - PUSH ECX - PUSH ESP - CALL GetCursorPos - MOV EAX, ESI - MOV EDX, ESP - MOV ECX, EDX - CALL TControl.Screen2Client - MOV ECX, ESP // @P - SUB ESP, 16 - MOV EDX, ESP // @ClientRect - MOV EAX, ESI - - PUSH EDX - PUSH ECX - CALL TControl.ClientRect - POP EAX - POP EDX - CALL PointInRect - ADD ESP, 16+8 - -@@2: - POP EDX - CMP AL, DL - JE @@retFalse - - //MouseWasInControl <> Yes - PUSH EAX - MOV EAX, ESI - CALL TControl.Invalidate - POP EAX - - TEST AL, AL - JZ @@3 - - {$IFDEF USE_FLAGS} - OR [ESI].TControl.fFlagsG3, 1 shl G3_MouseInCtl - {$ELSE} - MOV [ESI].TControl.fMouseInControl, 1 - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [ESI].TControl.EV - MOV ECX, [EAX].TEvents.fOnMouseEnter.TMethod.Code - {$ELSE} - MOV ECX, [ESI].TControl.EV.fOnMouseEnter.TMethod.Code - {$ENDIF} - JECXZ @@2_1 - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnMouseEnter.TMethod.Data - {$ELSE} - MOV EAX, [ESI].TControl.EV.fOnMouseEnter.TMethod.Data - {$ENDIF} - MOV EDX, ESI - CALL ECX -@@2_1: - PUSH ECX - PUSH [ESI].TControl.fHandle - PUSH TME_LEAVE - PUSH 16 - MOV EAX, ESP - CALL DoTrackMouseEvent - JMP @@4 - -@@3: - {$IFDEF USE_FLAGS} - AND byte ptr [ESI].TControl.fFlagsG3, $7F // not(1 shl G3_MouseInCtl) - {$ELSE} - MOV [ESI].TControl.fMouseInControl, 0 - {$ENDIF} - PUSH ECX - PUSH [ESI].TControl.fHandle - PUSH TME_LEAVE or TME_CANCEL - PUSH 16 - MOV EAX, ESP - CALL DoTrackMouseEvent - -@@3_X: - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [ESI].TControl.EV - MOV ECX, [EAX].TEvents.fOnMouseLeave.TMethod.Code - {$ELSE} - MOV ECX, [ESI].TControl.EV.fOnMouseLeave.TMethod.Code - {$ENDIF} - JECXZ @@3_1 - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnMouseLeave.TMethod.Data - {$ELSE} - MOV EAX, [ESI].TControl.EV.fOnMouseLeave.TMethod.Data - {$ENDIF} - MOV EDX, ESI - CALL ECX -@@3_1: - -@@4: - ADD ESP, 16 -@@4_1: - MOV EAX, ESI - CALL TControl.Invalidate - JMP @@retFalse - -@@MOUSELEAVE: - {$IFDEF USE_FLAGS} - BTR dword ptr [ESI].TControl.fFlagsG3, G3_MouseInCtl - JNC @@retFalse - {$ELSE} - BTR DWORD PTR [ESI].TControl.fMouseInControl, 0 - JNC @@retFalse - {$ENDIF} - - {$IFDEF GRAPHCTL_HOTTRACK} - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [ESI].TControl.EV - MOV ECX, [EAX].TEvents.fMouseLeaveProc.TMethod.Code - {$ELSE} - MOV ECX, [ESI].TControl.EV.fMouseLeaveProc.TMethod.Code - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@4_1 - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fMouseLeaveProc.TMethod.Data - {$ELSE} - MOV EAX, [ESI].TControl.EV.fMouseLeaveProc.TMethod.Data - {$ENDIF} - CALL ECX - {$ENDIF} - - SUB ESP, 16 - JMP @@3_X - -@@retFalse: - XOR EAX, EAX - POP ESI -end; - -function TControl.GetToBeVisible: Boolean; -asm - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fStyle.f3_Style, 1 shl F3_Visible - SETNZ DH - TEST [EAX].TControl.fFlagsG4, (1 shl G4_CreateHidden) or (1 shl G4_VisibleWOParent) - SETNZ DL - OR DL, DH - TEST [EAX].TControl.fFlagsG3, 1 shl G3_IsControl - JZ @@retDL - MOV ECX, [EAX].TControl.fParent - JECXZ @@retDL - - {$IFDEF OLD_ALIGN} - TEST [EAX].TControl.fFlagsG4, 1 shl G4_VisibleWOParent - JZ @@1 - MOV DL, DH - JMP @@retDL - {$ENDIF} - - {$ELSE not USE_FLAGS} - MOV DH, [EAX].TControl.fVisible - MOV DL, [EAX].TControl.fCreateHidden - OR DL, DH - OR DL, [EAX].TControl.fVisibleWoParent - CMP [EAX].TControl.fIsControl, 0 - JZ @@retDL - MOV ECX, [EAX].TControl.fParent - JECXZ @@retDL - - {$IFDEF OLD_ALIGN} - CMP [EAX].TControl.fVisibleWoParent, 0 - JZ @@1 - MOV DL, DH - JMP @@retDL - {$ENDIF} - - {$ENDIF} - -@@1: - TEST DL, DL - JZ @@retDL - XCHG EAX, ECX - PUSH EAX - CALL TControl.Get_Visible - POP EAX - CALL TControl.GetToBeVisible - XCHG EDX, EAX -@@retDL: - XCHG EAX, EDX -end; - -// by MTsv DN - v2.90 -- chg by VK -function WinVer : TWindowsVersion; -asm - MOVSX EAX, byte ptr [SaveWinVer] - INC AH // если <> 0 после инкремента, то AL содержит вычисленную версию - JNZ @@exit - CALL GetVersion // EAX < 0 для платформы 9х, иначе NT; AL=MajorVersion; AH=MinorVersion - XCHG EDX, EAX - XOR EAX, EAX - TEST EDX, EDX - XCHG DL, DH // DH=MajorVersion; DL=MinorVersion - - JL @@platform_9x - MOV AL, wvNT - CMP DX, $0400 - JZ @@save_exit - - INC AL // wvY2K - SUB DX, $0500 - JZ @@save_exit - - INC AL // wvXP - //CMP DX, $0501 - DEC DX - JZ @@save_exit - - INC AL // wvWin2003Server - //CMP DX, $0502 - DEC DX - JZ @@save_exit - - INC AL // wvVista - CMP DX, $0600 - $0502 - JZ @@save_exit - - INC AL // wvSeven - //CMP DX, $0601 - //DEC DX - JMP @@save_exit -@@platform_9x: - CMP DH, 4 - JB @@save_exit // wv31 - INC AL // wv95 - CMP DX, $040A - JB @@save_exit - INC AL // wv98 - CMP DX, $045A - JB @@save_exit - INC AL // wvME -@@save_exit: - MOV byte ptr [SaveWinVer], AL -@@exit: -end; - -{$IFDEF USE_CONSTRUCTORS} -constructor TControl.CreateGradientPanel(AParent: PControl; AColor1, // - AColor2: TColor); // -asm //cmd //opd // - XOR EDX, EDX // - PUSH EDX // - CALL CreateLabel // - MOV ECX, AColor1 // - MOV [EAX].fColor1, ECX // - MOV ECX, AColor2 // - MOV [EAX].fColor2, ECX // - MOV EDX, [EAX].fBoundsRect.Left // - ADD EDX, 40 // - MOV [EAX].fBoundsRect.Right, EDX // - MOV EDX, [EAX].fBoundsRect.Top // - ADD EDX, 40 // - MOV [EAX].fBoundsRect.Bottom, EDX // - PUSH EAX // - MOV EDX, offset[ WndProcGradient ] // - CALL AttachProc // - POP EAX // -end; // -{$ENDIF USE_CONSTRUCTORS} - -function TControl.MakeWordWrap: PControl; -asm - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG1, (1 shl G1_WordWrap) - {$ELSE} - MOV [EAX].TControl.fWordWrap, 1 - {$ENDIF} - - MOV EDX, [EAX].TControl.fStyle - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fFlagsG5, 1 shl G5_IsButton - {$ELSE} - CMP [EAX].TControl.fIsButton, 0 - {$ENDIF} - JNZ @@1 - AND DL, not SS_LEFTNOWORDWRAP -@@1: - OR DH, $20 or SS_LEFTNOWORDWRAP // BS_MULTILINE >> 8 -@@2: - PUSH EAX - CALL TControl.SetStyle - POP EAX -end; - -function TControl.FormGetIntParam: Integer; -asm - PUSH ESI - PUSH EDI - MOV EDI, EAX // EDX = @ Self - - XOR EDX, EDX -@@loop: - - LEA ECX, [EDI].DF.FormParams - MOV ESI, DWORD PTR[ECX] - LODSB - MOV DWORD PTR[ECX], ESI - - SHR AL, 1 - JNC @@nocont - - SHL EDX, 7 - OR DL, AL - JMP @@loop - -@@nocont: - - SHR AL, 1 - PUSHF - XCHG EDX, EAX - SHL EAX, 6 - OR AL, DL - POPF - JNC @@noneg - - NEG EAX -@@noneg: - POP EDI - POP ESI -end; - -function TControl.FormGetColorParam: Integer; -asm - CALL FormGetIntParam - ROR EAX, 1 -end; - -procedure TControl.FormGetStrParam; -asm - PUSH EDI - MOV EDI, EAX - CALL FormGetIntParam - XCHG ECX, EAX - LEA EAX, [EDI].FormString - PUSH ECX - MOV EDX, DWORD PTR[EDI].DF.FormParams - {$IFDEF _D2} - CALL System.@LStrFromLenStr - {$ELSE} - CALL System.@LStrFromPCharLen - {$ENDIF} - POP ECX - ADD DWORD PTR[EDI].DF.FormParams, ECX - POP EDI -end; - -procedure TControl.FormExecuteCommands(AForm: PControl; ControlPtrOffsets: PSmallIntArray); -asm - PUSH EBX - PUSH ESI - PUSH EDI - XCHG EDI, EAX // EDI = @ Self - MOV EBX, EDX // EBX = AForm - MOV ESI, ECX // ECX = @ ControlPtrOffsets[0] -@@while_do: - MOV EAX, EDI - CALL FormGetIntParam - TEST EAX, EAX - JZ @@ewhile - JG @@not_create_ctrl - - NEG EAX - MOV ECX, [EDI].DF.FormAlphabet - MOV ECX, [ECX+EAX*4-4] - - MOV EAX, EDI - - CALL ECX - XCHG ECX, EAX - - XOR EAX, EAX - LODSW - MOV DWORD PTR[EBX+EAX*4], ECX - MOV [EDI].DF.FormLastCreatedChild, ECX - JMP @@while_do - -@@not_create_ctrl: - MOV ECX, [EDI].DF.FormAlphabet - MOV ECX, [ECX+EAX*4-4] - MOV EAX, [EDI].DF.FormLastCreatedChild - - XOR EDX, EDX - INC EDX - - CALL ECX - JMP @@while_do - -@@ewhile: - LEA EAX, [EDI].FormString - CALL System.@LStrClr - - POP EDI - POP ESI - POP EBX -end; - -function FormNewLabel( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewLabel -end; - -function FormNewWordWrapLabel( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewWordWrapLabel -end; - -function FormNewLabelEffect( Form: PControl ): PControl; -asm - PUSH EAX - CALL TControl.FormGetStrParam - POP EAX - PUSH EAX - CALL TControl.FormGetIntParam - POP ECX - PUSH EAX - MOV EAX, [ECX].TControl.DF.FormCurrentParent - MOV EDX, [ECX].TControl.FormString - POP ECX - CALL NewLabelEffect -end; - -function FormNewButton( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewButton -end; - -function FormNewPanel( Form: PControl ): PControl; -asm - CALL FormPrepareIntParamCreateCtrl - CALL NewPanel -end; - -function FormNewGroupbox( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewGroupbox -end; - -function FormNewEditBox( Form: PControl ): PControl; -asm - CALL FormPrepareIntParamCreateCtrl - CALL NewEditBox -end; - -{$IFDEF USE_RICHEDIT} -function FormNewRichEdit( Form: PControl ): PControl; -asm CALL FormPrepareIntParamCreateCtrl - CALL NewRichEdit -end; -{$ENDIF USE_RICHEDIT} - -function FormNewComboBox( Form: PControl ): PControl; -asm - CALL FormPrepareIntParamCreateCtrl - CALL NewCombobox -end; - -function FormNewCheckbox( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewCheckbox -end; - -function FormNewRadiobox( Form: PControl ): PControl; -asm - CALL FormPrepareStrParamCreateCtrl - CALL NewRadiobox -end; - -function FormNewListbox( Form: PControl ): PControl; -asm - CALL FormPrepareIntParamCreateCtrl - CALL NewListbox -end; - -//!!! asm version returns in EAX Control, -// and integer parameter in EDX and ECX (EDX=ECX) !!! -//--- this is enough to call method of Control with a single int param --- -function ParentForm_IntParamAsm(Control: PControl): Integer; -asm PUSH EAX - CALL TControl.FormParentForm - CALL TControl.FormGetIntParam - XCHG EDX, EAX - MOV ECX, EDX - POP EAX -end; -function ParentForm_ColorParamAsm(Control: PControl): Integer; -asm CALL ParentForm_IntParamAsm - ROR EDX, 1 -end; - -procedure FormSetSize( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - //XCHG ECX, EDX - POP EDX - CALL TControl.SetSize -end; - -function ParentForm_PCharParamAsm(Control: PControl): PChar; -asm PUSH EAX - CALL ParentForm_PCharParam - XCHG EDX, EAX - MOV ECX, EDX - POP EAX -end; - -procedure FormSetPosition( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - CALL TControl.SetPosition -end; - -procedure FormSetClientSize( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - //XCHG ECX, EDX - POP EDX - CALL TControl.SetClientSize -end; - -procedure FormSetAlign( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetAlign -end; - -procedure FormSetCanResizeFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetCanResize -end; - -procedure FormInitMenu( Form: PControl ); -asm - PUSH 0 - PUSH 0 - PUSH WM_INITMENU - PUSH EAX - CALL TControl.Perform -end; - -procedure FormSetExStyle( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - OR EDX, [EAX].TControl.fExStyle - CALL TControl.SetExStyle -end; - -procedure FormSetVisibleFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetVisible -end; - -procedure FormSetEnabledFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetEnabled -end; - -procedure FormResetStyles( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - NOT EDX - AND EDX, [EAX].TControl.fStyle - CALL TControl.SetStyle -end; - -procedure FormSetStyle( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - OR EDX, [EAX].TControl.fStyle - CALL TControl.SetStyle -end; - -procedure FormSetAlphaBlend( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetAlphaBlend -end; - -procedure FormSetHasBorderFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetHasBorder -end; - -procedure FormSetHasCaptionFalse( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetHasCaption -end; - -procedure FormResetCtl3D( Form: PControl ); -asm - XOR EDX, EDX - CALL TControl.SetCtl3D -end; - -procedure FormIconLoad_hInstance( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV EDX, [hInstance] - CALL TControl.IconLoad -end; - -procedure FormIconLoadCursor_0( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - CALL TControl.IconLoadCursor -end; - -procedure FormSetIconNeg1( Form: PControl ); -asm - OR EDX, -1 - CALL TControl.SetIcon -end; - -procedure FormSetWindowState( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetWindowState -end; - -procedure FormCursorLoad_0( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - CALL TControl.CursorLoad -end; - -procedure FormSetColor( Form: PControl ); -asm - CALL ParentForm_ColorParamAsm - CALL TControl.SetCtlColor -end; - -procedure FormSetBrushStyle( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetBrush - POP EDX - CALL TGraphicTool.SetBrushStyle -end; - -procedure FormSetBrushBitmap( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - CALL TControl.FormParentForm - - PUSH EAX - CALL ParentForm_PCharParam - XCHG EDX, EAX - MOV EAX, [hInstance] - POP ECX - - CALL LoadBmp - - PUSH EAX - MOV EAX, EDI - CALL TControl.GetBrush - POP EDX - - CALL TGraphicTool.SetBrushBitmap - POP EDI -end; - -procedure FormSetFontColor( Form: PControl ); -asm - CALL ParentForm_ColorParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetColor -end; - -procedure FormSetFontStyles( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetFontStyle -end; - -procedure FormSetFontHeight( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - XOR EDX, EDX - MOV DL, 4 - POP ECX - CALL TGraphicTool.SetInt -end; - -procedure FormSetFontWidth( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - XOR EDX, EDX - MOV DL, 8 - POP ECX - CALL TGraphicTool.SetInt -end; - -procedure FormSetFontOrientation( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetFontOrientation -end; - -procedure FormSetFontCharset( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetFontCharset -end; - -procedure FormSetFontPitch( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL TControl.GetFont - POP EDX - CALL TGraphicTool.SetFontPitch -end; - -procedure FormSetBorder( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV [EAX].TControl.fMargin, DL -end; - -procedure FormSetMarginTop( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - INC EDX - CALL TControl.SetClientMargin -end; - -procedure FormSetMarginBottom( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - MOV DL, 2 - CALL TControl.SetClientMargin -end; - -procedure FormSetMarginLeft( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - MOV DL, 3 - CALL TControl.SetClientMargin -end; - -procedure FormSetMarginRight( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - XOR EDX, EDX - MOV DL, 4 - CALL TControl.SetClientMargin -end; - -procedure FormSetSimpleStatusText( Form: PControl ); -asm - CALL ParentForm_PCharParamAsm - XOR EDX, EDX - MOV DL, 255 - CALL TControl.SetStatusText -end; - -procedure FormSetStatusText( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_PCharParamAsm - POP EDX - CALL TControl.SetStatusText -end; - -procedure FormRemoveCloseIcon( Form: PControl ); -asm - PUSH MF_BYCOMMAND - PUSH SC_CLOSE - CALL TControl.GetWindowHandle - PUSH 0 - PUSH EAX - CALL GetSystemMenu - PUSH EAX - CALL DeleteMenu -end; - -procedure FormSetConstraint; -asm - MOVZX EDX, DL - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - CALL TControl.SetConstraint -end; - -procedure FormSetMinWidth( Form: PControl ); -asm - XOR EDX, EDX - CALL FormSetConstraint -end; - -procedure FormSetMaxWidth( Form: PControl ); -asm - MOV DL, 2 - CALL FormSetConstraint -end; - -procedure FormSetMinHeight( Form: PControl ); -asm - MOV DL, 1 - CALL FormSetConstraint -end; - -procedure FormSetMaxHeight( Form: PControl ); -asm - MOV DL, 3 - CALL FormSetConstraint -end; - -procedure FormSetTextShiftX( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV [EAX].TControl.DF.fTextShiftX, EDX -end; - -procedure FormSetTextShiftY( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV [EAX].TControl.DF.fTextShiftY, EDX -end; - -procedure FormSetColor2( Form: PControl ); -asm - CALL ParentForm_ColorParamAsm - CALL TControl.SetColor2 -end; - -procedure FormSetTextAlign( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetTextAlign -end; - -procedure FormSetTextVAlign( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetVerticalAlign -end; - -procedure FormSetIgnoreDefault( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - {$IFDEF USE_FLAGS} - SHL EDX, G5_IgnoreDefault - AND [EAX].TControl.fFlagsG5, $7F //not(1 shl G5_IgnoreDefault) - OR [EAX].TControl.fFlagsG5, DL - {$ELSE} - MOV [EAX].TControl.FIgnoreDefault, DL - {$ENDIF} -end; - -procedure FormSetCaption( Form: PControl ); -asm - PUSH EAX - CALL TControl.FormParentForm - PUSH EAX - CALL TControl.FormGetStrParam - POP EAX - MOV EDX, [EAX].TControl.FormString - POP EAX - CALL TControl.SetCaption -end; - -procedure FormSetGradienStyle( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetGradientStyle -end; - -{$IFDEF USE_RICHEDIT} -procedure FormSetRE_AutoFontFalse( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 4 - XOR ECX, ECX - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_AutoFontSizeAdjustFalse( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 16 - XOR ECX, ECX - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_DualFontTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 128 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_UIFontsTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 32 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_IMECancelCompleteTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 4 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_IMEAlwaysSendNotifyTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 8 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetMaxTextSize( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetMaxTextSize -end; - -procedure FormSetRE_AutoKeyboardTrue( Form: PControl ); -asm - XOR EDX, EDX - MOV DL, 1 - MOV CL, 1 - CALL TControl.RESetLangOptions -end; - -procedure FormSetRE_Zoom( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - SHL ECX, 16 - OR EDX, ECX - CALL TControl.ReSetZoom -end; -{$ENDIF USE_RICHEDIT} - -procedure FormSetCount( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetItemsCount -end; - -procedure FormSetDroppedWidth( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetDroppedWidth -end; - -procedure FormSetButtonImage( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - CALL ParentForm_IntParamAsm - PUSH ECX - CALL ParentForm_IntParamAsm - POP ECX - PUSH $8000 // LR_SHARED - PUSH ECX - PUSH EDX - PUSH IMAGE_ICON - CALL ParentForm_PCharParam - PUSH EAX - PUSH [hInstance] - CALL LoadImage - XCHG EDX, EAX - XCHG EAX, EDI - CALL TControl.SetButtonIcon - POP EDI -end; - -procedure FormSetButtonBitmap( Form: PControl ); -asm - PUSH EAX - CALL ParentForm_PCharParam - PUSH EAX - PUSH [hInstance] - CALL LoadBitmap - XCHG EDX, EAX - POP EAX - CALL TControl.SetButtonBitmap -end; - -procedure FormSetMaxProgress( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV EDX, (PBM_SETRANGE32 or $8000) shl 16 - CALL TControl.SetMaxProgress -end; - -procedure FormSetProgress( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV EDX, (PBM_SETPOS or $8000) shl 16 - CALL TControl.SetIntVal -end; - -procedure FormLVColumsAdd( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - CALL ParentForm_IntParamAsm - JECXZ @@fin -@@1: - PUSH ECX - MOV EAX, EDI - CALL ParentForm_IntParamAsm - PUSH ECX - CALL ParentForm_StrParam - MOV EAX, EDI - CALL TControl.FormParentForm - MOV EDX, [EAX].TControl.FormString - XOR ECX, ECX - MOV CL, taLeft - MOV EAX, EDI - CALL TControl.LVColAdd - POP ECX - LOOP @@1 -@@fin: - POP EDI -end; - -procedure FormSetLVColOrder( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - PUSH ECX - MOV ECX, LVCF_ORDER or (28 shl 16) - CALL TControl.SetLVColEx -end; - -procedure FormSetLVColImage( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSH EDX - CALL ParentForm_IntParamAsm - POP EDX - PUSH ECX - MOV ECX, LVCF_IMAGE or (24 shl 16) - CALL TControl.SetLVColEx -end; - -procedure FormSetTVIndent( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - MOV EDX, TVM_GETINDENT - CALL TControl.SetIntVal -end; - -procedure FormSetDateTimeFormat( Form: PControl ); -asm - PUSH EAX - CALL TControl.FormParentForm - PUSH EAX - CALL TControl.FormGetStrParam - POP EAX - MOV EDX, [EAX].TControl.FormString - POP EAX - CALL TControl.SetDateTimeFormat -end; - -procedure FormSetCurrentTab( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - PUSHAD - CALL TControl.SetCurIndex - POPAD - CALL TControl.GetPages - CALL TControl.BringToFront -end; - -procedure FormSetCurIdx( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetCurIndex -end; - -procedure FormSetSBMin( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetSBMin -end; - -procedure FormSetSBMax( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetSBMax -end; - -procedure FormSetSBPosition( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetSBPosition -end; - -procedure FormSetSBPageSize( Form: PControl ); -asm - CALL ParentForm_IntParamAsm - CALL TControl.SetSBPageSize -end; - -procedure FormLastCreatedChildAsNewCurrentParent( Form: PControl ); -asm - PUSH EAX - CALL TControl.FormParentForm - POP [EAX].TControl.DF.FormCurrentParent -end; - -procedure FormSetTabpageAsParent( Form: PControl ); -asm - PUSH EAX - CALL TControl.FormParentForm - CALL ParentForm_IntParamAsm - POP ECX - PUSH EAX - XCHG EAX, ECX - CALL TControl.GetPages - POP EDX - MOV [EDX].TControl.DF.FormCurrentParent, EAX - MOV [EDX].TControl.DF.FormLastCreatedChild, EAX -end; - -procedure FormSetCurCtl( Form: PControl ); -asm - CALL TControl.FormParentForm - CALL ParentForm_IntParamAsm - MOV ECX, [EAX].TControl.DF.FormAddress - MOV ECX, [ECX + EDX*4] - - TEST ECX, ECX - JNZ @@1 - MOV ECX, EAX - -@@1: - MOV [EAX].TControl.DF.FormLastCreatedChild, ECX -end; - -procedure FormSetEvent( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - PUSH ESI - CALL TControl.FormParentForm - MOV ESI, EAX - PUSH [ESI].TControl.DF.FormObj - CALL ParentForm_IntParamAsm - MOV ESI, [EAX].TControl.DF.FormAlphabet - PUSH dword ptr [ESI+EDX*4] - CALL ParentForm_IntParamAsm - XCHG EAX, EDI - CALL dword ptr [ESI+EDX*4] - POP ESI - POP EDI -end; - -procedure FormSetIndexedEvent( Form: PControl ); -asm - PUSH EDI - MOV EDI, EAX - PUSH ESI - CALL TControl.FormParentForm - MOV ESI, EAX - PUSH [ESI].TControl.DF.FormObj - CALL ParentForm_IntParamAsm - MOV ESI, [EAX].TControl.DF.FormAlphabet - PUSH dword ptr [ESI+EDX*4] - - CALL ParentForm_IntParamAsm // idx - PUSH EDX - - CALL ParentForm_IntParamAsm - XCHG EAX, EDI - MOV ECX, dword ptr [ESI+EDX*4] - - POP EDX - CALL ECX - POP ESI - POP EDI -end; - -{$ENDIF} - -//======================================== THE END OF FILE KOL_ASM.inc diff --git a/plugins/ImportTXT/kol/KOL_ASM_NOUNICODE.inc b/plugins/ImportTXT/kol/KOL_ASM_NOUNICODE.inc deleted file mode 100644 index 29c9c49f15..0000000000 --- a/plugins/ImportTXT/kol/KOL_ASM_NOUNICODE.inc +++ /dev/null @@ -1,4351 +0,0 @@ -//------------------------------------------------------------------------------ -// KOL_ASM_NOUNICODE.inc (to inlude in KOL.pas) -// v 3.141592 - -// this part of code is for case when ASM_VERSION is enabled and the symbol -// UNICODE_CTRLS is NOT defined (functions, procedures and methods which work -// with AnsiStrings only) - -const comctl32_const: PKOLChar = 'comctl32'; - InitCommonControlsEx_const: PKOLChar = 'InitCommonControlsEx'; -procedure DoInitCommonControls( dwICC: DWORD ); -asm - PUSH EAX // dwICC - CALL InitCommonControls - MOV EAX, [ComCtl32_Module] - TEST EAX, EAX - JNZ @@1 - PUSH [comctl32_const] - CALL LoadLibrary - MOV [ComCtl32_Module], EAX -@@1:PUSH [InitCommonControlsEx_const] - PUSH EAX - CALL GetProcAddress - XCHG ECX, EAX - {$IFDEF SAFE_CODE} - POP EDX - JECXZ @@fin - PUSH EDX - {$ENDIF} - PUSH 8 // dwSize - PUSH ESP // @ ICC - CALL ECX // Proc( @ ICC ) - POP ECX - POP ECX -@@fin: -end; - -function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD; -asm - push edx // Flags - mov ecx, [Applet] - {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFDEF SAFE_CODE} - jecxz @@0 - {$ENDIF} - pushad - xchg eax, ecx - mov edx, offset[WndProcSnapMouse2DfltBtn] - call TControl.AttachProc - popad -@@0: - {$ENDIF} - mov edx, 0 - {$IFDEF SAFE_CODE} - jecxz @@1 - {$ENDIF} - mov edx, [ecx].TControl.fHandle - mov ecx, [ecx].TControl.fCaption -@@1: push ecx // Title - push eax // S - push edx // Wnd - call MessageBox - {$IFDEF SNAPMOUSE2DFLTBTN} - mov ecx, [Applet] - {$IFDEF SAFE_CODE} - jecxz @@2 - {$ENDIF} - pushad - xchg eax, ecx - mov edx, offset[WndProcSnapMouse2DfltBtn] - call TControl.DetachProc - popad -@@2: - {$ENDIF} -end; - -procedure TGraphicTool.SetFontName(const Value: KOLString); -asm - PUSH EAX - LEA EAX, [EAX].fData.Font.Name - XOR ECX, ECX - MOV CL, 32 - PUSH EAX - PUSH ECX - PUSH EDX - CALL StrLComp - //TEST EAX, EAX - POP EDX - POP ECX - POP EAX - JZ @@exit - CALL StrLCopy - POP EAX - PUSH EAX - CALL Changed -@@exit: POP EAX -end; - -{$IFDEF TEXT_EXTENT_OLD} -function TCanvas.TextExtent(const Text: KOLString): TSize; -asm - PUSH EBX - PUSH ESI - MOV EBX, EAX - PUSH ECX - PUSH ECX // prepare @Result - MOV EAX, EDX - CALL System.@LStrLen - PUSH EAX // prepare Length(Text) - CALL EDX2PChar - PUSH EDX // prepare PChar(Text) - {$IFDEF SAFE_CODE} - MOV EAX, EBX - CALL RefInc - {$ENDIF} - PUSH HandleValid or FontValid - PUSH EBX - CALL RequiredState - XCHG ESI, EAX - TEST ESI, ESI // ESI = fHandle before - JNZ @@1 - PUSH ESI - CALL CreateCompatibleDC - MOV EDX, EBX - XCHG EAX, EDX // EAX := @Self; EDX := DC - CALL SetHandle -//****************************************************** // Added By M.Gerasimov - CMP WORD PTR [EBX].TCanvas.fIsPaintDC, 0 - JNZ @@2 - XOR ESI,ESI -@@2: -//****************************************************** -@@1: - PUSH HandleValid or FontValid - PUSH EBX - CALL RequiredState - PUSH EAX // prepare DC - CALL Windows.GetTextExtentPoint32A // KOL_ANSI - POP EDX // @ Result - {$IFDEF FIX_ITALIC_TEXT_WIDTH} - MOV ECX, [EBX].fFont - //JECXZ @@0 - CMP [ECX].TGraphicTool.fData.Font.Italic, 0 - JZ @@0 - MOV EAX, [EDX].TSize.cy - SHR EAX, 2 - ADD DWORD PTR [EDX], EAX -@@0: {$ENDIF} - TEST ESI, ESI - JNZ @@exit - XOR EDX, EDX - XCHG EAX, EBX - CALL SetHandle -@@exit: - {$IFDEF SAFE_CODE} - PUSH EAX - XCHG EAX, EBX - CALL RefDec - POP EAX - {$ENDIF} - POP ESI - POP EBX -end; -{$ELSE TEXT_EXTENT_NEW} -function TCanvas.TextExtent(const Text: KOLString): TSize; -asm - PUSH ESI - {$IFDEF FIX_ITALIC_TEXT_WIDTH} - PUSH EBX - MOV EBX, ECX - {$ENDIF} - XCHG ESI, EAX // ESI = @Self: PCanvas - CALL EDX2PChar - PUSH ECX - PUSH EDX - - XCHG EAX, EDX - CALL StrLen - XCHG [ESP], EAX - PUSH EAX - - PUSH HandleValid or FontValid - PUSH ESI - CALL TCanvas.RequiredState - PUSH [ESI].TCanvas.fHandle - CALL GetTextExtentPoint32 - {$IFDEF FIX_ITALIC_TEXT_WIDTH} - CMP [ESI].TGraphicTool.fData.Font.Italic, 0 - JZ @@1 - MOV EAX, [EBX].TSize.cy - SHR EAX, 2 - ADD DWORD PTR [EBX].TSize, EAX -@@1: POP EBX - {$ENDIF} - POP ESI -end; -{$ENDIF TEXT_EXTENT_NEW} - -procedure TCanvas.TextOut(X, Y: Integer; const Text: KOLString); stdcall; -asm - PUSH EBX - MOV EBX, [EBP+8] - - MOV EAX, [Text] - PUSH EAX - CALL System.@LStrLen - XCHG EAX, [ESP] // prepare Length(Text) - - //CALL System.@LStrToPChar // string does not need to be null-terminated ! - PUSH EAX // prepare PChar(Text) - PUSH [Y] // prepare Y - PUSH [X] // prepare X - - PUSH HandleValid or FontValid or BrushValid or ChangingCanvas - PUSH EBX - CALL RequiredState - PUSH EAX // prepare fHandle - CALL Windows.TextOutA // KOL_ANSI - - POP EBX -end; - -function Int2Hex( Value : DWord; Digits : Integer ) : KOLString; -asm // EAX = Value - // EDX = Digits - // ECX = @Result - PUSH 0 - ADD ESP, -0Ch - PUSH EDI - PUSH ECX - LEA EDI, [ESP+8+0Fh] // EBX := @Buf[ 15 ] - {$IFDEF SMALLEST_CODE} - {$ELSE} - AND EDX, $F - {$ENDIF} -@@loop: DEC EDI - DEC EDX - PUSH EAX - {$IFDEF PARANOIA} DB $24, $0F {$ELSE} AND AL, 0Fh {$ENDIF} - AAM - DB $D5, $11 //AAD - ADD AL, $30 - STOSB - DEC EDI - POP EAX - SHR EAX, 4 - JNZ @@loop - TEST EDX, EDX - JG @@loop - POP EAX // EAX = @Result - MOV EDX, EDI // EDX = @resulting string - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - POP EDI - ADD ESP, 10h -end; - -function Hex2Int( const Value : AnsiString) : Integer; -asm - CALL EAX2PChar - PUSH ESI - XCHG ESI, EAX - XOR EDX, EDX - TEST ESI, ESI - JE @@exit - LODSB - {$IFDEF PARANOIA} DB $3C, '$' {$ELSE} CMP AL, '$' {$ENDIF} - JNE @@1 -@@0: LODSB -@@1: TEST AL, AL - JE @@exit - {$IFDEF PARANOIA} DB $2C, '0' {$ELSE} SUB AL, '0' {$ENDIF} - {$IFDEF PARANOIA} DB $3C, 9 {$ELSE} CMP AL, '9' - '0' {$ENDIF} - JBE @@3 - - {$IFDEF PARANOIA} DB $2C, $11 {$ELSE} SUB AL, 'A' - '0' {$ENDIF} - {$IFDEF PARANOIA} DB $3C, 5 {$ELSE} CMP AL, 'F' - 'A' {$ENDIF} - JBE @@2 - - {$IFDEF PARANOIA} DB $2C, 32 {$ELSE} SUB AL, 32 {$ENDIF} - {$IFDEF PARANOIA} DB $3C, 5 {$ELSE} CMP AL, 'F' - 'A' {$ENDIF} - JA @@exit -@@2: - {$IFDEF PARANOIA} DB $04, 0Ah {$ELSE} ADD AL, 0Ah {$ENDIF} -@@3: - SHL EDX, 4 - ADD DL, AL - JMP @@0 - -@@exit: XCHG EAX, EDX - POP ESI -end; - -function Int2Str( Value : Integer ) : KOLString; -asm - XOR ECX, ECX - PUSH ECX - ADD ESP, -0Ch - - PUSH EBX - LEA EBX, [ESP + 15 + 4] - PUSH EDX - CMP EAX, ECX - PUSHFD - JGE @@1 - NEG EAX -@@1: - MOV CL, 10 - -@@2: - DEC EBX - XOR EDX, EDX - DIV ECX - ADD DL, 30h - MOV [EBX], DL - TEST EAX, EAX - JNZ @@2 - - POPFD - JGE @@3 - - DEC EBX - MOV byte ptr [EBX], '-' -@@3: - POP EAX - MOV EDX, EBX - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: safe to destory twice? - {$ENDIF} - CALL System.@LStrFromPChar - - POP EBX - ADD ESP, 10h -end; - -function Int2Ths( I : Integer ) : AnsiString; -asm - PUSH EBP - MOV EBP, ESP - PUSH EAX - PUSH EDX - CALL Int2Str - POP EDX - POP EAX - TEST EAX, EAX - JGE @@0 - NEG EAX -@@0: - CMP EAX, 1000 - JL @@Exit - PUSH EDX - MOV EAX, [EDX] - PUSH EAX - CALL System.@LStrLen // EAX = Length(Result) - POP EDX - PUSH EDX // EDX = @Result[ 1 ] - XOR ECX, ECX - -@@1: - ROL ECX, 8 - DEC EAX - MOV CL, [EDX+EAX] - JZ @@fin - CMP ECX, 300000h - JL @@1 - - PUSH ECX - XOR ECX, ECX - MOV CL, [ThsSeparator] - JMP @@1 - -@@fin: CMP CL, '-' - JNE @@fin1 - CMP CH, [ThsSeparator] - JNE @@fin1 - MOV CH, 0 // this corrects -,ddd,... -@@fin1: CMP ECX, 01000000h - JGE @@fin2 - INC EAX - ROL ECX, 8 - JMP @@fin1 -@@fin2: PUSH ECX - - LEA EDX, [ESP+EAX] - MOV EAX, [EBP-4] - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: safe to change ecx? - {$ENDIF} - CALL System.@LStrFromPChar -@@Exit: - MOV ESP, EBP - POP EBP -end; - -function Int2Digs( Value, Digits : Integer ) : KOLString; -asm - PUSH EBP - MOV EBP, ESP - PUSH EDX // [EBP-4] = Digits - PUSH ECX - MOV EDX, ECX - CALL Int2Str - POP ECX - PUSH ECX // [EBP-8] = @Result - MOV EAX, [ECX] - PUSH EAX - CALL System.@LStrLen - POP EDX // EDX = @Result[1] - MOV ECX, EAX // ECX = Length( Result ) - ADD EAX, EAX - SUB ESP, EAX - MOV EAX, ESP - PUSHAD - CALL StrCopy - POPAD - MOV EDX, EAX - ADD ESP, -100 - CMP byte ptr [EDX], '-' - PUSHFD - JNE @@1 - INC EDX -@@1: - MOV EAX, [EBP-4] // EAX = Digits - CMP ECX, EAX - JGE @@2 - DEC EDX - MOV byte ptr [EDX], '0' - INC ECX - JMP @@1 -@@2: - POPFD - JNE @@3 - DEC EDX - MOV byte ptr [EDX], '-' -@@3: - MOV EAX, [EBP-8] - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: eax or ecx affect result? - {$ENDIF} - CALL System.@LStrFromPChar - MOV ESP, EBP - POP EBP -end; - -function Num2Bytes( Value : Double ) : KOLString; -asm PUSH EBX - PUSH ESI - PUSH EDI - MOV EBX, ESP - MOV ESI, EAX - MOV ECX, 4 - MOV EDX, 'TGMk' -@@1: FLD [Value] -@@10: FICOM dword ptr [@@1024] - FSTSW AX - SAHF - JB @@2 - FIDIV dword ptr [@@1024] - FST [Value] - WAIT - TEST DL, 20h - JE @@ror - AND DL, not 20h - JMP @@nxt -@@1024: DD 1024 -@@100: DD 100 -@@ror: ROR EDX, 8 -@@nxt: LOOP @@10 -@@2: TEST DL, 20h - JZ @@3 - MOV DL, 0 -@@3: MOV DH, 0 - PUSH DX - MOV EDI, ESP - FLD ST(0) - CALL System.@TRUNC - {$IFDEF _D2orD3} - PUSH 0 - {$ELSE} - PUSH EDX - {$ENDIF} - PUSH EAX - FILD qword ptr [ESP] - POP EDX - POP EDX - MOV EDX, ESI - CALL Int2Str - FSUBP ST(1), ST - FIMUL dword ptr [@@100] - CALL System.@TRUNC - TEST EAX, EAX - JZ @@4 - XOR ECX, ECX - MOV CL, 0Ah - CDQ - IDIV ECX - TEST EDX, EDX - JZ @@5 - MOV AH, DL - SHL EAX, 16 - ADD EAX, '00. ' - PUSH EAX - MOV EDI, ESP - INC EDI - JMP @@4 -@@5: SHL EAX, 8 - ADD AX, '0.' - PUSH AX - MOV EDI, ESP -@@4: MOV EAX, [ESI] - CALL System.@LStrLen - ADD ESP, -100 - SUB EDI, EAX - PUSH ESI - PUSH EDI - MOV ESI, [ESI] - MOV ECX, EAX - REP MOVSB - POP EDX - POP EAX - {$IFDEF _D2009orHigher} - XOR ECX, ECX // TODO: IDIV - {$ENDIF} - CALL System.@LStrFromPChar - MOV ESP, EBX - POP EDI - POP ESI - POP EBX -end; - -function S2Int( S: PKOLChar ): Integer; -asm - XCHG EDX, EAX - XOR EAX, EAX - TEST EDX, EDX - JZ @@exit - - XOR ECX, ECX - MOV CL, [EDX] - INC EDX - CMP CL, '-' - PUSHFD - JE @@0 -@@1: CMP CL, '+' - JNE @@2 -@@0: MOV CL, [EDX] - INC EDX -@@2: SUB CL, '0' - CMP CL, '9'-'0' - JA @@fin - LEA EAX, [EAX+EAX*4] // - LEA EAX, [ECX+EAX*2] // - JMP @@0 -@@fin: POPFD - JNE @@exit - NEG EAX -@@exit: -end; - -function Str2Int(const Value : KOLString) : Integer; -asm - CALL EAX2PChar - CALL S2Int -end; - -function TrimLeft(const S: Ansistring): Ansistring; -asm - XCHG EAX, EDX - CALL EDX2PChar - DEC EDX -@@1: INC EDX - MOVZX ECX, byte ptr [EDX] - JECXZ @@fin - CMP CL, ' ' - JBE @@1 -@@fin: - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar -end; - -function TrimRight(const S: Ansistring): Ansistring; -asm - PUSH EDX - PUSH EAX - - PUSH EAX - CALL System.@LStrLen - XCHG EAX, [ESP] - CALL EAX2PChar - POP ECX - INC ECX -@@1: DEC ECX - MOV DL, [EAX+ECX] - JL @@fin - CMP DL, ' ' - JBE @@1 -@@fin: - INC ECX - POP EAX - XOR EDX, EDX - INC EDX - CALL System.@LStrCopy -end; - -function CopyEnd( const S : AnsiString; Idx : Integer ) : AnsiString; -asm - PUSH ECX - PUSH EAX - PUSH EDX - - CALL System.@LStrLen - - POP EDX - TEST EDX, EDX - JG @@1 - XOR EDX, EDX - INC EDX -@@1: - SUB EAX, EDX - MOV ECX, EAX - - POP EAX - JGE @@ret_end - - POP EAX - JL System.@LStrClr - -@@ret_end: - INC ECX - CALL System.@LStrCopy -end; - -function CopyTail( const S : AnsiString; Len : Integer ) : AnsiString; -asm - PUSH ECX - PUSH EAX - PUSH EDX - CALL System.@LStrLen - POP ECX - CMP ECX, EAX - {$IFDEF USE_CMOV} - CMOVG ECX, EAX - {$ELSE} - JLE @@1 - MOV ECX, EAX -@@1: {$ENDIF} - - MOV EDX, EAX - SUB EDX, ECX - INC EDX - POP EAX - CALL System.@LStrCopy -end; - -procedure DeleteTail( var S : AnsiString; Len : Integer ); -asm - PUSH EAX - PUSH EDX - MOV EAX, [EAX] - CALL System.@LStrLen - POP ECX - CMP ECX, EAX - {$IFDEF USE_CMOV} - CMOVG ECX, EAX - {$ELSE} - JLE @@1 - MOV ECX, EAX -@@1: {$ENDIF} - - MOV EDX, EAX - SUB EDX, ECX - INC EDX - POP EAX - CALL System.@LStrDelete -end; - -{$IFnDEF TEST_INDEXOFCHARS_COMPAT} -function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer; -asm - CALL EAX2PChar - PUSH EAX - MOV ECX, [EAX-4] - CALL StrScanLen - POP EDX - JZ @@1 - LEA EDX, [EAX+1] -@@1: SUB EAX, EDX -end; -{$ENDIF} - -function IndexOfCharsMin( const S, Chars : AnsiString ) : Integer; -asm PUSH ESI - PUSH EBX - PUSH EAX - CALL EDX2PChar - MOV ESI, EDX - - OR EBX, -1 - MOV ECX, [EDX-4] - JECXZ @@EXIT - -@@1: LODSB - - XCHG EDX, EAX - POP EAX - PUSH EAX - - PUSH ECX - CALL IndexOfChar - POP ECX - TEST EAX, EAX - JLE @@NEXT - - TEST EBX, EBX - JLE @@ASGN - CMP EAX, EBX - JGE @@NEXT -@@ASGN: - XCHG EAX, EBX -@@NEXT: LOOP @@1 - -@@EXIT: XCHG EAX, EBX - POP ECX - POP EBX - POP ESI -end; - -function Parse( var S : AnsiString; const Separators : AnsiString ) : AnsiString; -asm - PUSH EBX - PUSH ESI - PUSH EDI - MOV EDI, ECX - XCHG ESI, EAX - MOV EAX, [ESI] - CALL IndexOfCharsMin - XCHG EBX, EAX - TEST EBX, EBX - JG @@1 - MOV EAX, [ESI] - CALL System.@LStrLen - XCHG EBX, EAX - INC EBX -@@1: - XOR EDX, EDX - INC EDX - PUSH EDX - - PUSH EDI - MOV ECX, EBX - DEC ECX - MOV EAX, [ESI] - CALL System.@LStrCopy - XCHG EAX, ESI - MOV ECX, EBX - POP EDX - CALL System.@LStrDelete - POP EDI - POP ESI - POP EBX -end; - -function _StrSatisfy( S, Mask : PKOLChar ) : Boolean; -asm - TEST EAX, EAX - JZ @@exit - XCHG ECX, EAX - // EDX <- Mask - // ECX <- S - XOR EAX, EAX - MOV AL, '*' -@@rest_satisfy: - PUSH ECX - PUSH EDX - -@@nx_char: - MOV AH, [EDX] - OR AH, [ECX] - JZ @@fin //@@ret_true - - MOV AH, 0 - - CMP word ptr [EDX], AX //'*' - JE @@fin //@@ret_true - - CMP byte ptr [ECX], AH - JNE @@10 - - DEC EDX -@@1: - INC EDX - CMP byte ptr [EDX], AL //'*' - JE @@1 - - CMP byte ptr [EDX], AH - SETZ AL - JMP @@fin - -@@10: CMP byte ptr [EDX], AH - JE @@ret_false - - CMP byte ptr [EDX], '?' - JNE @@11 - -@@go_nx_char: - INC ECX - INC EDX - JMP @@nx_char - -@@11: - CMP byte ptr [EDX], AL //'*' - JNE @@20 - - INC EDX -@@12: CMP byte ptr [ECX], AH - JE @@ret_false - - CALL @@rest_satisfy - TEST AL, AL - JNE @@fin - MOV AL, '*' - - INC ECX - JMP @@12 - -@@20: MOV AH, [EDX] - XOR AH, [ECX] - - JE @@go_nx_char -@@ret_false: - XOR EAX, EAX - -@@fin: - POP EDX - POP ECX -@@exit: -end; - -function StrSatisfy( const S, Mask: AnsiString ): Boolean; -asm - PUSH ESI - TEST EAX, EAX - JZ @@exit - - XCHG ESI, EAX - - XCHG EAX, EDX - TEST EAX, EAX - JZ @@exit - - CALL EAX2PChar - - PUSH 0 - MOV EDX, ESP - CALL AnsiLowerCase - - XCHG EAX, ESI - CALL EAX2PChar - - PUSH 0 - MOV EDX, ESP - CALL AnsiLowerCase - - POP EAX - POP EDX - PUSH EDX - PUSH EAX - CALL _StrSatisfy - - XCHG ESI, EAX - - CALL RemoveStr - CALL RemoveStr - XCHG EAX, ESI - -@@exit: - POP ESI -end; - -function _2StrSatisfy( S, Mask: PAnsiChar ): Boolean; -asm // // - PUSH EBX - PUSH ECX - XCHG EBX, EAX - PUSH 0 - MOV EAX, ESP - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - PUSH 0 - MOV EAX, ESP - MOV EDX, EBX - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - POP EAX - POP EDX - PUSH EDX - PUSH EAX - CALL StrSatisfy - XCHG EBX, EAX - CALL RemoveStr - CALL RemoveStr - XCHG EAX, EBX - POP ECX - POP EBX -end; - -function SkipSpaces( P: PKOLChar ): PKOLChar; -asm - DEC EAX -@@loop: INC EAX - CMP byte ptr [EAX], 0 - JE @@exit - CMP byte ptr [EAX], ' ' - JBE @@loop -@@exit: -end; - -function SkipParam(P: PKOLChar): PKOLChar; -asm - CALL SkipSpaces -@@while: CMP byte ptr [EAX], ' ' - JBE @@exit - CMP byte ptr [EAX], '"' - JNE @@incP_goLoop -@@untilQuot: - INC EAX - CMP byte ptr [EAX], 0 - JE @@exit - CMP byte ptr [EAX], '"' - JNE @@untilQuot -@@incP_goLoop: - INC EAX - JMP @@while -@@exit: -end; - -function ParamCount: Integer; -asm - CALL GetCommandLine - OR EDX, -1 -@@while: INC EDX - CALL SkipParam - CALL SkipSpaces - CMP byte ptr [EAX], 0 - JNE @@while - XCHG EAX, EDX -end; - -function __DelimiterLast( Str: PAnsiChar; Delimiters: PAnsiChar ): PAnsiChar; -asm - PUSH ESI - - CALL EAX2PChar - - MOV ESI, EDX - MOV EDX, EAX - -@@tolast: - CMP byte ptr [EAX], 0 - JZ @@next1 - INC EAX - JMP @@tolast - -@@next1: - PUSH EAX - -@@next: - LODSB - TEST AL, AL - JZ @@exit - - PUSH EDX - XCHG EDX, EAX - CALL StrRScan - POP EDX - - TEST EAX, EAX - JZ @@next - - POP ECX - CMP byte ptr [ECX], 0 - JZ @@next1 - - CMP EAX, ECX - JG @@next1 - - PUSH ECX - JLE @@next - -@@exit: POP EAX - POP ESI -end; - -function DelimiterLast( const Str, Delimiters: KOLString ): Integer; -asm - CALL EAX2PChar - CALL EDX2PChar - PUSH EAX - CALL __DelimiterLast - POP EDX - SUB EAX, EDX - INC EAX -end; - -function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean; -asm - {$IFDEF F_P} - MOV EAX, [Str] - MOV EDX, [Pattern] - {$ENDIF F_P} - XOR ECX, ECX - @@1: - MOV CL, [EDX] // pattern[ i ] - INC EDX - MOV CH, [EAX] // str[ i ] - INC EAX - JECXZ @@2 // str = pattern; CL = #0, CH = #0 - CMP CL, CH - JE @@1 - @@2: - TEST CL, CL - SETZ AL -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; - -function Format( const fmt: KOLString; params: array of const ): AnsiString; -asm - PUSH ESI - PUSH EDI - PUSH EBX - MOV EBX, ESP - {$IFDEF UNICODE_CTRLS} - ADD ESP, -2048 - {$ELSE} - ADD ESP, -1024 - {$ENDIF} - MOV ESI, ESP - - INC ECX - JZ @@2 -@@1: - MOV EDI, [EDX + ECX*8 - 8] - PUSH EDI - LOOP @@1 -@@2: - PUSH ESP - PUSH EAX - PUSH ESI - - CALL wvsprintf - - MOV EDX, ESI - MOV EAX, @Result - {$IFDEF _D2009orHigher} - PUSH ECX - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - {$IFDEF _D2009orHigher} - POP ECX - {$ENDIF} - - MOV ESP, EBX - POP EBX - POP EDI - POP ESI -end; - -function FileExists( const FileName : KOLString ) : Boolean; -const size_TWin32FindData = sizeof( {$IFDEF UNICODE_CTRLS} TWin32FindDataW {$ELSE} TWin32FindDataA {$ENDIF} ); - Size_TFindFileData = (sizeof(TFindFileData) + 3) and not 3; -asm -{$IFDEF FILE_EXISTS_EX} - PUSH EBX - MOV BL, 0 - PUSH EAX - PUSH SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS - CALL SetErrorMode - XCHG EAX, [ESP] - SUB ESP, Size_TFindFileData - MOV EDX, ESP - CALL Find_First - TEST AL, AL - JZ @@fin - MOV EAX, ESP - CALL Find_Close - TEST byte ptr [ESP].TFindFileData.dwFileAttributes, FILE_ATTRIBUTE_DIRECTORY - JNZ @@fin - PUSH ESP - LEA EAX, [ESP+4].TFindFileData.ftLastWriteTime - PUSH EAX - CALL FileTimeToLocalFileTime - LEA EAX, [ESP+8] - PUSH EAX - INC EAX - INC EAX - PUSH EAX - SUB EAX, 10 - PUSH EAX - CALL FileTimeToDOSDateTime - TEST EAX, EAX - SETNZ BL -@@fin: ADD ESP, Size_TFindFileData - CALL SetErrorMode - XCHG EAX, EBX - POP EBX -{$ELSE} - CALL EAX2PChar - PUSH EAX - CALL GetFileAttributes - INC EAX - JZ @@exit - DEC EAX - {$IFDEF PARANOIA} DB $24, FILE_ATTRIBUTE_DIRECTORY {$ELSE} AND AL, FILE_ATTRIBUTE_DIRECTORY {$ENDIF} - SETZ AL -@@exit: -{$ENDIF} -end; - -function DiskPresent( const DrivePath: KOLString ): Boolean; -asm - PUSH EBX - MOV BH, 0 - TEST EAX, EAX - JZ @@dirExists - CMP byte ptr [EAX], '\' - JZ @@dirExists - PUSH EAX - PUSH EAX - CALL GetDriveType - CMP AL, DRIVE_REMOVABLE - JE @@setErrMode - CMP AL, DRIVE_CDROM - JE @@setErrMode - CMP AL, DRIVE_RAMDISK - JNE @@popPath_dirExists -@@setErrMode: - INC BH - PUSH SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS - CALL SetErrorMode - XCHG [ESP], EAX - PUSH EAX -@@popPath_dirExists: - POP EAX -@@dirExists: - CALL DirectoryExists - MOV BL, AL - TEST BH, BH - JZ @@exit - CALL SetErrorMode -@@exit: XCHG EAX, EBX - POP EBX -end; - -function GetStartDir : AnsiString; -asm - PUSH EBX - MOV EBX, EAX - - XOR EAX, EAX - MOV AH, 2 - SUB ESP, EAX - MOV EDX, ESP - PUSH EAX - PUSH EDX - PUSH 0 - CALL GetModuleFileName // in KOL_ANSI - - LEA EDX, [ESP + EAX] -@@1: DEC EDX - CMP byte ptr [EDX], '\' - JNZ @@1 - - INC EDX - MOV byte ptr [EDX], 0 - - MOV EAX, EBX - MOV EDX, ESP - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar // AnsiSafe! - - ADD ESP, 200h - POP EBX -end; - -function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString; -asm - push edx - push ecx - xchg ecx, eax - xchg edx, ecx - call System.@LStrAsg - pop eax - pop edx - mov ecx, [eax] - jecxz @@1 - add ecx, [ecx-4] - dec ecx - cmp byte ptr [ecx], dl - jz @@exit -@@1: - push eax - push 0 - mov eax, esp - {$IFDEF _D2009orHigher} - //push ecx - xor ecx, ecx - {$ENDIF} - call System.@LStrFromChar - {$IFDEF _D2009orHigher} - //pop ecx - {$ENDIF} - mov edx, [esp] - mov eax, [esp+4] - call System.@LStrCat - call RemoveStr - pop eax -@@exit: -end; - -const - DirDelimiters: PAnsiChar = ':\/'; -function ExtractFileName( const Path : AnsiString ) : AnsiString; -asm - PUSH EDX - PUSH EAX - MOV EDX, [DirDelimiters] - CALL __DelimiterLast - POP EDX - CMP byte ptr [EAX], 0 - JZ @@1 - XCHG EDX, EAX - INC EDX -@@1: POP EAX - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar // Safe! -end; - -function ExtractFileNameWOext( const Path : KOLString ) : KOLString; -asm - push ebx - - push edx - push eax - call ExtractFileName - pop edx // Path - не нужен больше - mov eax, [esp] // eax = Result = ExtractFileName(Path) - mov eax, [eax] - push 0 - mov edx, esp - call ExtractFileExt - mov eax, [esp] - call System.@LStrLen - xchg ebx, eax // ebx = Length(ExtractFileExt(Result)) - call RemoveStr // ExtractFileExt - больше не нужен - mov eax, [esp] - mov eax, [eax] - call System.@LStrLen // eax = Length(Result) - sub eax, ebx - xchg ecx, eax - xor edx, edx - inc edx - mov eax, [esp] - mov eax, [eax] - call System.@LStrCopy - - pop ebx -end; - -const - ExtDelimeters: PAnsiChar = '.'; - -function ExtractFileExt( const Path : KOLString ) : KOLString; -asm - PUSH EDX - MOV EDX, [ExtDelimeters] - CALL EAX2PChar - CALL __DelimiterLast -@@1: XCHG EDX, EAX - POP EAX - {$IFDEF _D2009orHigher} - PUSH ECX - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - {$IFDEF _D2009orHigher} - POP ECX // this routine hasn't touch ECX - {$ENDIF} -end; - -function ReplaceExt( const Path, NewExt: KOLString ): KOLString; -asm - push ecx // result - push edx // NewExt - push eax // Path - - push 0 - mov edx, esp - call ExtractFilePath - pop eax - xchg [esp], eax // eax=Path, Path in stack replaced with ExtractFilePath(Path) - - push 0 - mov edx, esp - call ExtractFileNameWOext - // now stack conatins: result,NewExt,ExtractFilePath(Path),ExtractFileNameWOext(Path)<-ESP - - mov eax, [esp+12] - mov edx, esp - push dword ptr [edx+4] // ExtractFilePath(Path) - push dword ptr [edx] // ExtractFileNameWOext(Path) - push dword ptr [edx+8] // NewExt - mov edx, 3 - call System.@LStrCatN - call RemoveStr - call RemoveStr - pop ecx - pop ecx -end; - -function GetSystemDir: KOLString; -asm - PUSH EBX - XCHG EBX, EAX - SUB ESP, MAX_PATH - MOV EAX, ESP - PUSH MAX_PATH - PUSH EAX - CALL GetSystemDirectory - MOV EAX, EBX - MOV EDX, ESP - CALL System.@LStrFromPChar - MOV EDX, EBX - MOV EAX, [EDX] - CALL IncludeTrailingPathDelimiter - ADD ESP, MAX_PATH - POP EBX -end; - -function GetWindowsDir : KOLString; -asm - PUSH EBX - XCHG EBX, EAX - SUB ESP, MAX_PATH - MOV EAX, ESP - PUSH MAX_PATH - PUSH EAX - CALL GetWindowsDirectory - MOV EAX, EBX - MOV EDX, ESP - CALL System.@LStrFromPChar - MOV EDX, EBX - MOV EAX, [EDX] - CALL IncludeTrailingPathDelimiter - ADD ESP, MAX_PATH - POP EBX -end; - -function GetWorkDir : KOLString; -asm - PUSH EBX - XCHG EBX, EAX - SUB ESP, MAX_PATH - PUSH ESP - PUSH MAX_PATH - CALL GetCurrentDirectory - MOV EAX, EBX - MOV EDX, ESP - CALL System.@LStrFromPChar - MOV EDX, EBX - MOV EAX, [EDX] - CALL IncludeTrailingPathDelimiter - ADD ESP, MAX_PATH - POP EBX -end; - -function GetTempDir : KOLString; -asm - push eax - sub esp, 264 - push esp - push 261 - call GetTempPath - mov edx, esp - mov eax, [esp+264] - {$IFDEF _D2009orHigher} - xor ecx, ecx - {$ENDIF} - call System.@LStrFromPChar - add esp, 264 - pop edx - mov eax, [edx] - call IncludeTrailingPathDelimiter -end; - -function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString; -asm - push ecx - call EAX2PCHAR - call EDX2PCHAR - sub esp, 264 - push esp - push 0 - push edx - push eax - call GetTempFileName - mov eax, [esp+264] - mov edx, esp - {$IFDEF _D2009orHigher} - xor ecx, ecx // ecx is argument - {$ENDIF} - call System.@LStrFromPChar - add esp, 268 -end; - -function FindFilter( const Filter: AnsiString): AnsiString; -asm - XCHG EAX, EDX - PUSH EAX - CALL System.@LStrAsg - POP EAX - CMP dword ptr [EAX], 0 - JNE @@exit - LEA EDX, @@mask_all - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - JE System.@LStrFromPChar -@@mask_all: DB '*.*',0 -@@exit: -end; - -procedure TDirList.ScanDirectoryEx(const DirPath, Filters: AnsiString; - Attr: DWord); -asm - PUSH EBX - MOV EBX, EAX - - PUSHAD - LEA EAX, [EBX].fFilters - CALL Free_And_Nil - - CALL NewStrList - MOV [EBX].fFilters, EAX - POPAD - - PUSHAD - PUSH 0 - MOV EAX, ESP - MOV EDX, ECX - CALL System.@LStrLAsg -@@1: MOV ECX, [ESP] - JECXZ @@2 - MOV EAX, ESP - MOV EDX, offset[@@semicolon] - PUSH 0 - MOV ECX, ESP - CALL Parse - MOV EAX, [ESP] - MOV EDX, ESP - CALL Trim - POP EDX - PUSH EDX - TEST EDX, EDX - JZ @@filt_added - MOV EAX, [EBX].fFilters - CALL TStrList.Add -@@filt_added: - CALL RemoveStr - JMP @@1 - - // ';' string literal - {$IFDEF _D2009orHigher} - DW 0, 1 - {$ENDIF} - DD -1, 1 -@@semicolon: - DB ';',0 - -@@2: POP ECX - POPAD - XOR ECX, ECX - PUSH [Attr] - CALL ScanDirectory - POP EBX -@@exit: -end; - -procedure _FillStrList; // Эта часть кода общая для двух следующих процедур -asm -/////////////////////////////// - OR EAX,0 - JE @@EXIT //ERROR -// LEA EAX,[EAX-IniBufferSize] -// JE @@EXIT -// возможна нехватка Буфера... в принципе не ошибка :) -// возвращаем что влезло... -@@LOOP: - LEA EAX,[ESI+4] - CALL StrLen - MOV [ESI],EAX - LEA EDX,[ESI+4] - INC EAX - ADD ESI,EAX - - MOV EAX,EDI - - CALL TStrList.ADD - - CMP byte ptr [ESI+4],0 - JNE @@LOOP - -@@EXIT: - POP EAX - CALL System.@FreeMem - - - POP ECX - POP EBX - POP EDI - POP ESI -end; - -procedure TIniFile.GetSectionNames(Names: PStrList); -asm - PUSH ESI - PUSH EDI - PUSH EBX - PUSH ECX - - MOV EBX,EAX - MOV EAX, IniBufferStrSize - MOV EDI,EDX - - CALL System.@GetMem - MOV ESI,EAX - PUSH EAX - - PUSH [EBX].fFileName - MOV EAX,IniBufferSize - PUSH EAX - - LEA EAX,[ESI+4] - PUSH EAX - - CALL GetPrivateProfileSectionNames - JMP _FillStrList -end; - -procedure TIniFile.SectionData(Names: PStrList); -asm - PUSH ESI - PUSH EDI - PUSH EBX - PUSH ECX - - MOV EBX,EAX - MOV EAX, IniBufferStrSize - MOV EDI,EDX - - CALL System.@GetMem - MOV ESI,EAX - PUSH EAX - - OR [EBX].fMode,0 - JNE @@DOWrite - - PUSH [EBX].fFileName - MOV EAX,IniBufferSize - PUSH EAX - - LEA EAX,[ESI+4] - PUSH EAX - PUSH [EBX].fSection - - CALL GetPrivateProfileSection - JMP _FillStrList - -@@DOWrite: - - PUSH EBX - PUSH ESI - PUSH EDX - PUSH EBP - - MOV EDX,0 - MOV EBP,[EDI].TStrList.fCount - MOV EBX,IniBufferSize-2 // оставим место для #0#0 - -{ECM+++>} OR EBP,EBP // otherwise GetPChars when StrList.Count = 0 crashed - -@@LOOP: - JE @@ENDLOOP - - OR EBX,EBX - JE @@ENDLOOP - - PUSH EDX - MOV EAX,EDI - CALL TStrList.GetPChars - - PUSH EAX - CALL StrLen - POP EAX - - XOR ECX,-1 - MOV EDX,ESI - - SUB EBX,ECX - JA @@L1 - ADD ECX,EBX - XOR EBX,EBX -@@L1: - - ADD ESI,ECX - - CALL MOVE -@@L2: - POP EDX - INC EDX - DEC EBP - JMP @@LOOP -@@ENDLOOP: - MOV WORD PTR [ESI],0 - - POP EBP - POP EDX - POP ESI - POP EBX - MOV EAX,EBX - CALL ClearSection - - PUSH [EBX].fFileName - PUSH ESI - PUSH [EBX].fSection - - CALL WritePrivateProfileSection - - POP EAX - CALL System.@FreeMem - - POP ECX - POP EBX - POP EDI - POP ESI - -end; - -function _NewControl( AParent: PControl; ControlClassName: PKOLChar; - Style: DWORD; Ctl3D: Boolean; - Actions: TCommandActionsParam ): PControl; -const szActions = sizeof(TCommandActions); -asm - PUSH EBX - PUSH EAX // push AParent - PUSH ECX // push Style - MOVZX ECX, [Ctl3D] - PUSH [Actions] - CALL _NewWindowed - XCHG EBX, EAX - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG3, (1 shl G3_IsControl) - {$ELSE} - INC [EBX].TControl.fIsControl - {$ENDIF} - POP EDX // pop Style - OR EDX, WS_CLIPSIBLINGS or WS_CLIPCHILDREN - //INC [EBX].TControl.fVerticalAlign - MOV byte ptr [EBX].TControl.fLookTabKeys, $0F - TEST [EBX].TControl.fCtl3D_child, 1 - JZ @@noCtl3D - AND EDX, not WS_BORDER - OR byte ptr [EBX].TControl.fExStyle + 1, WS_EX_CLIENTEDGE shr 8 -@@noCtl3D: - MOV [EBX].TControl.fStyle, EDX - {$IFDEF USE_FLAGS} - {$ELSE} - TEST EDX, WS_VISIBLE - SETNZ AL - MOV [EBX].TControl.fVisible, AL - TEST EDX, WS_TABSTOP - SETNZ AL - MOV [EBX].TControl.fTabstop, AL - {$ENDIF USE_FLAGS} - POP ECX // pop AParent - JECXZ @@noParent - - PUSH ESI - PUSH EDI - PUSH ECX - LEA ESI, [ECX].TControl.fMargin - LEA EDI, [EBX].TControl.fBoundsRect - LODSB - MOVSX EAX, AL - {$IFNDEF SMALLEST_CODE} - PUSH EAX - MOVSX ECX, byte ptr [ESI+2] - ADD EAX, ECX // AParent.fClientLeft - {$ENDIF} - STOSD // fBoundsRect.Left - {$IFNDEF SMALLEST_CODE} - POP EAX - PUSH EAX - MOVSX ECX, byte ptr [ESI+0] - ADD EAX, ECX // AParent.fClientTop - {$ENDIF} - STOSD // fBoundsRect.Top - {$IFNDEF SMALLEST_CODE} - XCHG EDX, EAX - POP EAX - {$ENDIF} - ADD EAX, 64 - STOSD // fBoundsRect.Right - {$IFNDEF SMALLEST_CODE} - XCHG EAX, EDX - ADD EAX, 64 - {$ENDIF} - STOSD // fBoundsRect.Bottom} - POP ECX - MOV EAX, [ECX].TControl.fCursor - STOSD - POP EDI - POP ESI - - XCHG EAX, ECX - CALL TControl.ParentForm - XCHG ECX, EAX - JECXZ @@noParentForm - INC [ECX].TControl.fTabOrder - MOV DX, WORD PTR [ECX].TControl.fTabOrder - MOV WORD PTR [EBX].TControl.fTabOrder, DX - TEST [EBX].TControl.fStyle, WS_TABSTOP - JZ @@CurrentControl_set - CMP [ECX].TControl.DF.fCurrentControl, 0 - JNZ @@CurrentControl_set - MOV [ECX].TControl.DF.fCurrentControl, EBX -@@CurrentControl_set: -@@noParentForm: -@@noParent: - MOVZX EDX, [CtlIdCount] - INC [CtlIdCount] - MOV [EBX].TControl.fMenu, EDX - MOV EDX, offset[WndProcCtrl] - MOV EAX, EBX - CALL TControl.AttachProc - XCHG EAX, EBX - POP EBX - {$IFDEF DEBUG_ALTSPC} - PUSH EAX - CALL DumpWindowed - POP EAX - {$ENDIF} -end; - -const StaticClass: Array[0..6] of AnsiChar=('S','T','A','T','I','C',#0); -function NewLabel( AParent: PControl; const Caption: KOLString ): PControl; -asm - PUSH EDX - - PUSH 0 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [LabelActions_Packed] - {$ELSE} - PUSH offset[LabelActions] - {$ENDIF} - MOV ECX, WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY - MOV EDX, offset[StaticClass] - CALL _NewControl - MOV word ptr [EAX].TControl.aAutoSzX, $101 - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG1, (1 shl G1_SizeRedraw) or (1 shl G1_IsStaticControl) - {$ELSE} - INC [EAX].TControl.fIsStaticControl - INC [EAX].TControl.fSizeRedraw - {$ENDIF} - MOV EDX, [EAX].TControl.fBoundsRect.Top - ADD EDX, 22 - MOV [EAX].TControl.fBoundsRect.Bottom, EDX - POP EDX - PUSH EAX - CALL TControl.SetCaption - POP EAX - -{$IFDEF GRAPHCTL_XPSTYLES} - PUSH EAX - MOV EDX, offset[XP_Themes_For_Label] - CALL Attach_WM_THEMECHANGED - POP EAX -{$ENDIF} -end; - -function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl; -asm - PUSH EDX - PUSH 0 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [ButtonActions_Packed] - {$ELSE} - PUSH offset[ButtonActions] - {$ENDIF} - MOV EDX, offset[ButtonClass] - MOV ECX, WS_VISIBLE or WS_CHILD or BS_GROUPBOX or WS_CLIPCHILDREN or WS_CLIPSIBLINGS - CALL _NewControl - OR [EAX].TControl.fExStyle, WS_EX_CONTROLPARENT - MOV EDX, [EAX].TControl.fBoundsRect.Left - ADD EDX, 100 - MOV [EAX].TControl.fBoundsRect.Right, EDX - MOV EDX, [EAX].TControl.fBoundsRect.Top - ADD EDX, 100 - MOV [EAX].TControl.fBoundsRect.Bottom, EDX - MOV byte ptr [EAX].TControl.fClientTop, 22 - XOR EDX, EDX - {$IFDEF USE_FLAGS} - AND [EAX].TControl.fStyle.f2_Style, not(1 shl F2_Tabstop) - {$ELSE} - MOV [EAX].TControl.fTabstop, DL - {$ENDIF USE_FLAGS} - MOV DL, 2 - ADD [EAX].TControl.fClientBottom, DL - ADD [EAX].TControl.fClientLeft, DL - ADD [EAX].TControl.fClientRight, DL - POP EDX - PUSH EAX - CALL TControl.SetCaption - POP EAX - PUSH EAX - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG5, 1 shl G5_IsGroupbox - {$ELSE} - INC [EAX].TControl.fIsGroupBox - {$ENDIF} - MOV EDX, offset[WndProcDoEraseBkgnd] - CALL TControl.AttachProc - POP EAX - -{$IFDEF GRAPHCTL_XPSTYLES} - PUSH EAX - MOV EDX, offset[XP_Themes_For_GroupBox] - CALL Attach_WM_THEMECHANGED - POP EAX -{$ENDIF} -end; - -function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl; -const CreateStyle = WS_VISIBLE or WS_CHILD or SS_LEFTNOWORDWRAP or - SS_NOPREFIX or SS_NOTIFY; -asm -{$IFDEF GRAPHCTL_XPSTYLES} - MOVZX EDX, EdgeStyle - PUSH EDX -{$ENDIF} - - PUSH EDX - MOV EDX, offset[StaticClass] - MOV ECX, CreateStyle - PUSH 0 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [LabelActions_Packed] - {$ELSE} - PUSH offset[LabelActions] - {$ENDIF} - CALL _NewControl - //INC byte ptr [EAX].TControl.aAutoSzX - //INC byte ptr [EAX].TControl.aAutoSzY - MOV word ptr [EAX].TControl.aAutoSzX, $101 - ADD [EAX].TControl.fBoundsRect.Right, 100-64 - ADD [EAX].TControl.fBoundsRect.Bottom, 100-64 - OR byte ptr [EAX].TControl.fExStyle+2, 1 - POP ECX - CMP CL, 1 - JG @@exit - JE @@sunken - OR byte ptr [EAX].TControl.fStyle+2, $40 -{$IFDEF GRAPHCTL_XPSTYLES} - JMP @@visual -{$ELSE} - RET -{$ENDIF} -@@sunken: - OR byte ptr [EAX].TControl.fStyle+1, $10 -@@exit: - -{$IFDEF GRAPHCTL_XPSTYLES} -@@visual: - CMP AppTheming, TRUE - JNE @@es_none_ - CMP CL, 1 - JG @@es_none_ - JE @@not_sunken - AND byte ptr [EAX].TControl.fStyle+2, $00 - JNE @@es_none_ -@@not_sunken: - AND byte ptr [EAX].TControl.fStyle+1, $00 -@@es_none_: - POP EDX - PUSH EAX - CALL TControl.SetEdgeStyle - POP EAX - PUSH EAX - MOV EDX, offset[XP_Themes_For_Panel] - CALL Attach_WM_THEMECHANGED - POP EAX -{$ENDIF} -end; - -const ListBoxClass : Array[ 0..7 ] of AnsiChar = ( 'L','I','S','T','B','O','X',#0 ); -function NewListbox( AParent: PControl; Options: TListOptions ): PControl; -asm - PUSH EAX - PUSH EDX - MOV EAX, ESP - MOV EDX, offset[ListFlags] - XOR ECX, ECX - MOV CL, 11 - CALL MakeFlags - POP EDX - OR EAX, WS_VISIBLE or WS_CHILD or WS_TABSTOP or WS_BORDER or WS_VSCROLL or LBS_NOTIFY - XCHG ECX, EAX - POP EAX - PUSH 1 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [ListActions_Packed] - {$ELSE} - PUSH offset[ListActions] - {$ENDIF} - MOV EDX, offset[ListBoxClass] - CALL _NewControl - {$IFDEF PACK_COMMANDACTIONS} - MOV EDX, [EAX].TControl.fCommandActions - MOV [EDX].TCommandActionsObj.aClear, offset[ClearListbox] - {$ENDIF} - ADD [EAX].TControl.fBoundsRect.Right, 100 - ADD [EAX].TControl.fBoundsRect.Bottom, 200-64 - MOV [EAX].TControl.fColor, clWindow - MOV [EAX].TControl.fLookTabKeys, 3 -end; - -procedure CreateComboboxWnd( Combo: PControl ); -//const PrevProcStr: PAnsiChar = 'PREV_PROC'; //************ Remarked By M.Gerasimov -asm - PUSH EDI - PUSH EBX - XCHG EBX, EAX - PUSH GW_CHILD - PUSH [EBX].TControl.fHandle -@@getwindow: - CALL GetWindow - TEST EAX, EAX - JZ @@fin - PUSH offset[WndFuncCombo] - PUSH GWL_WNDPROC - PUSH EAX - XCHG EDI, EAX - CALL SetWindowLong - PUSH EAX - PUSH offset [ID_PREVPROC] // - PUSH EDI - CALL SetProp -@@2getnext: - PUSH GW_HWNDNEXT - PUSH EDI - JMP @@getwindow -@@fin: POP EBX - POP EDI -end; - -{$IFDEF WNDPROCTREEVIEW_OLDASMVERSION} -function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm //cmd //opd - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNZ @@ret_false - PUSH EBX - XCHG EBX, EAX - MOV EDX, [EDX].TMsg.lParam - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - LEA EAX, [EAX].TEvents.fOnTVBeginDrag - {$ELSE} - LEA EAX, [EBX].TControl.EV.fOnTVBeginDrag - {$ENDIF} - CMP word ptr [EDX].TNMTreeView.hdr.code, NM_RCLICK - JNE @@chk_TVN_BEGINDRAG - PUSH ECX - PUSH ECX - PUSH ESP - CALL GetCursorPos - MOV EAX, EBX - MOV EDX, ESP - MOV ECX, EDX - CALL TControl.Screen2Client - POP EAX - AND EAX, $FFFF - POP EDX - SHL EDX, 16 - OR EAX, EDX - PUSH EAX - CALL GetShiftState - PUSH EAX - PUSH WM_RBUTTONUP - PUSH [EBX].TControl.fHandle - CALL PostMessage - JMP @@2fin_false1 - -@@chk_TVN_BEGINDRAG: - {$IFDEF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINDRAGW - JZ @@event_drag - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINRDRAGW - JZ @@event_drag - {$ENDIF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINDRAG - JZ @@event_drag - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINRDRAG - JNZ @@chk_BEGINLABELEDIT -@@event_drag: - MOV EDX, [EDX].TNMTreeView.itemNew.hItem -@@event_call: - MOV ECX, [EAX].TMethod.Code - JECXZ @@2fin_false1 - MOV EAX, [EAX].TMethod.Data - XCHG EBX, ECX - XCHG EDX, ECX - CALL EBX -@@2fin_false1: JMP @@fin_false -@@chk_BEGINLABELEDIT: - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - LEA EAX, [EAX].TEvents.FOnTVBeginEdit - {$ELSE} - LEA EAX, [EBX].TControl.EV.fOnTVBeginEdit - {$ENDIF} - {$IFDEF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINLABELEDITW - JZ @@beginlabeledit - {$ENDIF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_BEGINLABELEDIT - JNZ @@chk_ITEMEXPANDED //@@chk_DELETEITEM -@@beginlabeledit: - {$IFDEF USE_FLAGS} - TEST [EBX].TControl.fFlagsG6, 1 shl G6_Dragging - {$ELSE} - CMP [EBX].TControl.fDragging, 0 - {$ENDIF} - JZ @@allow_LABELEDIT - XOR EAX, EAX - INC EAX - MOV [ECX], EAX - JMP @@ret_true - -@@allow_LABELEDIT: - PUSH ECX // @Rslt - - MOV ECX, [EAX].TMethod.Code - JECXZ @@2fin_false1 - PUSH EBX - XCHG EBX, ECX - MOV EDX, [EDX].TTVDispInfo.item.hItem - XCHG EDX, ECX - MOV EAX, [EAX].TMethod.Data - CALL EBX - TEST AL, AL - SETZ AL // Rslt := not event result; - POP EBX - JMP @@ret_EAX - -@@call_EBX: - CALL EBX -@@2fin_false: - JMP @@fin_false -@@chk_ITEMEXPANDED: - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EBX].TControl.EV - LEA EAX, [EAX].TEvents.fOnTVExpanded - {$ELSE} - LEA EAX, [EBX].TControl.EV.fOnTVExpanded - {$ENDIF} - {$IFDEF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDEDW - JZ @@itemexpanded - {$ENDIF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDED - JNZ @@chk_SELCHANGING -@@itemexpanded: - MOV ECX, [EAX].TMethod.Code - JECXZ @@2fin_false - CMP [EDX].TNMTreeView.action, TVE_EXPAND - PUSH ECX - SETZ CL - XCHG ECX, [ESP] - JMP @@event_drag -@@chk_SELCHANGING: - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_SELCHANGING - JNE @@chk_ITEMEXPANDING - XCHG EAX, ECX - {$IFDEF EVENTS_DYNAMIC} - MOV ECX, [EBX].TControl.EV - MOV ECX, [ECX].TEvents.fOnTVSelChanging.TMethod.Code - {$ELSE} - MOV ECX, [EBX].TControl.EV.fOnTVSelChanging.TMethod.Code - {$ENDIF} -@@2fin_false2: - JECXZ @@2fin_false - PUSH EAX //@Rslt - PUSH [EDX].TNMTreeView.itemNew.hItem - XCHG ECX, EBX //EBX=OnTVSelChanging.Code ECX=Sender - XCHG ECX, EDX //EDX=Sender ECX=Msg - MOV ECX, [ECX].TNMTreeView.itemOld.hItem - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EDX].TControl.EV - MOV EAX, [EAX].TEvents.fOnTVSelChanging.TMethod.Data - {$ELSE} - MOV EAX, [EDX].TControl.EV.fOnTVSelChanging.TMethod.Data - {$ENDIF} - CALL EBX - XOR AL, 1 - MOVZX EAX, AL - JMP @@ret_EAX - -@@chk_ITEMEXPANDING: - {$IFDEF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDINGW - JZ @@itemexpanding - {$ENDIF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDING - JNE @@chk_ENDLABELEDIT -@@itemexpanding: - XCHG EAX, ECX - {$IFDEF EVENTS_DYNAMIC} - MOV ECX, [EBX].TControl.EV - MOV ECX, [ECX].TEvents.fOnTVExpanding.TMethod.Code - {$ELSE} - MOV ECX, [EBX].TControl.EV.fOnTVExpanding.TMethod.Code - {$ENDIF} - JECXZ @@2fin_false2 - PUSH EAX // @Rslt - CMP [EDX].TNMTreeView.action, TVE_EXPAND - PUSH ECX - SETZ CL - XCHG ECX, [ESP] - XCHG ECX, EBX //EBX=OnTVExpanding.Code ECX=Seneder - XCHG EDX, ECX //ECX=Msg EDX=Sender - MOV ECX, [ECX].TNMTreeView.itemNew.hItem //ECX=Item - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EDX].TControl.EV - MOV EAX, [EAX].TEvents.fOnTVExpanding.TMethod.Data - {$ELSE} - MOV EAX, [EDX].TControl.EV.fOnTVExpanding.TMethod.Data //EAX=object - {$ENDIF} -@@111: - CALL EBX -@@ret_EAX: - POP EDX //EDX=@Rslt - MOVZX EAX, AL - NEG EAX - MOV [EDX], EAX -@@ret_true: - MOV AL, 1 - POP EBX - RET -@@chk_ENDLABELEDIT: - {$IFDEF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ENDLABELEDITW - JZ @@endlabeledit - {$ENDIF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_ENDLABELEDIT - JNZ @@chk_SELCHANGED -@@endlabeledit: - XCHG EAX, ECX - {$IFDEF EVENTS_DYNAMIC} - MOV ECX, [EBX].TControl.EV - MOV ECX, [ECX].TEvents.fOnTVEndEdit.TMethod.Code - {$ELSE} - MOV ECX, [EBX].TControl.EV.fOnTVEndEdit.TMethod.Code - {$ENDIF} - JECXZ @@ret_1 - PUSH EAX - PUSH EBX - PUSH 0 - - XCHG EDX, EBX - MOV EAX, [EBX].TTVDispInfo.item.pszText - PUSH EDX - PUSH ECX - XCHG EAX, EDX - {$IFDEF UNICODE_CTRLS} - CMP [EBX].TNMTreeView.hdr.code, TVN_ENDLABELEDITW - JNZ @@endlabeleditA - CALL TControl.TVGetItemTextW - JMP @@NewTxt_ready -@@endlabeleditA: - {$ENDIF UNICODE_CTRLS} - TEST EDX, EDX - JNZ @@prepare_NewTxt - // NewTxt := [EDX].TControl.TVItemText[ hItem ] - LEA ECX, [ESP + 8] - MOV EDX, [EBX].TTVDispInfo.item.hItem - CALL TControl.TVGetItemText - JMP @@NewTxt_ready -@@prepare_NewTxt: - LEA EAX, [ESP+8] - {$IFDEF _D2009orHigher} - PUSH ECX - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - {$IFDEF _D2009orHigher} - POP ECX - {$ENDIF} -@@NewTxt_ready: - POP ECX - POP EDX - POP EAX - PUSH EAX - PUSH EAX - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EDX].TControl.EV - MOV EAX, [EAX].TEvents.fOnTVEndEdit.TMethod.Data - {$ELSE} - MOV EAX, [EDX].TControl.EV.fOnTVEndEdit.TMethod.Data - {$ENDIF} - MOV EBX, [EBX].TTVDispInfo.item.hItem - XCHG ECX, EBX - CALL EBX - XCHG EBX, EAX - CALL RemoveStr - XCHG EAX, EBX - POP EBX - JMP @@ret_EAX -@@ret_1: - INC ECX - MOV [EAX], ECX - JMP @@ret_true - -@@chk_SELCHANGED: - {$IFDEF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_SELCHANGEDW - JZ @@selchanged - {$ENDIF UNICODE_CTRLS} - CMP word ptr [EDX].TNMTreeView.hdr.code, TVN_SELCHANGED - JNZ @@fin_false -@@selchanged: - XCHG EAX, EBX - CALL TControl.DoSelChange - -@@fin_false: - POP EBX -@@ret_false: - XOR EAX, EAX -end; -{$ELSE NEW VERSION OF WndProcTreeView} -function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - PUSH ESI - PUSH EDI - MOV EDI, ECX // EDI -> Rslt - XOR ECX, ECX - CMP WORD PTR [EDX].TMsg.message, WM_NOTIFY - JNZ @@ret_false1 - XCHG ESI, EAX - MOV EDX, [EDX].TMsg.lParam - CMP WORD PTR [EDX].TNMTreeView.hdr.code, NM_RCLICK - JNE @@chk_TVN_BEGINDRAG - PUSH ECX - PUSH ECX - PUSH ESP - CALL GetCursorPos - MOV EAX, ESI - MOV EDX, ESP - MOV ECX, EDX - CALL TControl.Screen2Client - POP EDX - POP EAX - SHLD EAX, EDX, 16 - PUSH EAX - CALL GetShiftState - PUSH EAX - PUSH WM_RBUTTONUP - PUSH ESI - CALL TControl.PostMsg - JMP @@ret_false1 -@@prepareCallEvent: - STC - MOV EDX, ESI - {$IFDEF EVENTS_DYNAMIC} - MOV ESI, [ESI].TControl.EV - LEA ECX, [ESI+ECX*8].TEvents.fOnTVBeginDrag - {$ELSE} - LEA ECX, [ESI+ECX*8].TControl.EV.fOnTVBeginDrag - {$ENDIF} - MOV EAX, [ECX].TMethod.Data - MOV ECX, [ECX].TMethod.Code - JECXZ @@noEvent - MOV ESI, ECX - AND EAX, EAX -@@noEvent: - RET -@@chk_TVN_BEGINDRAG: /////////////////////////////////////////////////////////// - CMP WORD PTR [EDX].TNMTreeView.hdr.code, TVN_BEGINDRAG - JE @@beginDrag - CMP WORD PTR [EDX].TNMTreeView.hdr.code, TVN_BEGINRDRAG - JNE @@chk_TVNBEGINLABELEDIT -@@beginDrag: - PUSH [EDX].TNMTreeView.itemNew.hItem - CALL @@prepareCallEvent - POP ECX - JC @@ret_false1 -@@justEventCall: - CALL ESI -@@RsltEAX_ResultFalse: - MOV [EDI], EAX - XOR EAX, EAX - POP EDI - POP ESI - RET -@@chk_TVNBEGINLABELEDIT: /////////////////////////////////////////////////////// - INC ECX // -> FOnTVBeginEdit - CMP WORD PTR [EDX].TNMTreeView.hdr.code, TVN_BEGINLABELEDIT - JNE @@chk_ENDLABELEDIT - /////////////////////////////////////////////////////////////////////// - XOR EAX, EAX - INC EAX - {$IFDEF USE_FLAGS} - TEST [ESI].TControl.fFlagsG6, 1 shl G6_Dragging - {$ELSE} - CMP [ESI].TControl.fDragging, 0 - {$ENDIF} - JNZ @@rsltEAX_ResultTrue - PUSH [EDX].TTVDispInfo.item.hItem - CALL @@prepareCallEvent - POP ECX - JC @@ret_false1 - CALL ESI - XOR AL, 1 //+Dufa -@@rsltEAX_ResultTrue: - MOV [EDI], AL //+VK -@@ResultTrue: - MOV AL, 1 - POP EDI - POP ESI - RET -@@chk_ENDLABELEDIT: - INC ECX // -> fOnTVEndEdit - CMP WORD PTR [EDX].TNMTreeView.hdr.code, TVN_ENDLABELEDIT - JNE @@chk_ITEMEXPANDING - MOV EAX, [EDX].TTVDispInfo.item.pszText - TEST EAX, EAX - JZ @@ResultTrue - PUSH EAX - PUSH [EDX].TTVDispInfo.item.hItem - CALL @@prepareCallEvent - POP ECX - //JNC @@justEventCall ---//dufa - JC @@ret_false1 //dufa - CALL ESI //dufa - JMP @@rsltEAX_ResultTrue //dufa -@@Rslt1_ResultTrue: - XOR EAX, EAX - INC EAX - JMP @@RsltEAX_ResultFalse -@@chk_ITEMEXPANDING: /////////////////////////////////////////////////////////// - INC ECX // -> FOnTVExpanding - CMP WORD PTR [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDING - JNE @@chk_ITEMEXPANDED -@@expanding_expanded: - CMP [EDX].TNMTreeView.action, TVE_EXPAND - SETZ AL - PUSH EAX - PUSH [EDX].TNMTreeView.itemNew.hItem -@@event3: - CALL @@prepareCallEvent - POP ECX - JNC @@justEventCall - POP EAX - JMP @@ret_false1 -@@chk_ITEMEXPANDED: //////////////////////////////////////////////////////////// - INC ECX // -> FOnTVExpanded - CMP [EDX].TNMTreeView.hdr.code, TVN_ITEMEXPANDED - JE @@expanding_expanded - /////////////////////////////////////////////////////////////////////// - INC ECX // -> FOnTVSelChanging - CMP [EDX].TNMTreeView.hdr.code, TVN_SELCHANGING - JNE @@chk_TVN_SELCHANGED - PUSH [EDX].TNMTreeView.itemNew.hItem - PUSH [EDX].TNMTreeView.itemOld.hItem - JMP @@event3 -@@chk_TVN_SELCHANGED: - CMP [EDX].TNMTreeView.hdr.code, TVN_SELCHANGED - JNE @@ret_false1 - XCHG EAX, ESI - CALL TControl.DoSelChange -@@ret_false1: - XOR EAX, EAX - POP EDI - POP ESI -end; -{$ENDIF} - -function NewTabControl( AParent: PControl; const Tabs: array of PKOLChar; Options: TTabControlOptions; - ImgList: PImageList; ImgList1stIdx: Integer ): PControl; -const lenf=high(TabControlFlags); //+++ -asm //cmd //opd - PUSH EBX - PUSH ESI - PUSH EDI - XCHG EBX, EAX - PUSH EDX - PUSH ECX - LEA EAX, [Options] - MOV EDX, offset[TabControlFlags] - XOR ECX, ECX - MOV CL, lenf - CALL MakeFlags - TEST byte ptr [Options], 4 - JZ @@0 - OR EAX, WS_TABSTOP or TCS_FOCUSONBUTTONDOWN -@@0: OR EAX, WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE - XCHG ECX, EAX - XCHG EAX, EBX - MOV EDX, offset[WC_TABCONTROL] - PUSH 1 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [TabControlActions_Packed] - {$ELSE} - PUSH offset[TabControlActions] - {$ENDIF} - CALL _NewCommonControl - MOV EBX, EAX - TEST [Options], 2 shl (tcoBorder - 1) - JNZ @@borderfixed - AND [EBX].TControl.fExStyle, not WS_EX_CLIENTEDGE -@@borderfixed: - MOV EDX, offset[WndProcTabControl] - CALL TControl.AttachProc - ADD [EBX].TControl.fBoundsRect.Right, 100-64 - ADD [EBX].TControl.fBoundsRect.Bottom, 100-64 - MOV ECX, [ImgList] - JECXZ @@2 - XCHG EAX, ECX - CALL TImageList.GetHandle - PUSH EAX - PUSH 0 - PUSH TCM_SETIMAGELIST - PUSH EBX - CALL TControl.Perform -@@2: - POP EDI // EDI = High(Tabs) - POP ESI // ESI = Tabs - XOR EDX, EDX // EDX := 0 (=I) - MOV EAX, [ImgList1stIdx] //(=II) -@@loop: - CMP EDX, EDI - JG @@e_loop - PUSH EAX - PUSH EDX - PUSH EAX - LODSD - XCHG ECX, EAX - MOV EAX, EBX - CALL TControl.TC_Insert - POP EDX - POP EAX - INC EAX - INC EDX - JMP @@loop -@@e_loop: - MOV byte ptr [EBX].TControl.fLookTabKeys, 1 - XCHG EAX, EBX - POP EDI - POP ESI - POP EBX -end; - -function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions; - Bitmap: HBitmap; const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer ) : PControl; -const szTBButton = Sizeof( TTBButton ); - Option3DBorder = 1 shl Ord( tbo3DBorder ); -asm //cmd //opd - PUSH EDI - MOVZX EDX, DL - PUSH EDX // Align - PUSH EAX // AParent - - XOR EAX, EAX - TEST CL, Option3DBorder - SETNZ AL - PUSH EAX - - PUSH ECX // Options - - MOV AL, ICC_BAR_CLASSES - CALL DoInitCommonControls - - MOV EAX, ESP - MOV EDX, offset[ToolbarOptions] - XOR ECX, ECX - MOV CL, 6 - CALL MakeFlags - POP EDX - - {$IFDEF COMMANDACTIONS_OBJ} - PUSH TOOLBAR_ACTIONS - {$ELSE} - PUSH 0 //: actions : = nil - {$ENDIF} - XCHG ECX, EAX // ECX = MakeFlags(...) - MOV EDI, ECX - MOV EAX, [ESP+8] // EAX = AParent - MOV EDX, [ESP+12] // EDX = Align - OR ECX, [EDX*4+offset ToolbarAligns] - OR ECX, WS_CHILD or WS_VISIBLE or TBSTYLE_TOOLTIPS - MOV EDX, offset[ TOOLBARCLASSNAME ] - CALL _NewCommonControl - {$IFDEF COMMANDACTIONS_OBJ} - MOV EDX, [EAX].TControl.fCommandActions - MOV [EDX].TCommandActionsObj.aClear, offset[ClearToolbar] - MOV [EDX].TCommandActionsObj.aGetCount, TB_BUTTONCOUNT - {$ELSE} - MOV [EAX].TControl.fCommandActions.aClear, offset[ClearToolbar] - MOV [EAX].TControl.fCommandActions.aGetCount, TB_BUTTONCOUNT - {$ENDIF} - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG5, 1 shl G5_IsButton - {$ELSE} - INC [EAX].TControl.fIsButton - {$ENDIF} - POP EDX // pop AParent - POP EDX // EDX = Align - PUSH EDX - TEST EDX, EDX - JE @@zero_bounds - ADD [EAX].TControl.fBoundsRect.Bottom, 26-64 - ADD [EAX].TControl.fBoundsRect.Right, 1000-64 - JMP @@bounds_ready -@@zero_bounds: - MOV [EAX].TControl.fBoundsRect.Left, EDX - MOV [EAX].TControl.fBoundsRect.Top, EDX - MOV [EAX].TControl.fBoundsRect.Right, EDX - MOV [EAX].TControl.fBoundsRect.Bottom, EDX -@@bounds_ready: - PUSH EBX - PUSH ESI - XCHG EBX, EAX - MOV ESI, offset[TControl.Perform] - PUSH 0 - PUSH 0 - PUSH TB_GETEXTENDEDSTYLE - PUSH EBX - CALL ESI - OR EAX, TBSTYLE_EX_DRAWDDARROWS - PUSH EAX - PUSH 0 - PUSH TB_SETEXTENDEDSTYLE - PUSH EBX - CALL ESI - MOV EDX, offset[WndProcToolbarCtrl] - MOV EAX, EBX - CALL TControl.AttachProc - MOV EDX, offset[WndProcDoEraseBkgnd] - MOV EAX, EBX - CALL TControl.AttachProc - PUSH 0 - PUSH szTBButton - PUSH TB_BUTTONSTRUCTSIZE - PUSH EBX - CALL ESI - PUSH 0 - MOVSX EAX, [EBX].TControl.fMargin - PUSH EAX - PUSH TB_SETINDENT - PUSH EBX - CALL ESI - MOV EAX, [ESP+8] // Align - {$IFDEF PARANOIA} DB $2C, 1 {$ELSE} SUB AL, 1 {$ENDIF} - JL @@bounds_correct - JE @@corr_right - {$IFDEF PARANOIA} DB $2C, 2 {$ELSE} SUB AL, 2 {$ENDIF} - JNE @@corr_bottom - @@corr_right: - MOV EDX, [EBX].TControl.fBoundsRect.Left - ADD EDX, 24 - MOV [EBX].TControl.fBoundsRect.Right, EDX - JMP @@bounds_correct - @@corr_bottom: - MOV EDX, [EBX].TControl.fBoundsRect.Top - ADD EDX, 22 - MOV [EBX].TControl.fBoundsrect.Bottom, EDX - @@bounds_correct: - {$IFnDEF TBBUTTONS_DFLT_NOAUTOSIZE} - MOV byte ptr [EBX].TControl.DF.fDefaultTBBtnStyle, TBSTYLE_AUTOSIZE - {$ENDIF} - MOV EDX, [Bitmap] - TEST EDX, EDX - JZ @@bitmap_added - MOV EAX, EBX - CALL TControl.TBAddBitmap - @@bitmap_added: - - PUSH dword ptr [BtnImgIdxArray] - PUSH dword ptr [BtnImgIdxArray-4] - MOV ECX, [Buttons-4] - MOV EDX, [Buttons] - MOV EAX, EBX - CALL TControl.TBAddButtons - - PUSH 0 - PUSH 0 - PUSH WM_SIZE - PUSH EBX - CALL ESI - // --- - {+|ecm|} - // --- - MOV EDX,EDI - OR EDX,[EBX].TControl.FStyle - MOV EAX,EBX - CALL TControl.SetStyle - // --- - {/+|ecm|} - // --- - XCHG EAX, EBX - POP ESI - POP EBX - POP EDX - POP EDI -end; - -function WndProcDateTimePickerNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -type - TStrStr = record - param_Date: TDateTime; - param_PtrToAccept: PInteger; - Accept: Integer; - UserString: String; - end; -const Size_TStrStr = sizeof( TStrStr ); -asm - PUSH ESI - PUSH EDI - MOV EDI, EDX - CMP WORD PTR [EDI].TMsg.message, WM_NOTIFY - JNZ @@ret_false - {$IFDEF EVENTS_DYNAMIC} - MOV ESI, [EAX].TControl.EV - {$ENDIF} - MOV ECX, [EDI].TMsg.lParam - MOV EDX, [ECX].TNMHdr.code - CMP EDX, DTN_DROPDOWN - JNZ @@chk_DTN_CLOSEUP - {$IFDEF EVENTS_DYNAMIC} - LEA ECX, [ESI].TEvents.fOnDropDown.TMethod.Code - {$ELSE} - LEA ECX, [EAX].TControl.EV.fOnDropDown.TMethod.Code - {$ENDIF} -@@event1: - MOV EDX, [ECX].TMethod.Data - MOV ECX, [ECX].TMethod.Code - {$IFDEF NIL_EVENTS} - JECXZ @@ret_false - {$ENDIF} - XCHG EAX, EDX - CALL ECX - JMP @@ret_false -@@chk_DTN_CLOSEUP: ///////////////////////////////////////////////////////////// - {$IFDEF EVENTS_DYNAMIC} - LEA ECX, [ESI].TEvents.fOnCloseUp.TMethod.Code - {$ELSE} - LEA ECX, [EAX].TControl.EV.fOnCloseUp.TMethod.Code - {$ENDIF} - CMP EDX, DTN_CLOSEUP - JE @@event1 -//////////////////////////////////////////////////////////////////////////////// - {$IFDEF EVENTS_DYNAMIC} - LEA ECX, [ESI].TEvents.fOnChangeCtl.TMethod.Code - {$ELSE} - LEA ECX, [EAX].TControl.EV.fOnChangeCtl.TMethod.Code - {$ENDIF} - CMP EDX, DTN_DATETIMECHANGE - JE @@event1 - CMP EDX, DTN_USERSTRING - JNE @@ret_false -//////////////////////////////////////////////////////////////////////////////// - {$IFDEF EVENTS_DYNAMIC} - MOV ECX, [ESI].TEvents.fOnDTPUserString.TMethod.Code - MOV EDX, [ESI].TEvents.fOnDTPUserString.TMethod.Data - {$ELSE} - MOV ECX, [EAX].TControl.EV.fOnDTPUserString.TMethod.Code - MOV EDX, [EAX].TControl.EV.fOnDTPUserString.TMethod.Data - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@ret_false - {$ENDIF} - SUB ESP, Size_TStrStr - MOV ESI, ESP - PUSHAD - CALL TControl.GetDateTime - FSTP QWORD PTR [ESI].TStrStr.param_Date - WAIT - //POPAD - //PUSHAD - LEA EAX, [ESI].TStrStr.UserString - AND dword ptr [EAX], 0 - MOV EDI, [EDI].TMsg.lParam - MOV EDX, [EDI].TNMDateTimeString.pszUserString - CALL System.@LStrFromPChar - LEA EAX, [ESI].TStrStr.Accept - MOV byte ptr [EAX], 1 - MOV [ESI].TStrStr.param_PtrToAccept, EAX - POPAD - MOV ESI, ECX - MOV ECX, [ESI].TStrStr.UserString - XCHG EAX, EDX - CALL ESI - MOV EAX, [ESP].TStrStr.Accept - AND EAX, 1 - MOV [EDI].TNMDateTimeString.dwFlags, EAX - LEA EAX, [ESI].TStrStr.UserString - CALL System.@LStrClr - ADD ESP, Size_TStrStr -@@ret_false: - XOR EAX, EAX - POP EDI - POP ESI -end; - -function TControl.GetWindowHandle: HWnd; -asm - MOV ECX, [EAX].fHandle - JECXZ @@1 - XCHG EAX, ECX - RET -@@1: - PUSH EBX - MOV EBX, EAX - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG4, 1 shl G4_CreateVisible - {$ELSE} - CMP [EBX].fCreateVisible, 0 - {$ENDIF} - JNZ @@2 - - XOR EDX, EDX - CALL TControl.Set_Visible - - MOV EAX, EBX - CALL CallTControlCreateWindow - { This is a call to Pascal piece of code, which - calls virtual method TControl.CreateWindow } - - {$IFDEF USE_FLAGS} - OR [EBX].fFlagsG4, 1 shl G4_CreateHidden - {$ELSE} - INC [EBX].fCreateHidden - {$ENDIF} - JMP @@0 - -@@2: CALL CallTControlCreateWindow -@@0: MOV EAX, [EBX].fHandle - POP EBX -end; - -function TControl.CreateWindow: Boolean; -type PCreateWndParams = ^TCreateWndParams; -const - CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS; - CS_ON = 0; //CS_VREDRAW or CS_HREDRAW; - szWndClass = sizeof( TWndClass ); - int_IDC_ARROW = integer( IDC_ARROW ); -asm - PUSH EBX - XCHG EBX, EAX - {$IFDEF DEBUG_CREATEWINDOW} - MOV EAX, EBX - CALL Debug_CreateWindow1 - {$ENDIF} - MOV ECX, [EBX].fParent - JECXZ @@chk_handle - XCHG EAX, ECX - CALL GetWindowHandle - TEST EAX, EAX - JZ @@ret_0 -@@chk_handle: - MOV ECX, [EBX].fHandle - JECXZ @@prepare_Params - MOV EAX, EBX - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG4, 1 shl G4_CreateHidden - {$ELSE} - CMP [EBX].fCreateHidden, 0 - {$ENDIF} - JZ @@create_children - CALL CreateChildWindows - MOV EAX, EBX - MOV DL, 1 - CALL Set_Visible - {$IFDEF USE_FLAGS} - AND [EBX].fFlagsG4, not(1 shl G4_CreateHidden) - {$ELSE} - MOV [EBX].fCreateHidden, 0 - {$ENDIF} - JMP @@ret_true -@@create_children: - CALL CreateChildWindows -@@ret_true: - MOV AL, 1 -@@ret_0: - POP EBX - RET -@@prepare_params: - {$IFDEF USE_GRAPHCTLS} - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG6, 1 shl G6_GraphicCtl - SETNZ AL - JNZ @@ret_0 - {$ELSE} - MOV AL, [EBX].fWindowed - CMP AL, 0 - JZ @@ret_0 - {$ENDIF} - {$ENDIF} - PUSH EBP - MOV EBP, ESP - - PUSH ECX // Params.WindowClass.lpszClassName := nil - PUSH ECX // Params.WindowClass.lpszMenuName := nil - PUSH ECX // Params.WindowClass.hbrBackground := 0 - PUSH int_IDC_ARROW - PUSH ECX - CALL LoadCursor - PUSH EAX // Params.WindowClass.hCursor := LoadCursor( 0, IDC_ARROW ) - XOR ECX, ECX - PUSH ECX // Params.WindowClass.hIcon := 0 - PUSH [hInstance]// Params.WindowClass.hInstance := hInstance - PUSH ECX // Params.WindowClass.cbWndExtra := 0 - PUSH ECX // Params.WindowClass.cbClsExtra := 0 - {$IFDEF SAFE_CODE} - PUSH [EBX].fDefWndProc // Params.WindowClass.lpfnWndProc := fDefWndProc - {$ELSE} - PUSH 0 - {$ENDIF} - PUSH [EBX].fClsStyle // Params.WindowClass.style := fStyle - ADD ESP, -64 - PUSH ECX - MOV EAX, EBX - MOV EDX, ESP - CALL get_ClassName - POP EDX - MOV EAX, ESP - PUSH EDX - //CALL StrPCopy // StrPCopy( Params.WinClsNamBuf, ClassName ) - CALL StrCopy - CALL RemoveStr - PUSH 0 // Params.Param := nil - PUSH [hInstance] // Params.Inst := hInstance - PUSH [EBX].fMenu // Params.Menu := fMenu - MOV DL, 1 - MOV EAX, EBX - CALL GetParentWnd - PUSH EAX // Params.WndParent := GetParentWnd( True ) - - MOV ECX, CW_USEDEFAULT - MOV EAX, [EBX].fBoundsRect.Bottom - MOV EDX, [EBX].fBoundsRect.Top - SUB EAX, EDX - JNZ @@1 - MOV EAX, ECX -@@1: PUSH EAX // Params.Height := Height | CW_UseDefault - MOV EAX, [EBX].fBoundsRect.Right - SUB EAX, [EBX].fBoundsRect.Left - {$IFDEF USE_CMOV} - CMOVZ EAX, ECX - {$ELSE} - JNZ @@2 - MOV EAX, ECX -@@2: {$ENDIF} - - PUSH EAX // Params.Width := Width | CW_UseDefault - MOV EAX, [EBX].fBoundsRect.Left - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG3, 1 shl G3_IsControl - {$ELSE} - CMP [EBX].fIsControl, CL - {$ENDIF} - JNZ @@3 - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG2, (1 shl G2_ChangedPos) - {$ELSE} - TEST byte ptr [EBX].fChangedPosSz, 3 - {$ENDIF USE_FLAGS} - JNZ @@3 - MOV EDX, ECX - XCHG EAX, ECX -@@3: PUSH EDX // Params.Y := Top | CW_UseDefault - PUSH EAX // Params.X := Left | CW_UseDefault - PUSH [EBX].fStyle // Params.Style := fStyle - PUSH [EBX].fCaption // Params.Caption := fCaption - LEA EAX, [ESP+40] - PUSH EAX // Params.WinClassName := @Params.WinClsNamBuf - PUSH [EBX].fExStyle // Params.ExStyle := fExStyle - - MOV ECX, [EBX].fControlClassName - JECXZ @@registerClass - LEA EAX, [ESP].TCreateWndParams.WindowClass - PUSH EAX // @Params.WindowClass - PUSH ECX // fControlClassName - PUSH [hInstance] // hInstance - CALL GetClassInfo - MOV EAX, [ESP].TCreateWndParams.Inst - MOV [ESP].TCreateWndParams.WindowClass.hInstance, EAX - AND [ESP].TCreateWndParams.WindowClass.style, not CS_OFF -@@registerClass: - CMP [EBX].fDefWndProc, 0 - JNE @@fDefWndProc_ready - MOV EAX, [ESP].TCreateWndParams.WindowClass.lpfnWndProc - MOV [EBX].fDefWndProc, EAX -@@fDefWndProc_ready: - MOV ECX, [ESP].TCreateWndParams.WndParent - TEST ECX, ECX - JNZ @@registerClass1 - TEST byte ptr [ESP].TCreateWndParams.Style+3, $40 - XCHG EAX, ECX - JNZ @@fin -@@registerClass1: - MOV EAX, [ESP].TCreateWndParams.WinClassName - MOV EDX, [ESP].TCreateWndParams.WindowClass.hInstance - ADD ESP, -szWndClass - PUSH ESP - PUSH EAX - PUSH EDX - CALL GetClassInfo - ADD ESP, szWndClass - TEST EAX, EAX - JNZ @@registered - MOV EAX, [ESP].TCreateWndParams.WinClassName - MOV [ESP].TCreateWndParams.WindowClass.lpszClassName, EAX - MOV [ESP].TCreateWndParams.WindowClass.lpfnWndProc, offset WndFunc - LEA EAX, [ESP].TCreateWndParams.WindowClass - PUSH EAX - CALL RegisterClass - TEST EAX, EAX - JZ @@fin -@@registered: - MOV [CreatingWindow], EBX - {$IFDEF DEBUG_CREATEWINDOW} - MOV EAX, EBX - MOV EDX, ESP - CALL Debug_CreateWindow2 - {$ENDIF} - CALL CreateWindowEx - MOV [EBX].fHandle, EAX - TEST EAX, EAX - JZ @@fin - PUSH EAX - {$IFDEF USE_PROP} - PUSH offset ID_SELF - {$ELSE} - PUSH GWL_USERDATA - {$ENDIF} - PUSH EAX - - PUSH 0 - PUSH $10002 //UIS_CLEAR or (UISF_HIDEFOCUS shl 16) - PUSH $0128 //WM_UPDATEUISTATE - PUSH EAX - CALL SendMessage - - {$IFDEF USE_PROP} - CALL GetProp - {$ELSE} - CALL GetWindowLong - {$ENDIF} - XCHG ECX, EAX - POP EAX - INC ECX - LOOP @@propSet - MOV [CreatingWindow], ECX - PUSH EBX - {$IFDEF USE_PROP} - PUSH offset ID_SELF - PUSH EAX - CALL SetProp - {$ELSE} - PUSH GWL_USERDATA - PUSH EAX - CALL SetWindowLong - {$ENDIF} -@@propSet: - {$IFDEF SMALLEST_CODE} - {$ELSE} - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG3, 1 shl G3_IsControl - {$ELSE} - CMP [EBX].fIsControl, 0 - {$ENDIF} - JNZ @@iconSet - MOV EAX, EBX - CALL GetIcon - PUSH EAX - PUSH 1 - PUSH WM_SETICON - PUSH EBX - CALL Perform -@@iconSet: - {$ENDIF} - MOV ECX, [EBX].PP.fCreateWndExt - {$IFDEF NIL_EVENTS} - JECXZ @@dblbufcreate - {$ENDIF} - MOV EAX, EBX - CALL ECX -@@dblbufcreate: -@@applyfont: - MOV EAX, EBX - CALL [ApplyFont2Wnd_Proc] - MOV EAX, EBX - CALL [ApplyFont2Wnd_Proc] -@@createchildren: - XCHG EAX, EBX - CALL CreateChildWindows - MOV AL, 1 -@@fin: - MOV ESP, EBP - POP EBP -@@ret_false: - POP EBX -end; - - -function WndProcKeybd( Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -asm - PUSH EBX - MOV ECX, [EDX].TMsg.message - SUB CX, $100 - CMP ECX, 5 - JA @@fin_false - XCHG EBX, EAX // EBX = @Self - XCHG EAX, ECX // EAX = message - WM_KEYFIRST - {$IFDEF EVENTS_DYNAMIC} - MOV ECX, [EBX].TControl.EV - LEA ECX, [ECX].TEvents.fOnKeyUp - {$ELSE} - LEA ECX, [EBX].TControl.EV.fOnKeyUp - {$ENDIF} - JZ @@event - {$IFDEF PARANOIA} DB $34, 1 {$ELSE} XOR AL, 1 {$ENDIF} - JZ @@event - //LEA ECX, [EBX].TControl.EV.fOnKeyDown - ADD ECX, 8 - {$IFDEF PARANOIA} DB $34, 1 {$ELSE} XOR AL, 1 {$ENDIF} - JZ @@event - {$IFDEF PARANOIA} DB $34, 4 {$ELSE} XOR AL, 4 {$ENDIF} - JZ @@event - //LEA ECX, [EBX].TControl.EV.fOnChar - SUB ECX, 24 - {$IFDEF PARANOIA} DB $34, 6 {$ELSE} XOR AL, 2 xor 4 {$ENDIF} - JZ @@event - {$IFDEF PARANOIA} DB $34, 4 {$ELSE} XOR AL, 6 xor 2 {$ENDIF} - JNZ @@fin_false -@@event: - {$IFDEF NIL_EVENTS} - CMP word ptr [ECX].TMethod.Code+2, 0 - JZ @@fin_false - {$ENDIF} - PUSH EDX - PUSH ECX - LEA ECX, [EDX].TMsg.wParam - PUSH ECX - CALL GetShiftState - POP ECX // @wParam - XCHG EAX, [ESP] // ShiftState; EAX=@event - MOV EDX, EBX // @Self - MOV EBX, [EAX].TMethod.Code - MOV EAX, [EAX].TMethod.Data - CALL EBX - - POP EDX - MOV ECX, [EDX].TMsg.wParam - JECXZ @@fin_true - -@@fin_false: - XOR EAX, EAX - POP EBX - RET - -@@fin_true: - MOV AL, 1 - POP EBX -end; - -function TControl.GetCaption: KOLString; -asm - PUSH EBX - PUSH EDI - XCHG EBX, EAX - MOV EDI, EDX - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG1, (1 shl G1_IgnoreWndCaption) - {$ELSE} - CMP [EBX].fIgnoreWndCaption, 0 - {$ENDIF USE_FLAGS} - JNZ @@getFCaption - MOV ECX, [EBX].fHandle - JECXZ @@getFCaption -@@getWndCaption: - PUSH ECX - CALL GetWindowTextLength - PUSH EAX - XCHG EDX, EAX - LEA EAX, [EBX].fCaption - CALL System.@LStrSetLength - POP ECX - JECXZ @@getFCaption - INC ECX - PUSH ECX - PUSH [EBX].fCaption - PUSH [EBX].fHandle - CALL GetWindowText -@@getFCaption: - MOV EDX, [EBX].fCaption - XCHG EAX, EDI - {$IFNDEF UNICODE_CTRLS} - CALL System.@LStrAsg - {$ELSE} - CALL System.@WStrFromPChar - {$ENDIF} -@@exit: - POP EDI - POP EBX -end; - -function TControl.get_ClassName: AnsiString; -asm - PUSH EBX - XCHG EBX, EAX - XCHG EAX, EDX - MOV EDX, [EBX].fControlClassName - PUSH EAX - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar // EAX^ := String(EDX) - POP EAX - {$IFDEF USE_FLAGS} - TEST [EBX].fFlagsG6, 1 shl G6_CtlClassNameChg - {$ELSE} - CMP [EBX].fCtlClsNameChg, 0 - {$ENDIF} - JNZ @@exit - MOV ECX, [EAX] - MOV EDX, offset[ @@obj ] - CALL System.@LStrCat3 // EAX^ := EDX + ECX - JMP @@exit - - {$IFDEF _D2009orHigher} - DW 1252, 1 // CP_ANSI_LATIN1, Byte // TODO: CP_ACP - {$ENDIF} - DD -1, 4 // FFFFFFFF 04000000 obj_, 0 -@@obj: DB 'obj_', 0 -@@exit: - POP EBX -end; - -function TControl.GetItems(Idx: Integer): AnsiString; -asm - PUSH ESI - PUSH EDI - PUSH EBX - PUSH EBP - MOV EBP, ESP - - MOV EBX, EAX // @Self - MOV ESI, EDX // Idx - MOV EDI, ECX // @Result - - CALL Item2Pos - PUSH 0 // push 0 - PUSH EAX // store Pos - - XCHG EDX, EAX - MOV EAX, EBX - CALL Pos2Item // EAX = Idx' - XCHG ESI, EAX // ESI = Idx' - - XOR EAX, EAX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EBX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aGetItemLength - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aGetItemLength - {$ENDIF} - JECXZ @@ret_empty - - PUSH ECX // push aGetItemLength - - PUSH EBX - CALL Perform - - TEST EAX, EAX - JZ @@ret_empty - - PUSH EAX // save L - ADD EAX, 4 - - CALL System.@GetMem // GetMem( L+4 ) - POP EDX // restore L - LEA ECX, [EDX+1] - MOV dword ptr [EAX], ECX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EBX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aGetItemText - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aGetItemText - {$ENDIF} - JECXZ @@ret_buf - - PUSH EDX // save L - - PUSH EAX - PUSH EAX // push Buf - PUSH ESI // push Idx - - PUSH ECX // push aGetItemText - PUSH EBX - CALL Perform - POP EAX - - POP EDX -@@ret_buf: - MOV byte ptr [EAX + EDX], 0 // Buf[ L ] := #0 - -@@ret_empty: // EAX = 0 - XCHG EDX, EAX - MOV EAX, EDI - PUSH EDX - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - POP ECX - JECXZ @@exit - XCHG EAX, ECX - CALL System.@FreeMem -@@exit: - MOV ESP, EBP - POP EBP - POP EBX - POP EDI - POP ESI -end; - -procedure TControl.SetItems(Idx: Integer; const Value: AnsiString); -asm - PUSH EDI - PUSH EBX - XCHG EBX, EAX - XCHG EDI, EDX // EDI = Idx - CALL ECX2PChar - PUSH ECX // @Value[1] - - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EBX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aSetItemText - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aSetItemText - {$ENDIF} - JECXZ @@1 - - PUSH 0 - PUSH ECX - - MOV EDX, EDI - MOV EAX, EBX - CALL Item2Pos - PUSH EAX // store Strt - - MOV EDX, EDI - INC EDX - MOV EAX, EBX - CALL Item2Pos - POP EDX // EDX = Strt - - SUB EAX, EDX - PUSH EAX // store L - - MOV EAX, EBX - CALL SetSelStart - - POP EDX // EDX = L - PUSH EBX // prepare @Self for Perform - XCHG EAX, EBX - CALL SetSelLength - - // @Value[1] already in stack, - // 0 already in stack - // aSetItemText already in stack - // @Self already in stack - - CALL Perform - JMP @@exit - -@@1: // @Value[1] in stack already - POP EDX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EBX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aDeleteItem - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aDeleteItem - {$ENDIF} - JECXZ @@exit - - {$IFNDEF NOT_FIX_CURINDEX} - PUSH ESI - PUSH EBP - - PUSH EDX - - MOV EAX, EBX // +AK - CALL GetCurIndex // +AK - XCHG ESI, EAX // ESI = TmpCurIdx - - MOV EAX, EBX - MOV EDX, EDI - CALL GetItemData - XCHG EBP, EAX // EBP = TmpData - - MOV EDX, EDI - MOV EAX, EBX - CALL Delete - - MOV EAX, EBX // *AK - MOV EDX, EDI - POP ECX - CALL Insert - - MOV ECX, EBP // ECX = TmpData - MOV EDX, EDI - MOV EAX, EBX - CALL SetItemData - - XCHG EAX, EBX // +AK - MOV EDX, ESI // +AK - CALL SetCurIndex // +AK - - POP EBP - POP ESI - {$ELSE NOT_FIX_CURINDEX} - PUSH EDX - - MOV EDX, EDI - MOV EAX, EBX - CALL Delete - - XCHG EAX, EBX - XCHG EDX, EDI - - POP ECX - CALL Insert - {$ENDIF NOT_FIX_CURINDEX} - -@@exit: - POP EBX - POP EDI -end; - -function TControl.Add(const S: KOLString): Integer; -asm - PUSH EBX - MOV EBX, EAX // EBX = @Self - - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EBX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aAddItem - {$ELSE} - MOVZX ECX, [EBX].fCommandActions.aAddItem // ECX = aAddItem - {$ENDIF} - JECXZ @@chk_addtext - - CALL EDX2PChar - PUSH EDX - PUSH 0 - PUSH ECX - PUSH EBX - CALL Perform - PUSH EAX - - MOV EAX, EBX - CALL TControl.GetItemsCount - XCHG EAX, ECX - LOOP @@ret_EAX - - XCHG EAX, EBX - INC ECX - XOR EDX, EDX - CALL TControl.SetItemSelected -@@ret_EAX: - POP EAX - JMP @@exit - -@@chk_addtext: - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EBX].fCommandActions - MOV ECX, [ECX].TCommandActionsObj.aAddText - {$ELSE} - MOV ECX, [EBX].fCommandActions.aAddText - {$ENDIF} - JECXZ @@add_text_simple - - CALL ECX - JMP @@exit_0 - -@@add_text_simple: - LEA EAX, [EBX].fCaption - CALL System.@LStrCat - MOV EDX, [EBX].fCaption - MOV EAX, EBX - CALL SetCaption - -@@exit_0: - XOR EAX, EAX -@@exit: - POP EBX -end; - -function TControl.Insert(Idx: Integer; const S: AnsiString): Integer; -asm - CALL ECX2PChar - PUSH ECX - {$IFDEF COMMANDACTIONS_OBJ} - MOV ECX, [EAX].fCommandActions - MOVZX ECX, [ECX].TCommandActionsObj.aInsertItem - {$ELSE} - MOVZX ECX, [EAX].fCommandActions.aInsertItem - {$ENDIF} - JECXZ @@exit_1 - - PUSH EDX - PUSH ECX - PUSH EAX - CALL Perform - RET - -@@exit_1:OR EAX, -1 - POP ECX -end; - -procedure TTrayIcon.SetTooltip(const Value: AnsiString); -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, [EBX].fTooltip - PUSH EDX - CALL System.@LStrCmp - POP EDX - JE @@exit - LEA EAX, [EBX].fTooltip - CALL System.@LStrAsg - CMP [EBX].fActive, 0 - JE @@exit - XOR EDX, EDX - INC EDX // EDX = NIM_MODIFY - XCHG EAX, EBX - CALL SetTrayIcon -@@exit: - POP EBX -end; - -procedure TTrayIcon.SetTrayIcon(const Value: DWORD); -const sz_tid = sizeof( TNotifyIconData ); -asm - CMP [AppletTerminated], 0 - JE @@1 - MOV DL, NIM_DELETE -@@1: - PUSH EBX - PUSH ESI - MOV ESI, EAX - MOV EBX, EDX - - XOR ECX, ECX - PUSH ECX - ADD ESP, -60 - MOV EDX, [ESI].fToolTip - CALL EDX2PChar - MOV EAX, ESP - MOV CL, 63 - CALL StrLCopy - - PUSH [ESI].fIcon - PUSH CM_TRAYICON - XOR EDX, EDX - CMP BL, NIM_DELETE - JE @@2 - MOV DL, NIF_ICON or NIF_MESSAGE or NIF_TIP -@@2: PUSH EDX - PUSH ESI - MOV EAX, [ESI].FWnd - TEST EAX, EAX - JNZ @@3 - MOV EAX, [ESI].fControl - MOV EAX, [EAX].TControl.fHandle -@@3: - PUSH EAX - PUSH sz_tid - - PUSH ESP - PUSH EBX - CALL Shell_NotifyIcon - - ADD ESP, sz_tid - POP ESI - POP EBX -@@exit: -end; - -function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; -asm - PUSH EBP - MOV EBP, ESP - PUSHAD - CALL WndProcJustOne - POPAD - XOR EAX, EAX - PUSH ECX - MOV ECX, [EDX].TMsg.message - SUB ECX, [JustOneMsg] - POP ECX - JNE @@exit - MOV [ECX], EAX - CMP [OnAnotherInstance].TMethod.Code, EAX - JE @@exit_1 - - //MOV EAX, (MAX_PATH + 3) and 0FFFFCh - MOV AH, 2 - SUB ESP, EAX - - MOV ECX, ESP - PUSH EAX - PUSH ECX - PUSH [EDX].TMsg.lParam - CALL GetWindowText - - MOV EDX, ESP - PUSH 0 - MOV EAX, ESP - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - - MOV EDX, [ESP] - MOV EAX, [OnAnotherInstance].TMethod.Data - CALL [OnAnotherInstance].TMethod.Code - - MOV EAX, ESP - CALL System.@LStrClr -@@exit_1: - MOV AL, 1 -@@exit: - MOV ESP, EBP - POP EBP -end; - -function JustOneNotify( Wnd: PControl; const Identifier : AnsiString; - const aOnAnotherInstance: TOnAnotherInstance ) : Boolean; -asm - PUSHAD - MOV EBP, ESP - - XCHG EAX, EDX - PUSH EAX - CALL System.@LStrLen - POP EDX - ADD EAX, EAX - SUB ESP, EAX - MOV EAX, ESP - CALL StrPCopy - PUSH '.ega' - PUSH 'sseM' - PUSH ESP - CALL RegisterWindowMessage - MOV [JustOneMsg], EAX - TEST EAX, EAX - MOV ESP, EBP - POPAD - JE @@exit_f - PUSHAD - CALL JustOne - DEC AL - POPAD - JZ @@exit_t - PUSH EBX - XCHG EBX, EAX - XOR EDX, EDX - XCHG [EBX].TControl.fCaption, EDX - PUSH EDX - CALL GetCommandLine - XCHG EDX, EAX - LEA EAX, [EBX].TControl.fCaption - {$IFDEF _D2009orHigher} - PUSH ECX - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - {$IFDEF _D2009orHigher} - POP ECX - {$ENDIF} - MOV EAX, EBX - MOV EDX, [EBX].TControl.fCaption - CALL TControl.SetCaption - MOV EAX, EBX - CALL TControl.GetWindowHandle - TEST EAX, EAX - JZ @@rest_cap - PUSH BSM_APPLICATIONS - MOV EDX, ESP - PUSH EAX - PUSH 0 - PUSH [JustOneMsg] - PUSH EDX - PUSH BSF_QUERY or BSF_IGNORECURRENTTASK - CALL BroadcastSystemMessage - POP EDX -@@rest_cap: - LEA EAX, [EBX].TControl.fCaption - CALL System.@LStrClr - POP EDX - MOV [EBX].TControl.fCaption, EDX - MOV EAX, EBX - CALL TControl.SetCaption - POP EBX -@@exit_f: - XOR EAX, EAX - JMP @@exit -@@exit_t: - PUSHAD - LEA ESI, [aOnAnotherInstance] - LEA EDI, [OnAnotherInstance] - MOVSD - MOVSD - MOV EDX, offset[WndProcJustOneNotify] - CALL TControl.AttachProc - POPAD - MOV AL, 1 -@@exit: -end; - -function TStrList.AppendToFile(const FileName: Ansistring): Boolean; -asm - PUSH EBX - MOV EBX, EDX - PUSH 0 - MOV EDX, ESP - CALL GetTextStr - XCHG EAX, EBX - MOV EDX, ofOpenWrite or ofOpenAlways - CALL FileCreate - MOV EBX, EAX - INC EAX - JZ @@exit - DEC EAX - XOR EDX, EDX - XOR ECX, ECX - MOV CL, spEnd - CALL FileSeek - POP EAX - PUSH EAX - CALL System.@LStrLen - XCHG ECX, EAX - MOV EAX, EBX - POP EDX - PUSH EDX - CALL FileWrite - XCHG EAX, EBX - CALL FileClose -@@exit: - CALL RemoveStr - POP EBX -end; - -function TStrList.LoadFromFile(const FileName: AnsiString): Boolean; -asm - PUSH EAX - XCHG EAX, EDX - MOV EDX, ofOpenRead or ofShareDenyWrite or ofOpenExisting - CALL FileCreate - INC EAX - JZ @@exit - DEC EAX - PUSH EBX - XCHG EBX, EAX - PUSH 0 - PUSH EBX - CALL GetFileSize - XOR EDX, EDX - PUSH EDX - XCHG ECX, EAX - MOV EAX, ESP - PUSH ECX - {$IFDEF _D2} - CALL _LStrFromPCharLen - {$ELSE} - {$IFDEF _D2009orHigher} - PUSH EDX // ushort 0, CodePage? - {$ENDIF} - CALL System.@LStrFromPCharLen - {$ENDIF} - POP ECX - MOV EAX, EBX - POP EDX - PUSH EDX - CALL FileRead - XCHG EAX, EBX - CALL FileClose - POP EDX - POP EBX - POP EAX - PUSH EDX - XOR ECX, ECX - CALL SetText - CALL RemoveStr - PUSH EDX - MOV AL, 1 -@@exit: POP EDX -end; - -function TStrList.SaveToFile(const FileName: Ansistring): Boolean; -asm - PUSH EBX - PUSH EAX - XCHG EAX, EDX - MOV EDX, ofOpenWrite or ofCreateAlways - CALL FileCreate - INC EAX - JZ @@exit - DEC EAX - XCHG EBX, EAX - POP EAX - PUSH 0 - MOV EDX, ESP - CALL GetTextStr - POP EAX - PUSH EAX - CALL System.@LStrLen - XCHG ECX, EAX - POP EDX - PUSH EDX - MOV EAX, EBX - CALL FileWrite - PUSH EBX - CALL SetEndOfFile - XCHG EAX, EBX - CALL FileClose - CALL RemoveStr - PUSH EDX - INC EAX -@@exit: - POP EDX - POP EBX -end; - -procedure TControl.SetStatusText(Index: Integer; const Value: KOLString); -asm - PUSHAD - MOV EBX, EDX // EBX = Index - MOV ESI, EAX // ESI = @Self - PUSH Value // prepare value for call at the end of procedure - PUSH EBX // prepare Index for call at the end of procedure - MOV ECX, [ESI].fStatusCtl - MOV EBP, ECX - INC ECX - LOOP @@status_created - CALL GetClientHeight - PUSH EAX // ch = old client height - MOV EAX, ESI - CALL _NewStatusBar - MOV [ESI].fStatusCtl, EAX - XCHG EBP, EAX - XOR EDX, EDX - PUSH EDX - INC DH - DEC EDX - CMP EBX, EDX - SETZ DL - NEG EDX - PUSH EDX - PUSH SB_SIMPLE - PUSH EBP - CALL TControl.Perform - ADD ESP, -16 - PUSH ESP - PUSH [EBP].fHandle - CALL GetWindowRect - POP EAX - POP EDX - POP EAX - POP EAX - SUB EAX, EDX - MOV [ESI].fClientBottom, AL - POP EDX // ch - PUSH 0 - PUSH 0 - PUSH WM_SIZE - PUSH EBP - MOV EAX, ESI - CALL TControl.SetClientHeight - CALL TControl.Perform -@@status_created: - CMP EBX, 255 - JGE @@not_simple - PUSH 0 - PUSH 0 - PUSH SB_GETPARTS - PUSH EBP - CALL Perform - CMP EAX, EBX - JG @@reset_simple - MOV EAX, ESI - CALL GetWidth - CDQ - MOV ECX, EBX - INC ECX - IDIV ECX - MOV EDX, EAX - ADD ESP, -1024 - /////////////////// - MOV ECX, EBX - MOV EDI, ESP - JECXZ @@2 -@@store_loo: - STOSD - ADD EAX, EDX - LOOP @@store_loo -@@2: - OR dword ptr [ESP+EBX*4], -1 - PUSH ESP - INC EBX - PUSH EBX - PUSH SB_SETPARTS - PUSH EBP - CALL Perform - //////////////////// - ADD ESP, 1024 -@@reset_simple: - PUSH 0 - PUSH 0 - PUSH SB_SIMPLE - PUSH EBP - CALL Perform -@@not_simple: - PUSH SB_SETTEXT - PUSH EBP - CALL Perform - POPAD -end; - -function TOpenSaveDialog.Execute: Boolean; -asm - PUSH EBX - XCHG EBX, EAX - - XOR ECX, ECX - {$IFDEF OpenSaveDialog_Extended} - MOVZX EAX, [EBX].NoPlaceBar - PUSH EAX - PUSH ECX - PUSH ECX - PUSH [EBX].TemplateName - PUSH [EBX].HookProc - {$ELSE} - PUSH ECX // prepare lpTemplateName = nil - PUSH ECX // prepare lpfnHook = nil - {$ENDIF} - PUSH EBX // prepare lCustData = @Self - MOV EDX, [EBX].FDefExtension - CALL EDX2PChar - PUSH EDX // prepare lpstrDefExt = FDefExtension - PUSH ECX // prepare nFileExtension, nFileOffset: Word = 0, 0 - // prepare flags: - LEA EAX, [EBX].FOptions - MOV EDX, Offset[@@OpenSaveFlags] - {$IFDEF OpenSaveDialog_Extended} - MOV CL, 14 - {$ELSE} - MOV CL, 12 - {$ENDIF} - CALL MakeFlags - XOR ECX, ECX - OR EAX, OFN_EXPLORER or OFN_LONGNAMES or OFN_ENABLESIZING - PUSH EAX // push Flags - PUSH [EBX].FTitle // prepare lpstrTitle - PUSH [EBX].FInitialDir // prepare lpstrInitialDir - PUSH ECX // prepare nMaxFileTitle = 0 - PUSH ECX // prepare lpstrFileTitle = nil - TEST AH, 2 // MultiSelect? - MOV EAX, 65520 - JNZ @@1 - MOV AX, MAX_PATH+2 -@@1: PUSH EAX // prepare nMaxFile - CALL System.@GetMem - POP ECX - PUSH ECX - PUSH EAX // prepare lpStrFile - XOR EDX, EDX - -@@2: MOV EDX, [EBX].fFileName // no, fill it initilly by FileName - CALL EDX2PChar - DEC ECX // added 5 october 2003 to prevent possible error if FileName too big - CALL StrLCopy - XOR EDX, EDX - - PUSH [EBX].FFilterIndex // prepare nFilterIndex - PUSH EDX // prepare nMaxCustFilter - PUSH EDX // prepare lpstrCustomFilter - PUSH EDX // prepare lpstrFilter = nil - MOV EAX, ESP - OR EDX, [EBX].FFilter - JZ @@5 - - MOV ECX, offset[@@0] - CALL System.@LStrCat3 // prepare lpStrFilter = FFilter + #0 - POP EAX - PUSH EAX - XOR EDX, EDX -@@3: INC EAX // filter is not starting from ';' or '|'... - CMP [EAX], DL - JZ @@5 - CMP byte ptr [EAX], '|' - JNZ @@3 -@@4: MOV [EAX], DL - JMP @@3 -@@OpenSaveFlags: - DD OFN_CREATEPROMPT, OFN_EXTENSIONDIFFERENT, OFN_FILEMUSTEXIST - DD OFN_HIDEREADONLY, OFN_NOCHANGEDIR, OFN_NODEREFERENCELINKS - DD OFN_ALLOWMULTISELECT, OFN_NONETWORKBUTTON, OFN_NOREADONLYRETURN - DD OFN_OVERWRITEPROMPT, OFN_PATHMUSTEXIST, OFN_READONLY, OFN_NOVALIDATE - {$IFDEF OpenSaveDialog_Extended} - DD OFN_ENABLETEMPLATE, OFN_ENABLEHOOK - {$ENDIF} - - {$IFDEF _D2009orHigher} - DW 0, 1 - {$ENDIF} - DD -1, 1 -@@0: DB 0 - - -@@5: - PUSH [hInstance] // prepare hInstance - - MOV ECX, [EBX].TControl.fWnd - INC ECX - LOOP @@6 - MOV ECX, [Applet] - JECXZ @@6 - MOV ECX, [ECX].TControl.fHandle -@@6: PUSH ECX // prepare hWndOwner - {$IFDEF OpenSaveDialog_Extended} - CALL WinVer - CMP AL, wvNT - MOV DL, 76+12 - JA @@6a - CMP AL, wvME - JE @@6a - MOV DL, 76 -@@6a: MOVZX EAX, DL - PUSH EAX - {$ELSE} - PUSH 76 // prepare lStructSize - {$ENDIF} - - PUSH ESP - CMP [EBX].TControl.FOpenDialog, 0 - JZ @@7 - CALL GetOpenFileName - JMP @@8 -@@7: CALL GetSaveFileName -@@8: - PUSH EAX - XOR EDX, EDX - TEST EAX, EAX - JZ @@10 - - MOV EAX, [ESP+4].TOpenFileName.nFilterIndex - MOV [EBX].FFilterIndex, EAX - - TEST BYTE PTR [ESP+4].TOpenFileName.Flags, OFN_READONLY - SETNZ AL - MOV [EBX].fOpenReadOnly, AL - - MOV EAX, [ESP+4].TOpenFileName.lpstrFile - MOV EDX, EAX - XOR ECX, ECX - - TEST [EBX].FOptions, 1 shl OSAllowMultiSelect - JZ @@10 - - DEC EAX -@@9: INC EAX - CMP byte ptr [EAX], CL - JNZ @@9 - CMP byte ptr [EAX+1], CL - JZ @@10 - MOV byte ptr [EAX], 13 - JMP @@9 - -@@10: - LEA EAX, [EBX].FFileName - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - MOV EAX, [ESP+4].TOpenFileName.lpstrFile - CALL System.@FreeMem // v1.86 +AK - - LEA EAX, [ESP+4].TOpenFileName.lpstrFilter - CALL System.@LStrClr - - POP EAX - {$IFDEF OpenSaveDialog_Extended} - ADD ESP, 76+12 - {$ELSE} - ADD ESP, 76 - {$ENDIF} - POP EBX -end; - -function TOpenDirDialog.Execute: Boolean; -asm - PUSH EBX - XCHG EBX, EAX - XOR ECX, ECX - PUSH ECX // prepare iImage = 0 - PUSH EBX // prepare lParam = @Self - PUSH [EBX].FCallBack // prepare lpfn = FCallBack - LEA EAX, [EBX].FOptions - MOV EDX, Offset[@@FlagsArray] - MOV CL, 8 - CALL MakeFlags - PUSH EAX // prepare ulFlags = Options - PUSH [EBX].FTitle // prepare lpszTitle - LEA EAX, [EBX].FBuf - PUSH EAX // prepare pszDisplayName - PUSH 0 // prepare pidlRoot - MOV ECX, [EBX].fWnd - INC ECX - LOOP @@1 - MOV ECX, Applet - JECXZ @@1 - MOV ECX, [ECX].TControl.fHandle -@@1: PUSH ECX // prepare hwndOwner - PUSH ESP - CALL SHBrowseForFolderA - ADD ESP, 32 - TEST EAX, EAX - JZ @@exit - PUSH EAX - LEA EDX, [EBX].FBuf - PUSH EDX - PUSH EAX - CALL SHGetPathFromIDListA - CALL CoTaskMemFree - MOV AL, 1 - JMP @@fin -@@FlagsArray: - DD BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN - DD BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT - DD BIF_BROWSEINCLUDEFILES, BIF_EDITBOX, BIF_NEWDIALOGSTYLE -@@exit: XOR EAX, EAX -@@fin: - POP EBX -end; - -function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): - Integer; stdcall; -asm - MOV EAX, [lpData] - MOV ECX, [EAX].TOpenDirDialog.FOnSelChanged.TMethod.Code - JECXZ @@exit - LEA EDX, [EAX].TOpenDirDialog.FBuf - PUSH EDX - PUSH [lParam] - CALL SHGetPathFromIDListA - MOV EDX, [lpData] - LEA ECX, [EDX].TOpenDirDialog.FBuf - PUSH 0 - PUSH ESP - LEA EAX, [EDX].TOpenDirDialog.FStatusText - PUSH EAX - MOV EAX, [EDX].TOpenDirDialog.FOnSelChanged.TMethod.Data - CALL dword ptr [EDX].TOpenDirDialog.FOnSelChanged.TMethod.Code - PUSH 0 - PUSH BFFM_ENABLEOK - PUSH [Wnd] - CALL SendMessage -@@1: MOV EDX, [lpData] - MOV ECX, [EDX].TOpenDirDialog.FStatusText - JECXZ @@exit - PUSH ECX - PUSH 0 - PUSH BFFM_SETSTATUSTEXT - PUSH [Wnd] - CALL SendMessage -@@exit: XOR EAX, EAX -end; - -function TControl.TBAddInsButtons(Idx: Integer; const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer): Integer; stdcall; -asm { [EBP+$8] = @Self - [EBP+$C] = Idx - [EBP+$10] = Buttons - [EBP+$14] = High(Butons) - [EBP+$18] = BtnImgIdxArray - [EBP+$1C] = High(BtnImgIdxArray) } - PUSH EBX - PUSH ESI - PUSH EDI - OR EBX, -1 - MOV EAX, 20 - MOV ECX, [EBP+$14] - CMP ECX, EBX - JLE @@fin - INC ECX - MUL ECX - CALL System.@GetMem - PUSH EAX // save AB to FreeMem after - MOV EDX, EBX - DEC EDX // nBmp := -2 - MOV ECX, [EBP+$14] - INC ECX - JZ @@exit - MOV ECX, [EBP+$1C] - INC ECX - JZ @@1 - MOV ECX, [BtnImgIdxArray] - MOV EDX, [ECX] - DEC EDX // nBmp := BtnImgIdxArray[ 0 ] - 1 -@@1: MOV ECX, [EBP+$14] - INC ECX - MOV ESI, [Buttons] - MOV EDI, EAX // EDI = PAB - PUSH 0 // N:=0 in [EBP-$14] -@@loop: - LODSD - TEST EAX, EAX - JZ @@break - PUSH ECX - CMP word ptr [EAX], '-' - JNE @@2 - OR EAX, -1 - STOSD - MOV EAX, [ToolbarsIDcmd] - TEST EBX, EBX - {$IFDEF USE_CMOV} - CMOVL EBX, EAX - {$ELSE} - JGE @@b0 - MOV EBX, EAX -@@b0: {$ENDIF} - STOSD - XOR EAX, EAX - INC AH // TBSTYLE_SEP = 1 - STOSD - DEC AH - STOSD - DEC EAX - JMP @@3 - {$IFDEF _D2009orHigher} - DW 0, 1 - {$ENDIF} - DD -1, 1 -@@0: DB 0 -@@2: - INC EDX // Inc( nBmp ) - PUSH EAX - MOV EAX, [EBP+$1C] - MOV ECX, [EBP-$14] - CMP EAX, ECX - MOV EAX, EDX - JL @@21 - MOV EAX, [BtnImgIdxArray] - MOV EAX, [EAX+ECX*4] -@@21: STOSD - TEST EDX, EDX - JGE @@2a - DEC EDX -@@2a: - MOV EAX, [ToolbarsIDcmd] - STOSD - TEST EBX, EBX - {$IFDEF USE_CMOV} - CMOVL EBX, EAX - {$ELSE} - JGE @@210 - MOV EBX, EAX -@@210: {$ENDIF} - MOV ECX, [EBP+8] - MOV AH, BYTE PTR [ECX].TControl.DF.fDefaultTBBtnStyle - POP ECX - MOV AL, 4 // AL=fsState=_ENABLED, AH=fsStyle=_AUTOSIZE if fDefaultTBBtnStyle contains - CMP byte ptr [ECX], '^' - JNE @@22 - OR AH, TBSTYLE_DROPDOWN - INC ECX -@@22: CMP byte ptr [ECX], '-' - JZ @@23 - CMP byte ptr [ECX], '+' - JNZ @@24 - MOV AL, TBSTATE_ENABLED or TBSTATE_CHECKED -@@23: INC ECX - OR AH, TBSTYLE_CHECK - CMP byte ptr [ECX], '!' - JNZ @@24 - OR AH, TBSTYLE_GROUP - INC ECX -@@24: {$IFDEF TOOLBAR_DOT_NOAUTOSIZE_BUTTON} - CMP byte ptr [ECX], '.' - JNZ @@25 - AND AH, not TBSTYLE_AUTOSIZE - INC ECX -@@25: - {$ENDIF TOOLBAR_DOT_NOAUTOSIZE_BUTTON} - STOSD - MOV EAX, [EBP+8] - STOSD - OR EAX, -1 - CMP word ptr [ECX], ' ' - JZ @@3 - CMP byte ptr [ECX], 0 - JZ @@3 - PUSH EDX - PUSH 0 - MOV EDX, ECX - MOV EAX, ESP - {$IFDEF _D2009orHigher} - PUSH ECX - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - {$IFDEF _D2009orHigher} - POP ECX - {$ENDIF} - MOV EAX, ESP - MOV EDX, offset[@@0] - CALL System.@LStrCat - PUSH dword ptr [ESP] - PUSH 0 - PUSH TB_ADDSTRING - PUSH dword ptr [EBP+8] - CALL Perform - STOSD - CALL RemoveStr - POP EDX - JMP @@30 -@@3: STOSD -@@30: INC dword ptr [EBP-$14] - INC [ToolbarsIDcmd] - POP ECX - DEC ECX - JNZ @@loop -@@break: - POP ECX - JECXZ @@exit - PUSH dword ptr [ESP] - MOV EAX, [Idx] - TEST EAX, EAX - JGE @@31 - PUSH ECX - PUSH TB_ADDBUTTONS - JMP @@32 -@@31: - PUSH EAX - PUSH TB_INSERTBUTTON -@@32: - PUSH dword ptr [EBP+8] - CALL Perform -@@exit: - POP EAX - CALL System.@FreeMem -@@fin: - POP EDI - POP ESI - XCHG EAX, EBX - POP EBX -end; - -function TControl.TBGetButtonText( BtnID: Integer ): AnsiString; -asm - PUSH ECX - ADD ESP, -1024 - PUSH ESP - PUSH EAX - CALL GetTBBtnGoodID - POP EDX - PUSH EAX - PUSH TB_GETBUTTONTEXT - PUSH EDX - CALL Perform - TEST EAX, EAX - JLE @@2 - MOV EDX, ESP - JMP @@1 -@@2: XOR EDX, EDX -@@1: MOV EAX, [ESP+1024] - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar - ADD ESP, 1028 -end; - -procedure TBitmap.LoadFromResourceName(Inst: DWORD; ResName: PAnsiChar); -asm - PUSH EBX - MOV EBX, EAX - PUSHAD - CALL Clear - POPAD - XOR EAX, EAX - PUSH ECX - MOVZX ECX, [EBX].fHandleType - INC ECX - LOOP @@1 - MOV AH, LR_CREATEDIBSECTION shr 8 // = $2000 -@@1: MOV AL, LR_DEFAULTSIZE // = $40 - POP ECX - PUSH EAX - PUSH 0 - PUSH 0 - PUSH IMAGE_BITMAP - PUSH ECX - PUSH EDX - CALL LoadImage - TEST EAX, EAX - JZ @@exit - XCHG EDX, EAX - XCHG EAX, EBX - CALL SetHandle -@@exit: POP EBX -end; -{$ENDIF} diff --git a/plugins/ImportTXT/kol/KOL_ansi.inc b/plugins/ImportTXT/kol/KOL_ansi.inc deleted file mode 100644 index b40ef014c7..0000000000 --- a/plugins/ImportTXT/kol/KOL_ansi.inc +++ /dev/null @@ -1,2316 +0,0 @@ -{******************************************************************************* - KOL_unicode.inc - Some redeclarations from Windows.pas for case, when UNICODE_CTRLS symbol is off. -*******************************************************************************} -{$IFDEF interface_part} //////////////////////////////////////////////////////// - //// for D3 gumno -type - PRecoveryAgentInformationA = ^TRecoveryAgentInformationA; - PRecoveryAgentInformationW = ^TRecoveryAgentInformationW; - PRecoveryAgentInformation = PRecoveryAgentInformationA; - _RECOVERY_AGENT_INFORMATIONA = record - NextEntryOffset: DWORD; - AgentNameLength: DWORD; - AgentInformation: array[0..0] of AnsiChar; - end; - //// _RECOVERY_AGENT_INFORMATIONA} - _RECOVERY_AGENT_INFORMATIONW = record - NextEntryOffset: DWORD; - AgentNameLength: DWORD; - AgentInformation: array[0..0] of WideChar; - end; - //// _RECOVERY_AGENT_INFORMATIONW} - _RECOVERY_AGENT_INFORMATION = _RECOVERY_AGENT_INFORMATIONA; - TRecoveryAgentInformationA = _RECOVERY_AGENT_INFORMATIONA; - TRecoveryAgentInformationW = _RECOVERY_AGENT_INFORMATIONW; - TRecoveryAgentInformation = TRecoveryAgentInformationA; - RECOVERY_AGENT_INFORMATIONA = _RECOVERY_AGENT_INFORMATIONA; - //// RECOVERY_AGENT_INFORMATIONA} - RECOVERY_AGENT_INFORMATIONW = _RECOVERY_AGENT_INFORMATIONW; - //// RECOVERY_AGENT_INFORMATIONW} - RECOVERY_AGENT_INFORMATION = RECOVERY_AGENT_INFORMATIONA; - // - PTextMetricA = ^TTextMetricA; - PTextMetricW = ^TTextMetricW; - PTextMetric = PTextMetricA; - tagTEXTMETRICA = record - tmHeight: Longint; - tmAscent: Longint; - tmDescent: Longint; - tmInternalLeading: Longint; - tmExternalLeading: Longint; - tmAveCharWidth: Longint; - tmMaxCharWidth: Longint; - tmWeight: Longint; - tmOverhang: Longint; - tmDigitizedAspectX: Longint; - tmDigitizedAspectY: Longint; - tmFirstChar: AnsiChar; - tmLastChar: AnsiChar; - tmDefaultChar: AnsiChar; - tmBreakChar: AnsiChar; - tmItalic: Byte; - tmUnderlined: Byte; - tmStruckOut: Byte; - tmPitchAndFamily: Byte; - tmCharSet: Byte; - end; - tagTEXTMETRICW = record - tmHeight: Longint; - tmAscent: Longint; - tmDescent: Longint; - tmInternalLeading: Longint; - tmExternalLeading: Longint; - tmAveCharWidth: Longint; - tmMaxCharWidth: Longint; - tmWeight: Longint; - tmOverhang: Longint; - tmDigitizedAspectX: Longint; - tmDigitizedAspectY: Longint; - tmFirstChar: WideChar; - tmLastChar: WideChar; - tmDefaultChar: WideChar; - tmBreakChar: WideChar; - tmItalic: Byte; - tmUnderlined: Byte; - tmStruckOut: Byte; - tmPitchAndFamily: Byte; - tmCharSet: Byte; - end; - tagTEXTMETRIC = tagTEXTMETRICA; - TTextMetricA = tagTEXTMETRICA; - TTextMetricW = tagTEXTMETRICW; - TTextMetric = TTextMetricA; - TEXTMETRICA = tagTEXTMETRICA; - TEXTMETRICW = tagTEXTMETRICW; - TEXTMETRIC = TEXTMETRICA; - /// - PNewTextMetricA = ^TNewTextMetricA; - PNewTextMetricW = ^TNewTextMetricW; - PNewTextMetric = PNewTextMetricA; - //// tagNEWTEXTMETRICA} - tagNEWTEXTMETRICA = record - tmHeight: Longint; - tmAscent: Longint; - tmDescent: Longint; - tmInternalLeading: Longint; - tmExternalLeading: Longint; - tmAveCharWidth: Longint; - tmMaxCharWidth: Longint; - tmWeight: Longint; - tmOverhang: Longint; - tmDigitizedAspectX: Longint; - tmDigitizedAspectY: Longint; - tmFirstChar: AnsiChar; - tmLastChar: AnsiChar; - tmDefaultChar: AnsiChar; - tmBreakChar: AnsiChar; - tmItalic: Byte; - tmUnderlined: Byte; - tmStruckOut: Byte; - tmPitchAndFamily: Byte; - tmCharSet: Byte; - ntmFlags: DWORD; - ntmSizeEM: UINT; - ntmCellHeight: UINT; - ntmAvgWidth: UINT; - end; - //// tagNEWTEXTMETRICW} - tagNEWTEXTMETRICW = record - tmHeight: Longint; - tmAscent: Longint; - tmDescent: Longint; - tmInternalLeading: Longint; - tmExternalLeading: Longint; - tmAveCharWidth: Longint; - tmMaxCharWidth: Longint; - tmWeight: Longint; - tmOverhang: Longint; - tmDigitizedAspectX: Longint; - tmDigitizedAspectY: Longint; - tmFirstChar: WideChar; - tmLastChar: WideChar; - tmDefaultChar: WideChar; - tmBreakChar: WideChar; - tmItalic: Byte; - tmUnderlined: Byte; - tmStruckOut: Byte; - tmPitchAndFamily: Byte; - tmCharSet: Byte; - ntmFlags: DWORD; - ntmSizeEM: UINT; - ntmCellHeight: UINT; - ntmAvgWidth: UINT; - end; - // tagNEWTEXTMETRIC} - tagNEWTEXTMETRIC = tagNEWTEXTMETRICA; - TNewTextMetricA = tagNEWTEXTMETRICA; - TNewTextMetricW = tagNEWTEXTMETRICW; - TNewTextMetric = TNewTextMetricA; - // NEWTEXTMETRICA} - NEWTEXTMETRICA = tagNEWTEXTMETRICA; - // NEWTEXTMETRICW} - NEWTEXTMETRICW = tagNEWTEXTMETRICW; - // NEWTEXTMETRIC} - NEWTEXTMETRIC = NEWTEXTMETRICA; - PNewTextMetricExA = ^TNewTextMetricExA; - // tagNEWTEXTMETRICEXA} - tagNEWTEXTMETRICEXA = packed record - ntmTm: TNewTextMetricA; - ntmFontSig: TFontSignature; - end; - TNewTextMetricExA = tagNEWTEXTMETRICEXA; - // NEWTEXTMETRICEXA} - NEWTEXTMETRICEXA = tagNEWTEXTMETRICEXA; - PNewTextMetricExW = ^TNewTextMetricExW; - // tagNEWTEXTMETRICEXW} - tagNEWTEXTMETRICEXW = packed record - ntmTm: TNewTextMetricW; - ntmFontSig: TFontSignature; - end; - TNewTextMetricExW = tagNEWTEXTMETRICEXW; - // NEWTEXTMETRICEXW} - NEWTEXTMETRICEXW = tagNEWTEXTMETRICEXW; - PNewTextMetricEx = PNewTextMetricExA; - { Structure passed to FONTENUMPROC } - PEnumLogFontA = ^TEnumLogFontA; - PEnumLogFontW = ^TEnumLogFontW; - PEnumLogFont = PEnumLogFontA; - // tagENUMLOGFONTA} - tagENUMLOGFONTA = packed record - elfLogFont: TLogFontA; - elfFullName: array[0..LF_FULLFACESIZE - 1] of AnsiChar; - elfStyle: array[0..LF_FACESIZE - 1] of AnsiChar; - end; - // tagENUMLOGFONTW} - tagENUMLOGFONTW = packed record - elfLogFont: TLogFontW; - elfFullName: array[0..LF_FULLFACESIZE - 1] of WideChar; - elfStyle: array[0..LF_FACESIZE - 1] of WideChar; - end; - // tagENUMLOGFONT} - tagENUMLOGFONT = tagENUMLOGFONTA; - TEnumLogFontA = tagENUMLOGFONTA; - TEnumLogFontW = tagENUMLOGFONTW; - TEnumLogFont = TEnumLogFontA; - // ENUMLOGFONTA} - ENUMLOGFONTA = tagENUMLOGFONTA; - // ENUMLOGFONTW} - ENUMLOGFONTW = tagENUMLOGFONTW; - // ENUMLOGFONT} - ENUMLOGFONT = ENUMLOGFONTA; - PEnumLogFontExA = ^TEnumLogFontExA; - PEnumLogFontExW = ^TEnumLogFontExW; - PEnumLogFontEx = PEnumLogFontExA; - // tagENUMLOGFONTEXA} - tagENUMLOGFONTEXA = packed record - elfLogFont: TLogFontA; - elfFullName: array[0..LF_FULLFACESIZE - 1] of AnsiChar; - elfStyle: array[0..LF_FACESIZE - 1] of AnsiChar; - elfScript: array[0..LF_FACESIZE - 1] of AnsiChar; - end; - // tagENUMLOGFONTEXW} - tagENUMLOGFONTEXW = packed record - elfLogFont: TLogFontW; - elfFullName: array[0..LF_FULLFACESIZE - 1] of WideChar; - elfStyle: array[0..LF_FACESIZE - 1] of WideChar; - elfScript: array[0..LF_FACESIZE - 1] of WideChar; - end; - // tagENUMLOGFONTEX} - tagENUMLOGFONTEX = tagENUMLOGFONTEXA; - TEnumLogFontExA = tagENUMLOGFONTEXA; - TEnumLogFontExW = tagENUMLOGFONTEXW; - TEnumLogFontEx = TEnumLogFontExA; - // ENUMLOGFONTEXA} - ENUMLOGFONTEXA = tagENUMLOGFONTEXA; - // ENUMLOGFONTEXW} - ENUMLOGFONTEXW = tagENUMLOGFONTEXW; - // ENUMLOGFONTEX} - ENUMLOGFONTEX = ENUMLOGFONTEXA; - PExtLogFontA = ^TExtLogFontA; - PExtLogFontW = ^TExtLogFontW; - PExtLogFont = PExtLogFontA; - // tagEXTLOGFONTA} - tagEXTLOGFONTA = record - elfLogFont: TLogFontA; - elfFullName: array[0..LF_FULLFACESIZE - 1] of AnsiChar; - elfStyle: array[0..LF_FACESIZE - 1] of AnsiChar; - elfVersion: DWORD; { 0 for the first release of NT } - elfStyleSize: DWORD; - elfMatch: DWORD; - elfReserved: DWORD; - elfVendorId: array[0..ELF_VENDOR_SIZE - 1] of Byte; - elfCulture: DWORD; { 0 for Latin } - elfPanose: TPanose; - end; - // tagEXTLOGFONTW} - tagEXTLOGFONTW = record - elfLogFont: TLogFontW; - elfFullName: array[0..LF_FULLFACESIZE - 1] of WideChar; - elfStyle: array[0..LF_FACESIZE - 1] of WideChar; - elfVersion: DWORD; { 0 for the first release of NT } - elfStyleSize: DWORD; - elfMatch: DWORD; - elfReserved: DWORD; - elfVendorId: array[0..ELF_VENDOR_SIZE - 1] of Byte; - elfCulture: DWORD; { 0 for Latin } - elfPanose: TPanose; - end; - // tagEXTLOGFONT} - tagEXTLOGFONT = tagEXTLOGFONTA; - TExtLogFontA = tagEXTLOGFONTA; - TExtLogFontW = tagEXTLOGFONTW; - TExtLogFont = TExtLogFontA; - // EXTLOGFONTA} - EXTLOGFONTA = tagEXTLOGFONTA; - // EXTLOGFONTW} - EXTLOGFONTW = tagEXTLOGFONTW; - // EXTLOGFONT} - EXTLOGFONT = EXTLOGFONTA; - PDisplayDeviceA = ^TDisplayDeviceA; - PDisplayDeviceW = ^TDisplayDeviceW; - PDisplayDevice = PDisplayDeviceA; - // _DISPLAY_DEVICEA} - _DISPLAY_DEVICEA = packed record - cb: DWORD; - DeviceName: array[0..31] of AnsiChar; - DeviceString: array[0..127] of AnsiChar; - StateFlags: DWORD; - end; - // _DISPLAY_DEVICEW} - _DISPLAY_DEVICEW = packed record - cb: DWORD; - DeviceName: array[0..31] of WideChar; - DeviceString: array[0..127] of WideChar; - StateFlags: DWORD; - end; - // _DISPLAY_DEVICE} - _DISPLAY_DEVICE = _DISPLAY_DEVICEA; - TDisplayDeviceA = _DISPLAY_DEVICEA; - TDisplayDeviceW = _DISPLAY_DEVICEW; - TDisplayDevice = TDisplayDeviceA; - POutlineTextmetricA = ^TOutlineTextmetricA; - POutlineTextmetricW = ^TOutlineTextmetricW; - POutlineTextmetric = POutlineTextmetricA; - // _OUTLINETEXTMETRICA} - _OUTLINETEXTMETRICA = record - otmSize: UINT; - otmTextMetrics: TTextMetricA; - otmFiller: Byte; - otmPanoseNumber: TPanose; - otmfsSelection: UINT; - otmfsType: UINT; - otmsCharSlopeRise: Integer; - otmsCharSlopeRun: Integer; - otmItalicAngle: Integer; - otmEMSquare: UINT; - otmAscent: Integer; - otmDescent: Integer; - otmLineGap: UINT; - otmsCapEmHeight: UINT; - otmsXHeight: UINT; - otmrcFontBox: TRect; - otmMacAscent: Integer; - otmMacDescent: Integer; - otmMacLineGap: UINT; - otmusMinimumPPEM: UINT; - otmptSubscriptSize: TPoint; - otmptSubscriptOffset: TPoint; - otmptSuperscriptSize: TPoint; - otmptSuperscriptOffset: TPoint; - otmsStrikeoutSize: UINT; - otmsStrikeoutPosition: Integer; - otmsUnderscoreSize: Integer; - otmsUnderscorePosition: Integer; - otmpFamilyName: PAnsiChar; - otmpFaceName: PAnsiChar; - otmpStyleName: PAnsiChar; - otmpFullName: PAnsiChar; - end; - // _OUTLINETEXTMETRICW} - _OUTLINETEXTMETRICW = record - otmSize: UINT; - otmTextMetrics: TTextMetricW; - otmFiller: Byte; - otmPanoseNumber: TPanose; - otmfsSelection: UINT; - otmfsType: UINT; - otmsCharSlopeRise: Integer; - otmsCharSlopeRun: Integer; - otmItalicAngle: Integer; - otmEMSquare: UINT; - otmAscent: Integer; - otmDescent: Integer; - otmLineGap: UINT; - otmsCapEmHeight: UINT; - otmsXHeight: UINT; - otmrcFontBox: TRect; - otmMacAscent: Integer; - otmMacDescent: Integer; - otmMacLineGap: UINT; - otmusMinimumPPEM: UINT; - otmptSubscriptSize: TPoint; - otmptSubscriptOffset: TPoint; - otmptSuperscriptSize: TPoint; - otmptSuperscriptOffset: TPoint; - otmsStrikeoutSize: UINT; - otmsStrikeoutPosition: Integer; - otmsUnderscoreSize: Integer; - otmsUnderscorePosition: Integer; - otmpFamilyName: PWideChar; - otmpFaceName: PWideChar; - otmpStyleName: PWideChar; - otmpFullName: PWideChar; - end; - // _OUTLINETEXTMETRIC} - _OUTLINETEXTMETRIC = _OUTLINETEXTMETRICA; - TOutlineTextmetricA = _OUTLINETEXTMETRICA; - TOutlineTextmetricW = _OUTLINETEXTMETRICW; - TOutlineTextmetric = TOutlineTextmetricA; - // OUTLINETEXTMETRICA} - OUTLINETEXTMETRICA = _OUTLINETEXTMETRICA; - // OUTLINETEXTMETRICW} - OUTLINETEXTMETRICW = _OUTLINETEXTMETRICW; - // OUTLINETEXTMETRIC} - OUTLINETEXTMETRIC = OUTLINETEXTMETRICA; - PPolyTextA = ^TPolyTextA; - PPolyTextW = ^TPolyTextW; - PPolyText = PPolyTextA; - // tagPOLYTEXTA} - tagPOLYTEXTA = packed record - x: Integer; - y: Integer; - n: UINT; - PAnsiChar: PAnsiChar; - uiFlags: UINT; - rcl: TRect; - pdx: PINT; - end; - // tagPOLYTEXTW} - tagPOLYTEXTW = packed record - x: Integer; - y: Integer; - n: UINT; - PAnsiChar: PWideChar; - uiFlags: UINT; - rcl: TRect; - pdx: PINT; - end; - // tagPOLYTEXT} - tagPOLYTEXT = tagPOLYTEXTA; - TPolyTextA = tagPOLYTEXTA; - TPolyTextW = tagPOLYTEXTW; - TPolyText = TPolyTextA; - // POLYTEXTA} - POLYTEXTA = tagPOLYTEXTA; - // POLYTEXTW} - POLYTEXTW = tagPOLYTEXTW; - // POLYTEXT} - POLYTEXT = POLYTEXTA; - PGCPResultsA = ^TGCPResultsA; - PGCPResultsW = ^TGCPResultsW; - PGCPResults = PGCPResultsA; - // tagGCP_RESULTSA} - tagGCP_RESULTSA = packed record - lStructSize: DWORD; - lpOutString: PAnsiChar; - lpOrder: PUINT; - lpDx: PINT; - lpCaretPos: PINT; - lpClass: PAnsiChar; - lpGlyphs: PUINT; - nGlyphs: UINT; - nMaxFit: Integer; - end; - // tagGCP_RESULTSW} - tagGCP_RESULTSW = packed record - lStructSize: DWORD; - lpOutString: PWideChar; - lpOrder: PUINT; - lpDx: PINT; - lpCaretPos: PINT; - lpClass: PWideChar; - lpGlyphs: PUINT; - nGlyphs: UINT; - nMaxFit: Integer; - end; - // tagGCP_RESULTS} - tagGCP_RESULTS = tagGCP_RESULTSA; - TGCPResultsA = tagGCP_RESULTSA; - TGCPResultsW = tagGCP_RESULTSW; - TGCPResults = TGCPResultsA; - // GCP_RESULTSA} - GCP_RESULTSA = tagGCP_RESULTSA; - // GCP_RESULTSW} - GCP_RESULTSW = tagGCP_RESULTSW; - // GCP_RESULTS} - GCP_RESULTS = GCP_RESULTSA; -const - MM_MAX_AXES_NAMELEN = 16; - MM_MAX_NUMAXES = 16; -type - PAxisInfoA = ^TAxisInfoA; - tagAXISINFOA = packed record - axMinValue: Longint; - axMaxValue: Longint; - axAxisName: array[0..MM_MAX_AXES_NAMELEN-1] of AnsiChar; - end; - TAxisInfoA = tagAXISINFOA; - PAxisInfoW = ^TAxisInfoW; - // tagAXISINFOW} - tagAXISINFOW = packed record - axMinValue: Longint; - axMaxValue: Longint; - axAxisName: array[0..MM_MAX_AXES_NAMELEN-1] of WideChar; - end; - TAxisInfoW = tagAXISINFOW; - PAxisInfo = PAxisInfoA; - PAxesListA = ^TAxesListA; - // tagAXESLISTA} - tagAXESLISTA = packed record - axlReserved: DWORD; - axlNumAxes: DWORD; - axlAxisInfo: array[0..MM_MAX_NUMAXES-1] of TAxisInfoA; - end; - TAxesListA = tagAXESLISTA; - PAxesListW = ^TAxesListW; - // tagAXESLISTW} - tagAXESLISTW = packed record - axlReserved: DWORD; - axlNumAxes: DWORD; - axlAxisInfo: array[0..MM_MAX_NUMAXES-1] of TAxisInfoW; - end; - TAxesListW = tagAXESLISTW; - PAxesList = PAxesListA; - PEnumLogFontExDVA = ^TEnumLogFontExDVA; - PDesignVector = ^TDesignVector; - tagDESIGNVECTOR = packed record - dvReserved: DWORD; - dvNumAxes: DWORD; - dvValues: array[0..MM_MAX_NUMAXES-1] of Longint; - end; - TDesignVector = tagDESIGNVECTOR; - tagENUMLOGFONTEXDVA = packed record - elfEnumLogfontEx: TEnumLogFontExA; - elfDesignVector: TDesignVector; - end; - TEnumLogFontExDVA = tagENUMLOGFONTEXDVA; - PEnumLogFontExDVW = ^TEnumLogFontExDVW; - // tagENUMLOGFONTEXDVW} - tagENUMLOGFONTEXDVW = packed record - elfEnumLogfontEx: TEnumLogFontExW; - elfDesignVector: TDesignVector; - end; - TEnumLogFontExDVW = tagENUMLOGFONTEXDVW; - PEnumLogFontExDV = PEnumLogFontExDVA; - PEnumTextMetricA = ^TEnumTextMetricA; - // tagENUMTEXTMETRICA} - tagENUMTEXTMETRICA = packed record - etmNewTextMetricEx: TNewTextMetricExA; - etmAxesList: TAxesListA; - end; - TEnumTextMetricA = tagENUMTEXTMETRICA; - PEnumTextMetricW = ^TEnumTextMetricW; - // tagENUMTEXTMETRICW} - tagENUMTEXTMETRICW = packed record - etmNewTextMetricEx: TNewTextMetricExW; - etmAxesList: TAxesListW; - end; - TEnumTextMetricW = tagENUMTEXTMETRICW; - PEnumTextMetric = PEnumTextMetricA; - PDocInfoA = ^TDocInfoA; - PDocInfoW = ^TDocInfoW; - PDocInfo = PDocInfoA; - // _DOCINFOA} - _DOCINFOA = packed record - cbSize: Integer; - lpszDocName: PAnsiChar; - lpszOutput: PAnsiChar; - lpszDatatype: PAnsiChar; - fwType: DWORD; - end; - // _DOCINFOW} - _DOCINFOW = packed record - cbSize: Integer; - lpszDocName: PWideChar; - lpszOutput: PWideChar; - lpszDatatype: PWideChar; - fwType: DWORD; - end; - // _DOCINFO} - _DOCINFO = _DOCINFOA; - TDocInfoA = _DOCINFOA; - TDocInfoW = _DOCINFOW; - TDocInfo = TDocInfoA; - // DOCINFOA} - DOCINFOA = _DOCINFOA; - // DOCINFOW} - DOCINFOW = _DOCINFOW; - // DOCINFO} - DOCINFO = DOCINFOA; - PCreateStructA = ^TCreateStructA; - PCreateStructW = ^TCreateStructW; - PCreateStruct = PCreateStructA; - // tagCREATESTRUCTA} - tagCREATESTRUCTA = packed record - lpCreateParams: Pointer; - hInstance: HINST; - hMenu: HMENU; - hwndParent: HWND; - cy: Integer; - cx: Integer; - y: Integer; - x: Integer; - style: Longint; - lpszName: PAnsiChar; - lpszClass: PAnsiChar; - dwExStyle: DWORD; - end; - // tagCREATESTRUCTW} - tagCREATESTRUCTW = packed record - lpCreateParams: Pointer; - hInstance: HINST; - hMenu: HMENU; - hwndParent: HWND; - cy: Integer; - cx: Integer; - y: Integer; - x: Integer; - style: Longint; - lpszName: PWideChar; - lpszClass: PWideChar; - dwExStyle: DWORD; - end; - // tagCREATESTRUCT} - tagCREATESTRUCT = tagCREATESTRUCTA; - TCreateStructA = tagCREATESTRUCTA; - TCreateStructW = tagCREATESTRUCTW; - TCreateStruct = TCreateStructA; - // CREATESTRUCTA} - CREATESTRUCTA = tagCREATESTRUCTA; - // CREATESTRUCTW} - CREATESTRUCTW = tagCREATESTRUCTW; - // CREATESTRUCT} - CREATESTRUCT = CREATESTRUCTA; - PWndClassExA = ^TWndClassExA; - PWndClassExW = ^TWndClassExW; - PWndClassEx = PWndClassExA; - // tagWNDCLASSEXA} - tagWNDCLASSEXA = packed record - cbSize: UINT; - style: UINT; - lpfnWndProc: TFNWndProc; - cbClsExtra: Integer; - cbWndExtra: Integer; - hInstance: HINST; - hIcon: HICON; - hCursor: HCURSOR; - hbrBackground: HBRUSH; - lpszMenuName: PAnsiChar; - lpszClassName: PAnsiChar; - hIconSm: HICON; - end; - // tagWNDCLASSEXW} - tagWNDCLASSEXW = packed record - cbSize: UINT; - style: UINT; - lpfnWndProc: TFNWndProc; - cbClsExtra: Integer; - cbWndExtra: Integer; - hInstance: HINST; - hIcon: HICON; - hCursor: HCURSOR; - hbrBackground: HBRUSH; - lpszMenuName: PWideChar; - lpszClassName: PWideChar; - hIconSm: HICON; - end; - // tagWNDCLASSEX} - tagWNDCLASSEX = tagWNDCLASSEXA; - TWndClassExA = tagWNDCLASSEXA; - TWndClassExW = tagWNDCLASSEXW; - TWndClassEx = TWndClassExA; - // WNDCLASSEXA} - WNDCLASSEXA = tagWNDCLASSEXA; - // WNDCLASSEXW} - WNDCLASSEXW = tagWNDCLASSEXW; - // WNDCLASSEX} - WNDCLASSEX = WNDCLASSEXA; - - PWndClassA = ^TWndClassA; - PWndClassW = ^TWndClassW; - PWndClass = PWndClassA; - // tagWNDCLASSA} - tagWNDCLASSA = packed record - style: UINT; - lpfnWndProc: TFNWndProc; - cbClsExtra: Integer; - cbWndExtra: Integer; - hInstance: HINST; - hIcon: HICON; - hCursor: HCURSOR; - hbrBackground: HBRUSH; - lpszMenuName: PAnsiChar; - lpszClassName: PAnsiChar; - end; - // tagWNDCLASSW} - tagWNDCLASSW = packed record - style: UINT; - lpfnWndProc: TFNWndProc; - cbClsExtra: Integer; - cbWndExtra: Integer; - hInstance: HINST; - hIcon: HICON; - hCursor: HCURSOR; - hbrBackground: HBRUSH; - lpszMenuName: PWideChar; - lpszClassName: PWideChar; - end; - // tagWNDCLASS} - tagWNDCLASS = tagWNDCLASSA; - TWndClassA = tagWNDCLASSA; - TWndClassW = tagWNDCLASSW; - TWndClass = TWndClassA; - // WNDCLASSA} - WNDCLASSA = tagWNDCLASSA; - // WNDCLASSW} - WNDCLASSW = tagWNDCLASSW; - // WNDCLASS} - WNDCLASS = WNDCLASSA; - HDEVNOTIFY = Pointer; - PHDEVNOTIFY = ^HDEVNOTIFY; - //// - MakeIntAtom = MakeIntAtomA; - PWin32FindData = PWin32FindDataA; - TWin32FindData = TWin32FindDataA; - {$IFDEF _D3orHigher} - PHWProfileInfo = PHWProfileInfoA; - THWProfileInfo = THWProfileInfoA; - {$ENDIF} - POSVersionInfo = POSVersionInfoA; - TOSVersionInfo = TOSVersionInfoA; - PLogColorSpace = PLogColorSpaceA; - TLogColorSpace = TLogColorSpaceA; - PLogFont = PLogFontA; - TLogFont = TLogFontA; - PDeviceMode = PDeviceModeA; - TDeviceMode = TDeviceModeA; - TFNOldFontEnumProc = TFNOldFontEnumProcA; - TFNFontEnumProc = TFNFontEnumProcA; - MakeIntResource = PAnsiChar; // MakeIntResourceA; - //PMenuItemInfo = PMenuItemInfoA; - //TMenuItemInfo = TMenuItemInfoA; - //MENUITEMINFO = MENUITEMINFOA; - PMsgBoxParams = PMsgBoxParamsA; - TMsgBoxParams = TMsgBoxParamsA; - PMsgBoxParamsA = ^TMsgBoxParamsA; - PMsgBoxParamsW = ^TMsgBoxParamsW; - // tagMSGBOXPARAMSA} - tagMSGBOXPARAMSA = packed record - cbSize: UINT; - hwndOwner: HWND; - hInstance: HINST; - lpszText: PAnsiChar; - lpszCaption: PAnsiChar; - dwStyle: DWORD; - lpszIcon: PAnsiChar; - dwContextHelpId: DWORD; - lpfnMsgBoxCallback: TPRMsgBoxCallback; - dwLanguageId: DWORD; - end; - // tagMSGBOXPARAMSW} - tagMSGBOXPARAMSW = packed record - cbSize: UINT; - hwndOwner: HWND; - hInstance: HINST; - lpszText: PWideChar; - lpszCaption: PWideChar; - dwStyle: DWORD; - lpszIcon: PWideChar; - dwContextHelpId: DWORD; - lpfnMsgBoxCallback: TPRMsgBoxCallback; - dwLanguageId: DWORD; - end; - // tagMSGBOXPARAMS} - tagMSGBOXPARAMS = tagMSGBOXPARAMSA; - TMsgBoxParamsA = tagMSGBOXPARAMSA; - TMsgBoxParamsW = tagMSGBOXPARAMSW; - // MSGBOXPARAMSA} - MSGBOXPARAMSA = tagMSGBOXPARAMSA; - // MSGBOXPARAMSW} - MSGBOXPARAMSW = tagMSGBOXPARAMSW; - // MSGBOXPARAMS} - MSGBOXPARAMS = MSGBOXPARAMSA; - PMDICreateStruct = PMDICreateStructA; - TMDICreateStruct = TMDICreateStructA; - PMultiKeyHelp = PMultiKeyHelpA; - TMultiKeyHelp = TMultiKeyHelpA; - // HELPPOLY} - HELPPOLY = DWORD; - PMultiKeyHelpA = ^TMultiKeyHelpA; - PMultiKeyHelpW = ^TMultiKeyHelpW; - // tagMULTIKEYHELPA} - tagMULTIKEYHELPA = record - mkSize: DWORD; - mkKeylist: AnsiChar; - szKeyphrase: array[0..0] of AnsiChar; - end; - // tagMULTIKEYHELPW} - tagMULTIKEYHELPW = record - mkSize: DWORD; - mkKeylist: WideChar; - szKeyphrase: array[0..0] of WideChar; - end; - // tagMULTIKEYHELP} - tagMULTIKEYHELP = tagMULTIKEYHELPA; - TMultiKeyHelpA = tagMULTIKEYHELPA; - TMultiKeyHelpW = tagMULTIKEYHELPW; - // MULTIKEYHELPA} - MULTIKEYHELPA = tagMULTIKEYHELPA; - // MULTIKEYHELPW} - MULTIKEYHELPW = tagMULTIKEYHELPW; - // MULTIKEYHELP} - MULTIKEYHELP = MULTIKEYHELPA; - PHelpWinInfoA = ^THelpWinInfoA; - PHelpWinInfoW = ^THelpWinInfoW; - PHelpWinInfo = PHelpWinInfoA; - // tagHELPWININFOA} - tagHELPWININFOA = record - wStructSize: Integer; - x: Integer; - y: Integer; - dx: Integer; - dy: Integer; - wMax: Integer; - rgchMember: array[0..1] of AnsiChar; - end; - // tagHELPWININFOW} - tagHELPWININFOW = record - wStructSize: Integer; - x: Integer; - y: Integer; - dx: Integer; - dy: Integer; - wMax: Integer; - rgchMember: array[0..1] of WideChar; - end; - // tagHELPWININFO} - tagHELPWININFO = tagHELPWININFOA; - THelpWinInfoA = tagHELPWININFOA; - THelpWinInfoW = tagHELPWININFOW; - THelpWinInfo = THelpWinInfoA; - // HELPWININFOA} - HELPWININFOA = tagHELPWININFOA; - // HELPWININFOW} - HELPWININFOW = tagHELPWININFOW; - // HELPWININFO} - HELPWININFO = HELPWININFOA; - // tagNONCLIENTMETRICSA} - tagNONCLIENTMETRICSA = packed record - cbSize: UINT; - iBorderWidth: Integer; - iScrollWidth: Integer; - iScrollHeight: Integer; - iCaptionWidth: Integer; - iCaptionHeight: Integer; - lfCaptionFont: TLogFontA; - iSmCaptionWidth: Integer; - iSmCaptionHeight: Integer; - lfSmCaptionFont: TLogFontA; - iMenuWidth: Integer; - iMenuHeight: Integer; - lfMenuFont: TLogFontA; - lfStatusFont: TLogFontA; - lfMessageFont: TLogFontA; - end; - // tagNONCLIENTMETRICSW} - tagNONCLIENTMETRICSW = packed record - cbSize: UINT; - iBorderWidth: Integer; - iScrollWidth: Integer; - iScrollHeight: Integer; - iCaptionWidth: Integer; - iCaptionHeight: Integer; - lfCaptionFont: TLogFontW; - iSmCaptionWidth: Integer; - iSmCaptionHeight: Integer; - lfSmCaptionFont: TLogFontW; - iMenuWidth: Integer; - iMenuHeight: Integer; - lfMenuFont: TLogFontW; - lfStatusFont: TLogFontW; - lfMessageFont: TLogFontW; - end; - // tagNONCLIENTMETRICS} - tagNONCLIENTMETRICS = tagNONCLIENTMETRICSA; - TNonClientMetricsA = tagNONCLIENTMETRICSA; - TNonClientMetricsW = tagNONCLIENTMETRICSW; - PNonClientMetricsA = ^TNonClientMetricsA; - PNonClientMetrics = PNonClientMetricsA; - TNonClientMetrics = TNonClientMetricsA; - PNonClientMetricsW = ^TNonClientMetricsW; - // NONCLIENTMETRICSA} - NONCLIENTMETRICSA = tagNONCLIENTMETRICSA; - // NONCLIENTMETRICSW} - NONCLIENTMETRICSW = tagNONCLIENTMETRICSW; - // NONCLIENTMETRICS} - NONCLIENTMETRICS = NONCLIENTMETRICSA; - // tagICONMETRICSA} - tagICONMETRICSA = packed record - cbSize: UINT; - iHorzSpacing: Integer; - iVertSpacing: Integer; - iTitleWrap: Integer; - lfFont: TLogFontA; - end; - // tagICONMETRICSW} - tagICONMETRICSW = packed record - cbSize: UINT; - iHorzSpacing: Integer; - iVertSpacing: Integer; - iTitleWrap: Integer; - lfFont: TLogFontW; - end; - // tagICONMETRICS} - tagICONMETRICS = tagICONMETRICSA; - TIconMetricsA = tagICONMETRICSA; - TIconMetricsW = tagICONMETRICSW; - PIconMetricsA = ^TIconMetricsA; - PIconMetricsW = ^TIconMetricsW; - PIconMetrics = PIconMetricsA; - TIconMetrics = TIconMetricsA; - // ICONMETRICSA} - ICONMETRICSA = tagICONMETRICSA; - // ICONMETRICSW} - ICONMETRICSW = tagICONMETRICSW; - // ICONMETRICS} - ICONMETRICS = ICONMETRICSA; - PSerialKeys = PSerialKeysA; - TSerialKeys = TSerialKeysA; - PSerialKeysA = ^TSerialKeysA; - PSerialKeysW = ^TSerialKeysW; - // tagSERIALKEYSA} - tagSERIALKEYSA = packed record - cbSize: UINT; - dwFlags: DWORD; - lpszActivePort: PAnsiChar; - lpszPort: PAnsiChar; - iBaudRate: UINT; - iPortState: UINT; - iActive: UINT; - end; - // tagSERIALKEYSW} - tagSERIALKEYSW = packed record - cbSize: UINT; - dwFlags: DWORD; - lpszActivePort: PWideChar; - lpszPort: PWideChar; - iBaudRate: UINT; - iPortState: UINT; - iActive: UINT; - end; - // tagSERIALKEYS} - tagSERIALKEYS = tagSERIALKEYSA; - TSerialKeysA = tagSERIALKEYSA; - TSerialKeysW = tagSERIALKEYSW; - // SERIALKEYSA} - SERIALKEYSA = tagSERIALKEYSA; - // SERIALKEYSW} - SERIALKEYSW = tagSERIALKEYSW; - // SERIALKEYS} - SERIALKEYS = SERIALKEYSA; - PHighContrast = PHighContrastA; - THighContrast = THighContrastA; - PHighContrastA = ^THighContrastA; - PHighContrastW = ^THighContrastW; - // tagHIGHCONTRASTA} - tagHIGHCONTRASTA = packed record - cbSize: UINT; - dwFlags: DWORD; - lpszDefaultScheme: PAnsiChar; - end; - // tagHIGHCONTRASTW} - tagHIGHCONTRASTW = packed record - cbSize: UINT; - dwFlags: DWORD; - lpszDefaultScheme: PWideChar; - end; - // tagHIGHCONTRAST} - tagHIGHCONTRAST = tagHIGHCONTRASTA; - THighContrastA = tagHIGHCONTRASTA; - THighContrastW = tagHIGHCONTRASTW; - // HIGHCONTRASTA} - HIGHCONTRASTA = tagHIGHCONTRASTA; - // HIGHCONTRASTW} - HIGHCONTRASTW = tagHIGHCONTRASTW; - // HIGHCONTRAST} - HIGHCONTRAST = HIGHCONTRASTA; - PSoundsEntry = PSoundsEntryA; - TSoundsEntry = TSoundsEntryA; - PSoundsEntryA = ^TSoundsEntryA; - PSoundsEntryW = ^TSoundsEntryW; - // tagSOUNDSENTRYA} - tagSOUNDSENTRYA = packed record - cbSize: UINT; - dwFlags: DWORD; - iFSTextEffect: DWORD; - iFSTextEffectMSec: DWORD; - iFSTextEffectColorBits: DWORD; - iFSGrafEffect: DWORD; - iFSGrafEffectMSec: DWORD; - iFSGrafEffectColor: DWORD; - iWindowsEffect: DWORD; - iWindowsEffectMSec: DWORD; - lpszWindowsEffectDLL: PAnsiChar; - iWindowsEffectOrdinal: DWORD; - end; - // tagSOUNDSENTRYW} - tagSOUNDSENTRYW = packed record - cbSize: UINT; - dwFlags: DWORD; - iFSTextEffect: DWORD; - iFSTextEffectMSec: DWORD; - iFSTextEffectColorBits: DWORD; - iFSGrafEffect: DWORD; - iFSGrafEffectMSec: DWORD; - iFSGrafEffectColor: DWORD; - iWindowsEffect: DWORD; - iWindowsEffectMSec: DWORD; - lpszWindowsEffectDLL: PWideChar; - iWindowsEffectOrdinal: DWORD; - end; - // tagSOUNDSENTRY} - tagSOUNDSENTRY = tagSOUNDSENTRYA; - TSoundsEntryA = tagSOUNDSENTRYA; - TSoundsEntryW = tagSOUNDSENTRYW; - // SOUNDSENTRYA} - SOUNDSENTRYA = tagSOUNDSENTRYA; - // SOUNDSENTRYW} - SOUNDSENTRYW = tagSOUNDSENTRYW; - // SOUNDSENTRY} - SOUNDSENTRY = SOUNDSENTRYA; - PNumberFmt = PNumberFmtA; - TNumberFmt = TNumberFmtA; - PNumberFmtA = ^TNumberFmtA; - PNumberFmtW = ^TNumberFmtW; - // _numberfmtA} - _numberfmtA = packed record - NumDigits: UINT; { number of decimal digits } - LeadingZero: UINT; { if leading zero in decimal fields } - Grouping: UINT; { group size left of decimal } - lpDecimalSep: PAnsiChar; { ptr to decimal separator AnsiString } - lpThousandSep: PAnsiChar; { ptr to thousand separator AnsiString } - NegativeOrder: UINT; { negative number ordering } - end; - // _numberfmtW} - _numberfmtW = packed record - NumDigits: UINT; { number of decimal digits } - LeadingZero: UINT; { if leading zero in decimal fields } - Grouping: UINT; { group size left of decimal } - lpDecimalSep: PWideChar; { ptr to decimal separator WideString } - lpThousandSep: PWideChar; { ptr to thousand separator WideString } - NegativeOrder: UINT; { negative number ordering } - end; - // _numberfmt} - _numberfmt = _numberfmtA; - TNumberFmtA = _numberfmtA; - TNumberFmtW = _numberfmtW; - // NUMBERFMTA} - NUMBERFMTA = _numberfmtA; - // NUMBERFMTW} - NUMBERFMTW = _numberfmtW; - // NUMBERFMT} - NUMBERFMT = NUMBERFMTA; - PCurrencyFmt = PCurrencyFmtA; - PCurrencyFmtA = ^TCurrencyFmtA; - PCurrencyFmtW = ^TCurrencyFmtW; - // _currencyfmtA} - _currencyfmtA = packed record - NumDigits: UINT; { number of decimal digits } - LeadingZero: UINT; { if leading zero in decimal fields } - Grouping: UINT; { group size left of decimal } - lpDecimalSep: PAnsiChar; { ptr to decimal separator AnsiString } - lpThousandSep: PAnsiChar; { ptr to thousand separator AnsiString } - NegativeOrder: UINT; { negative currency ordering } - PositiveOrder: UINT; { positive currency ordering } - lpCurrencySymbol: PAnsiChar; { ptr to currency symbol AnsiString } - end; - // _currencyfmtW} - _currencyfmtW = packed record - NumDigits: UINT; { number of decimal digits } - LeadingZero: UINT; { if leading zero in decimal fields } - Grouping: UINT; { group size left of decimal } - lpDecimalSep: PWideChar; { ptr to decimal separator WideString } - lpThousandSep: PWideChar; { ptr to thousand separator WideString } - NegativeOrder: UINT; { negative currency ordering } - PositiveOrder: UINT; { positive currency ordering } - lpCurrencySymbol: PWideChar; { ptr to currency symbol WideString } - end; - // _currencyfmt} - _currencyfmt = _currencyfmtA; - TCurrencyFmtA = _currencyfmtA; - TCurrencyFmtW = _currencyfmtW; - TCurrencyFmt = TCurrencyFmtA; - // CURRENCYFMTA} - CURRENCYFMTA = _currencyfmtA; - // CURRENCYFMTW} - CURRENCYFMTW = _currencyfmtW; - // CURRENCYFMT} - CURRENCYFMT = CURRENCYFMTA; - PPValue = PPValueA; -{ Provider supplied value/context.} - PPValueA = ^TPValueA; - PPValueW = ^TPValueW; - // pvalueA} - pvalueA = packed record - pv_valuename: PAnsiChar; { The value name pointer } - pv_valuelen: BOOL; - pv_value_context: Pointer; - pv_type: DWORD; - end; - // pvalueW} - pvalueW = packed record - pv_valuename: PWideChar; { The value name pointer } - pv_valuelen: BOOL; - pv_value_context: Pointer; - pv_type: DWORD; - end; - // pvalue} - pvalue = pvalueA; - TPValueA = pvalueA; - TPValueW = pvalueW; - TPValue = TPValueA; - PValueEnt = PValueEntA; - TValueEnt = TValueEntA; - PValueEntA = ^TValueEntA; - PValueEntW = ^TValueEntW; - // value_entA} - value_entA = packed record - ve_valuename: PAnsiChar; - ve_valuelen: DWORD; - ve_valueptr: DWORD; - ve_type: DWORD; - end; - // value_entW} - value_entW = packed record - ve_valuename: PWideChar; - ve_valuelen: DWORD; - ve_valueptr: DWORD; - ve_type: DWORD; - end; - // value_ent} - value_ent = value_entA; - TValueEntA = value_entA; - TValueEntW = value_entW; - // VALENTA} - VALENTA = value_entA; - // VALENTW} - VALENTW = value_entW; - // VALENT} - VALENT = VALENTA; - TValEnt = TValueEnt; - PValEnt = PValueEnt; - PNetResource = PNetResourceA; - TNetResource = TNetResourceA; - PNetResourceA = ^TNetResourceA; - PNetResourceW = ^TNetResourceW; - // _NETRESOURCEA} - _NETRESOURCEA = packed record - dwScope: DWORD; - dwType: DWORD; - dwDisplayType: DWORD; - dwUsage: DWORD; - lpLocalName: PAnsiChar; - lpRemoteName: PAnsiChar; - lpComment: PAnsiChar; - lpProvider: PAnsiChar; - end; - // _NETRESOURCEW} - _NETRESOURCEW = packed record - dwScope: DWORD; - dwType: DWORD; - dwDisplayType: DWORD; - dwUsage: DWORD; - lpLocalName: PWideChar; - lpRemoteName: PWideChar; - lpComment: PWideChar; - lpProvider: PWideChar; - end; - // _NETRESOURCE} - _NETRESOURCE = _NETRESOURCEA; - TNetResourceA = _NETRESOURCEA; - TNetResourceW = _NETRESOURCEW; - // NETRESOURCEA} - NETRESOURCEA = _NETRESOURCEA; - // NETRESOURCEW} - NETRESOURCEW = _NETRESOURCEW; - // NETRESOURCE} - NETRESOURCE = NETRESOURCEA; - PDiscDlgStruct = PDiscDlgStructA; - PDiscDlgStructA = ^TDiscDlgStructA; - PDiscDlgStructW = ^TDiscDlgStructW; - // _DISCDLGSTRUCTA} - _DISCDLGSTRUCTA = packed record - cbStructure: DWORD; { size of this structure in bytes } - hwndOwner: HWND; { owner window for the dialog } - lpLocalName: PAnsiChar; { local device name } - lpRemoteName: PAnsiChar; { network resource name } - dwFlags: DWORD; - end; - // _DISCDLGSTRUCTW} - _DISCDLGSTRUCTW = packed record - cbStructure: DWORD; { size of this structure in bytes } - hwndOwner: HWND; { owner window for the dialog } - lpLocalName: PWideChar; { local device name } - lpRemoteName: PWideChar; { network resource name } - dwFlags: DWORD; - end; - // _DISCDLGSTRUCT} - _DISCDLGSTRUCT = _DISCDLGSTRUCTA; - TDiscDlgStructA = _DISCDLGSTRUCTA; - TDiscDlgStructW = _DISCDLGSTRUCTW; - TDiscDlgStruct = TDiscDlgStructA; - // DISCDLGSTRUCTA} - DISCDLGSTRUCTA = _DISCDLGSTRUCTA; - // DISCDLGSTRUCTW} - DISCDLGSTRUCTW = _DISCDLGSTRUCTW; - // DISCDLGSTRUCT} - DISCDLGSTRUCT = DISCDLGSTRUCTA; - PUniversalNameInfo = PUniversalNameInfoA; - TUniversalNameInfo = TUniversalNameInfoA; - PUniversalNameInfoA = ^TUniversalNameInfoA; - PUniversalNameInfoW = ^TUniversalNameInfoW; - // _UNIVERSAL_NAME_INFOA} - _UNIVERSAL_NAME_INFOA = packed record - lpUniversalName: PAnsiChar; - end; - // _UNIVERSAL_NAME_INFOW} - _UNIVERSAL_NAME_INFOW = packed record - lpUniversalName: PWideChar; - end; - // _UNIVERSAL_NAME_INFO} - _UNIVERSAL_NAME_INFO = _UNIVERSAL_NAME_INFOA; - TUniversalNameInfoA = _UNIVERSAL_NAME_INFOA; - TUniversalNameInfoW = _UNIVERSAL_NAME_INFOW; - // UNIVERSAL_NAME_INFOA} - UNIVERSAL_NAME_INFOA = _UNIVERSAL_NAME_INFOA; - // UNIVERSAL_NAME_INFOW} - UNIVERSAL_NAME_INFOW = _UNIVERSAL_NAME_INFOW; - // UNIVERSAL_NAME_INFO} - UNIVERSAL_NAME_INFO = UNIVERSAL_NAME_INFOA; - PRemoteNameInfo = PRemoteNameInfoA; - TRemoteNameInfo = TRemoteNameInfoA; - PRemoteNameInfoA = ^TRemoteNameInfoA; - PRemoteNameInfoW = ^TRemoteNameInfoW; - // _REMOTE_NAME_INFOA} - _REMOTE_NAME_INFOA = packed record - lpUniversalName: PAnsiChar; - lpConnectionName: PAnsiChar; - lpRemainingPath: PAnsiChar; - end; - // _REMOTE_NAME_INFOW} - _REMOTE_NAME_INFOW = packed record - lpUniversalName: PWideChar; - lpConnectionName: PWideChar; - lpRemainingPath: PWideChar; - end; - // _REMOTE_NAME_INFO} - _REMOTE_NAME_INFO = _REMOTE_NAME_INFOA; - TRemoteNameInfoA = _REMOTE_NAME_INFOA; - TRemoteNameInfoW = _REMOTE_NAME_INFOW; - // REMOTE_NAME_INFOA} - REMOTE_NAME_INFOA = _REMOTE_NAME_INFOA; - // REMOTE_NAME_INFOW} - REMOTE_NAME_INFOW = _REMOTE_NAME_INFOW; - // REMOTE_NAME_INFO} - REMOTE_NAME_INFO = REMOTE_NAME_INFOA; - AUDIT_EVENT_TYPE = DWORD; - {$IFDEF _D3orHigher} - PObjectTypeList = ^TObjectTypeList; - _OBJECT_TYPE_LIST = record - Level: WORD; - Sbz: WORD; - ObjectType: PGUID; - end; - TObjectTypeList = _OBJECT_TYPE_LIST; - OBJECT_TYPE_LIST = _OBJECT_TYPE_LIST; - {$ENDIF _D3orHigher} - { Alt-Tab Switch window information. } - PAltTabInfo = ^TAltTabInfo; - tagALTTABINFO = packed record - cbSize: DWORD; - cItems: Integer; - cColumns: Integer; - cRows: Integer; - iColFocus: Integer; - iRowFocus: Integer; - cxItem: Integer; - cyItem: Integer; - ptStart: TPoint; - end; - TAltTabInfo = tagALTTABINFO; - -function AbortSystemShutdown(lpMachineName: PKOLChar): BOOL; stdcall; -function AccessCheckAndAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; ObjectTypeName, ObjectName: PKOLChar; - SecurityDescriptor: PSecurityDescriptor; DesiredAccess: DWORD; - const GenericMapping: TGenericMapping; ObjectCreation: BOOL; - var GrantedAccess: DWORD; var AccessStatus, pfGenerateOnClose: BOOL): BOOL; stdcall; -{$IFDEF _D4orHigher} -function AccessCheckByTypeAndAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; ObjectTypeName, ObjectName: PKOLChar; - SecurityDescriptor: PSecurityDescriptor; PrincipalSelfSid: PSID; DesiredAccess: DWORD; - AuditType: AUDIT_EVENT_TYPE; Flags: DWORD; ObjectTypeList: PObjectTypeList; - ObjectTypeListLength: DWORD; const GenericMapping: TGenericMapping; ObjectCreation: BOOL; - var GrantedAccess: DWORD; var AccessStatus, pfGenerateOnClose: BOOL): BOOL; stdcall; -function AccessCheckByTypeResultListAndAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; ObjectTypeName, ObjectName: PKOLChar; - SecurityDescriptor: PSecurityDescriptor; PrincipalSelfSid: PSID; DesiredAccess: DWORD; - AuditType: AUDIT_EVENT_TYPE; Flags: DWORD; ObjectTypeList: PObjectTypeList; - ObjectTypeListLength: DWORD; const GenericMapping: TGenericMapping; ObjectCreation: BOOL; - var GrantedAccess: DWORD; var AccessStatusList: DWORD; var pfGenerateOnClose: BOOL): BOOL; stdcall; -{$ENDIF _D4orHigher} -function BackupEventLog(hEventLog: THandle; lpBackupFileName: PKOLChar): BOOL; stdcall; -function ClearEventLog(hEventLog: THandle; lpBackupFileName: PKOLChar): BOOL; stdcall; -function CreateProcessAsUser(hToken: THandle; lpApplicationName: PKOLChar; - lpCommandLine: PKOLChar; lpProcessAttributes: PSecurityAttributes; - lpThreadAttributes: PSecurityAttributes; bInheritHandles: BOOL; - dwCreationFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: PKOLChar; - const lpStartupInfo: TStartupInfo; var lpProcessInformation: TProcessInformation): BOOL; stdcall; -{$IFDEF _D3orHigher} -function GetCurrentHwProfile(var lpHwProfileInfo: THWProfileInfo): BOOL; stdcall; -{$ENDIF _D3orHigher} -function GetFileSecurity(lpFileName: PKOLChar; RequestedInformation: SECURITY_INFORMATION; - pSecurityDescriptor: PSecurityDescriptor; nLength: DWORD; var lpnLengthNeeded: DWORD): BOOL; stdcall; -function GetUserName(lpBuffer: PKOLChar; var nSize: DWORD): BOOL; stdcall; -function InitiateSystemShutdown(lpMachineName, lpMessage: PKOLChar; - dwTimeout: DWORD; bForceAppsClosed, bRebootAfterShutdown: BOOL): BOOL; stdcall; -function LogonUser(lpszUsername, lpszDomain, lpszPassword: PKOLChar; - dwLogonType, dwLogonProvider: DWORD; var phToken: THandle): BOOL; stdcall; -function LookupAccountName(lpSystemName, lpAccountName: PKOLChar; - Sid: PSID; var cbSid: DWORD; ReferencedDomainName: PKOLChar; - var cbReferencedDomainName: DWORD; var peUse: SID_NAME_USE): BOOL; stdcall; -function LookupAccountSid(lpSystemName: PKOLChar; Sid: PSID; - Name: PKOLChar; var cbName: DWORD; ReferencedDomainName: PKOLChar; - var cbReferencedDomainName: DWORD; var peUse: SID_NAME_USE): BOOL; stdcall; -function LookupPrivilegeDisplayName(lpSystemName, lpName: PKOLChar; - lpDisplayName: PKOLChar; var cbDisplayName, lpLanguageId: DWORD): BOOL; stdcall; -function LookupPrivilegeName(lpSystemName: PKOLChar; - var lpLuid: TLargeInteger; lpName: PKOLChar; var cbName: DWORD): BOOL; stdcall; -function LookupPrivilegeValue(lpSystemName, lpName: PKOLChar; - var lpLuid: TLargeInteger): BOOL; stdcall; -function ObjectCloseAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; GenerateOnClose: BOOL): BOOL; stdcall; -function ObjectDeleteAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; GenerateOnClose: BOOL): BOOL; stdcall; -function ObjectOpenAuditAlarm(SubsystemName: PKOLChar; HandleId: Pointer; - ObjectTypeName: PKOLChar; ObjectName: PKOLChar; pSecurityDescriptor: PSecurityDescriptor; - ClientToken: THandle; DesiredAccess, GrantedAccess: DWORD; - var Privileges: TPrivilegeSet; ObjectCreation, AccessGranted: BOOL; - var GenerateOnClose: BOOL): BOOL; stdcall; -function ObjectPrivilegeAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; ClientToken: THandle; DesiredAccess: DWORD; - var Privileges: TPrivilegeSet; AccessGranted: BOOL): BOOL; stdcall; -function OpenBackupEventLog(lpUNCServerName, lpFileName: PKOLChar): THandle; stdcall; -function OpenEventLog(lpUNCServerName, lpSourceName: PKOLChar): THandle; stdcall; -function PrivilegedServiceAuditAlarm(SubsystemName, ServiceName: PKOLChar; - ClientToken: THandle; var Privileges: TPrivilegeSet; AccessGranted: BOOL): BOOL; stdcall; -function ReadEventLog(hEventLog: THandle; dwReadFlags, dwRecordOffset: DWORD; - lpBuffer: Pointer; nNumberOfBytesToRead: DWORD; - var pnBytesRead, pnMinNumberOfBytesNeeded: DWORD): BOOL; stdcall; -function RegConnectRegistry(lpMachineName: PKOLChar; hKey: HKEY; - var phkResult: HKEY): Longint; stdcall; -function RegCreateKey(hKey: HKEY; lpSubKey: PKOLChar; - var phkResult: HKEY): Longint; stdcall; -function RegCreateKeyEx(hKey: HKEY; lpSubKey: PKOLChar; - Reserved: DWORD; lpClass: PKOLChar; dwOptions: DWORD; samDesired: REGSAM; - lpSecurityAttributes: PSecurityAttributes; var phkResult: HKEY; - lpdwDisposition: PDWORD): Longint; stdcall; -function RegDeleteKey(hKey: HKEY; lpSubKey: PKOLChar): Longint; stdcall; -function RegDeleteValue(hKey: HKEY; lpValueName: PKOLChar): Longint; stdcall; -function RegEnumKeyEx(hKey: HKEY; dwIndex: DWORD; lpName: PKOLChar; - var lpcbName: DWORD; lpReserved: Pointer; lpClass: PKOLChar; - lpcbClass: PDWORD; lpftLastWriteTime: PFileTime): Longint; stdcall; -function RegEnumKey(hKey: HKEY; dwIndex: DWORD; lpName: PKOLChar; cbName: DWORD): Longint; stdcall; -function RegEnumValue(hKey: HKEY; dwIndex: DWORD; lpValueName: PKOLChar; - var lpcbValueName: DWORD; lpReserved: Pointer; lpType: PDWORD; - lpData: PByte; lpcbData: PDWORD): Longint; stdcall; -function RegLoadKey(hKey: HKEY; lpSubKey, lpFile: PKOLChar): Longint; stdcall; -function RegOpenKey(hKey: HKEY; lpSubKey: PKOLChar; var phkResult: HKEY): Longint; stdcall; -function RegOpenKeyEx(hKey: HKEY; lpSubKey: PKOLChar; - ulOptions: DWORD; samDesired: REGSAM; var phkResult: HKEY): Longint; stdcall; -function RegQueryInfoKey(hKey: HKEY; lpClass: PKOLChar; - lpcbClass: PDWORD; lpReserved: Pointer; - lpcSubKeys, lpcbMaxSubKeyLen, lpcbMaxClassLen, lpcValues, - lpcbMaxValueNameLen, lpcbMaxValueLen, lpcbSecurityDescriptor: PDWORD; - lpftLastWriteTime: PFileTime): Longint; stdcall; -function RegQueryMultipleValues(hKey: HKEY; var ValList; - NumVals: DWORD; lpValueBuf: PKOLChar; var ldwTotsize: DWORD): Longint; stdcall; -function RegQueryValue(hKey: HKEY; lpSubKey: PKOLChar; - lpValue: PKOLChar; var lpcbValue: Longint): Longint; stdcall; -function RegQueryValueEx(hKey: HKEY; lpValueName: PKOLChar; - lpReserved: Pointer; lpType: PDWORD; lpData: PByte; lpcbData: PDWORD): Longint; stdcall; -function RegReplaceKey(hKey: HKEY; lpSubKey: PKOLChar; - lpNewFile: PKOLChar; lpOldFile: PKOLChar): Longint; stdcall; -function RegRestoreKey(hKey: HKEY; lpFile: PKOLChar; dwFlags: DWORD): Longint; stdcall; -function RegSaveKey(hKey: HKEY; lpFile: PKOLChar; - lpSecurityAttributes: PSecurityAttributes): Longint; stdcall; -function RegSetValue(hKey: HKEY; lpSubKey: PKOLChar; - dwType: DWORD; lpData: PKOLChar; cbData: DWORD): Longint; stdcall; -function RegSetValueEx(hKey: HKEY; lpValueName: PKOLChar; - Reserved: DWORD; dwType: DWORD; lpData: Pointer; cbData: DWORD): Longint; stdcall; -function RegUnLoadKey(hKey: HKEY; lpSubKey: PKOLChar): Longint; stdcall; -function RegisterEventSource(lpUNCServerName, lpSourceName: PKOLChar): THandle; stdcall; -function ReportEvent(hEventLog: THandle; wType, wCategory: Word; - dwEventID: DWORD; lpUserSid: Pointer; wNumStrings: Word; - dwDataSize: DWORD; lpStrings, lpRawData: Pointer): BOOL; stdcall; -function SetFileSecurity(lpFileName: PKOLChar; SecurityInformation: SECURITY_INFORMATION; - pSecurityDescriptor: PSecurityDescriptor): BOOL; stdcall; -function AddAtom(lpString: PKOLChar): ATOM; stdcall; -function BeginUpdateResource(pFileName: PKOLChar; bDeleteExistingResources: BOOL): THandle; stdcall; -function BuildCommDCB(lpDef: PKOLChar; var lpDCB: TDCB): BOOL; stdcall; -function BuildCommDCBAndTimeouts(lpDef: PKOLChar; var lpDCB: TDCB; - var lpCommTimeouts: TCommTimeouts): BOOL; stdcall; -function CallNamedPipe(lpNamedPipeName: PKOLChar; lpInBuffer: Pointer; - nInBufferSize: DWORD; lpOutBuffer: Pointer; nOutBufferSize: DWORD; - var lpBytesRead: DWORD; nTimeOut: DWORD): BOOL; stdcall; -function CommConfigDialog(lpszName: PKOLChar; hWnd: HWND; var lpCC: TCommConfig): BOOL; stdcall; -function CompareString(Locale: LCID; dwCmpFlags: DWORD; lpString1: PKOLChar; - cchCount1: Integer; lpString2: PKOLChar; cchCount2: Integer): Integer; stdcall; -function CopyFile(lpExistingFileName, lpNewFileName: PKOLChar; bFailIfExists: BOOL): BOOL; stdcall; -{$IFDEF _D3orHigher} -function CopyFileEx(lpExistingFileName, lpNewFileName: PKOLChar; - lpProgressRoutine: TFNProgressRoutine; lpData: Pointer; pbCancel: PBool; - dwCopyFlags: DWORD): BOOL; stdcall; -{$ENDIF _D3orHigher} -function CreateDirectory(lpPathName: PKOLChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; stdcall; -function CreateDirectoryEx(lpTemplateDirectory, lpNewDirectory: PKOLChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; stdcall; -function CreateEvent(lpEventAttributes: PSecurityAttributes; - bManualReset, bInitialState: BOOL; lpName: PKOLChar): THandle; stdcall; -function CreateFile(lpFileName: PKOLChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; stdcall; -function CreateFileMapping(hFile: THandle; lpFileMappingAttributes: PSecurityAttributes; - flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD; lpName: PKOLChar): THandle; stdcall; -function CreateHardLink(lpFileName, lpExistingFileName: PKOLChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; stdcall; -function CreateMailslot(lpName: PKOLChar; nMaxMessageSize: DWORD; - lReadTimeout: DWORD; lpSecurityAttributes: PSecurityAttributes): THandle; stdcall; -function CreateNamedPipe(lpName: PKOLChar; - dwOpenMode, dwPipeMode, nMaxInstances, nOutBufferSize, nInBufferSize, nDefaultTimeOut: DWORD; - lpSecurityAttributes: PSecurityAttributes): THandle; stdcall; -function CreateProcess(lpApplicationName: PKOLChar; lpCommandLine: PKOLChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PKOLChar; const lpStartupInfo: TStartupInfo; - var lpProcessInformation: TProcessInformation): BOOL; stdcall; -function CreateSemaphore(lpSemaphoreAttributes: PSecurityAttributes; - lInitialCount, lMaximumCount: Longint; lpName: PKOLChar): THandle; stdcall; -function CreateWaitableTimer(lpTimerAttributes: PSecurityAttributes; bManualReset: BOOL; lpTimerName: PKOLChar): THandle; stdcall; -function DefineDosDevice(dwFlags: DWORD; lpDeviceName, lpTargetPath: PKOLChar): BOOL; stdcall; -function DeleteFile(lpFileName: PKOLChar): BOOL; stdcall; -function EndUpdateResource(hUpdate: THandle; fDiscard: BOOL): BOOL; stdcall; -function EnumCalendarInfo(lpCalInfoEnumProc: TFNCalInfoEnumProc; Locale: LCID; - Calendar: CALID; CalType: CALTYPE): BOOL; stdcall; -function EnumDateFormats(lpDateFmtEnumProc: TFNDateFmtEnumProc; - Locale: LCID; dwFlags: DWORD): BOOL; stdcall; -function EnumResourceLanguages(hModule: HMODULE; lpType, lpName: PKOLChar; - lpEnumFunc: ENUMRESLANGPROC; lParam: Longint): BOOL; stdcall; -function EnumResourceNames(hModule: HMODULE; lpType: PKOLChar; - lpEnumFunc: ENUMRESNAMEPROC; lParam: Longint): BOOL; stdcall; -function EnumResourceTypes(hModule: HMODULE; lpEnumFunc: ENUMRESTYPEPROC; - lParam: Longint): BOOL; stdcall; -function EnumSystemCodePages(lpCodePageEnumProc: TFNCodepageEnumProc; dwFlags: DWORD): BOOL; stdcall; -function EnumSystemLocales(lpLocaleEnumProc: TFNLocaleEnumProc; dwFlags: DWORD): BOOL; stdcall; -function EnumTimeFormats(lpTimeFmtEnumProc: TFNTimeFmtEnumProc; - Locale: LCID; dwFlags: DWORD): BOOL; stdcall; -function ExpandEnvironmentStrings(lpSrc: PKOLChar; lpDst: PKOLChar; nSize: DWORD): DWORD; stdcall; -procedure FatalAppExit(uAction: UINT; lpMessageText: PKOLChar); stdcall; -function FillConsoleOutputCharacter(hConsoleOutput: THandle; cCharacter: KOLChar; - nLength: DWORD; dwWriteCoord: TCoord; var lpNumberOfCharsWritten: DWORD): BOOL; stdcall; -function FindAtom(lpString: PKOLChar): ATOM; stdcall; -function FindFirstChangeNotification(lpPathName: PKOLChar; - bWatchSubtree: BOOL; dwNotifyFilter: DWORD): THandle; stdcall; -function FindFirstFile(lpFileName: PKOLChar; var lpFindFileData: TWIN32FindData): THandle; stdcall; -{$IFDEF _D3orHigher} -function FindFirstFileEx(lpFileName: PKOLChar; fInfoLevelId: TFindexInfoLevels; - lpFindFileData: Pointer; fSearchOp: TFindexSearchOps; lpSearchFilter: Pointer; - dwAdditionalFlags: DWORD): BOOL; stdcall; -{$ENDIF _D3orHigher} -function FindNextFile(hFindFile: THandle; var lpFindFileData: TWIN32FindData): BOOL; stdcall; -function FindResource(hModule: HMODULE; lpName, lpType: PKOLChar): HRSRC; stdcall; -function FindResourceEx(hModule: HMODULE; lpType, lpName: PKOLChar; wLanguage: Word): HRSRC; stdcall; -function FoldString(dwMapFlags: DWORD; lpSrcStr: PKOLChar; cchSrc: Integer; - lpDestStr: PKOLChar; cchDest: Integer): Integer; stdcall; -function FormatMessage(dwFlags: DWORD; lpSource: Pointer; dwMessageId: DWORD; dwLanguageId: DWORD; - lpBuffer: PKOLChar; nSize: DWORD; Arguments: Pointer): DWORD; stdcall; -function FreeEnvironmentStrings(EnvBlock: PKOLChar): BOOL; stdcall; -function GetAtomName(nAtom: ATOM; lpBuffer: PKOLChar; nSize: Integer): UINT; stdcall; -function GetBinaryType(lpApplicationName: PKOLChar; var lpBinaryType: DWORD): BOOL; stdcall; -function GetCommandLine: PKOLChar; stdcall; -function GetCompressedFileSize(lpFileName: PKOLChar; lpFileSizeHigh: PDWORD): DWORD; stdcall; -function GetComputerName(lpBuffer: PKOLChar; var nSize: DWORD): BOOL; stdcall; -function GetConsoleTitle(lpConsoleTitle: PKOLChar; nSize: DWORD): DWORD; stdcall; -function GetCurrencyFormat(Locale: LCID; dwFlags: DWORD; lpValue: PKOLChar; - lpFormat: PCurrencyFmt; lpCurrencyStr: PKOLChar; cchCurrency: Integer): Integer; stdcall; -function GetCurrentDirectory(nBufferLength: DWORD; lpBuffer: PKOLChar): DWORD; stdcall; -function GetDateFormat(Locale: LCID; dwFlags: DWORD; lpDate: PSystemTime; - lpFormat: PKOLChar; lpDateStr: PKOLChar; cchDate: Integer): Integer; stdcall; -function GetDefaultCommConfig(lpszName: PKOLChar; - var lpCC: TCommConfig; var lpdwSize: DWORD): BOOL; stdcall; -function GetDiskFreeSpace(lpRootPathName: PKOLChar; - var lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; stdcall; -function GetDiskFreeSpaceEx(lpDirectoryName: PKOLChar; - var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes; lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall; -function GetDriveType(lpRootPathName: PKOLChar): UINT; stdcall; -function GetEnvironmentStrings: PKOLChar; stdcall; -function GetEnvironmentVariable(lpName: PKOLChar; lpBuffer: PKOLChar; nSize: DWORD): DWORD; stdcall; //overload; -function GetFileAttributes(lpFileName: PKOLChar): DWORD; stdcall; -{$IFDEF _D3orHigher} -function GetFileAttributesEx(lpFileName: PKOLChar; - fInfoLevelId: TGetFileExInfoLevels; lpFileInformation: Pointer): BOOL; stdcall; -{$ENDIF _D3orHigher} -function GetFullPathName(lpFileName: PKOLChar; nBufferLength: DWORD; - lpBuffer: PKOLChar; var lpFilePart: PKOLChar): DWORD; stdcall; -function GetLocaleInfo(Locale: LCID; LCType: LCTYPE; lpLCData: PKOLChar; cchData: Integer): Integer; stdcall; -function GetLogicalDriveStrings(nBufferLength: DWORD; lpBuffer: PKOLChar): DWORD; stdcall; -function GetModuleFileName(hModule: HINST; lpFilename: PKOLChar; nSize: DWORD): DWORD; stdcall; -function GetModuleHandle(lpModuleName: PKOLChar): HMODULE; stdcall; -function GetNamedPipeHandleState(hNamedPipe: THandle; - lpState, lpCurInstances, lpMaxCollectionCount, lpCollectDataTimeout: PDWORD; - lpUserName: PKOLChar; nMaxUserNameSize: DWORD): BOOL; stdcall; -function GetNumberFormat(Locale: LCID; dwFlags: DWORD; lpValue: PKOLChar; - lpFormat: PNumberFmt; lpNumberStr: PKOLChar; cchNumber: Integer): Integer; stdcall; -function GetPrivateProfileInt(lpAppName, lpKeyName: PKOLChar; nDefault: Integer; lpFileName: PKOLChar): UINT; stdcall; -function GetPrivateProfileSection(lpAppName: PKOLChar; lpReturnedString: PKOLChar; nSize: DWORD; lpFileName: PKOLChar): DWORD; stdcall; -function GetPrivateProfileSectionNames(lpszReturnBuffer: PKOLChar; nSize: DWORD; lpFileName: PKOLChar): DWORD; stdcall; -function GetPrivateProfileString(lpAppName, lpKeyName, lpDefault: PKOLChar; - lpReturnedString: PKOLChar; nSize: DWORD; lpFileName: PKOLChar): DWORD; stdcall; -function GetProfileInt(lpAppName, lpKeyName: PKOLChar; nDefault: Integer): UINT; stdcall; -function GetProfileSection(lpAppName: PKOLChar; lpReturnedString: PKOLChar; nSize: DWORD): DWORD; stdcall; -function GetProfileString(lpAppName, lpKeyName, lpDefault: PKOLChar; - lpReturnedString: PKOLChar; nSize: DWORD): DWORD; stdcall; -function GetShortPathName(lpszLongPath: PKOLChar; lpszShortPath: PKOLChar; - cchBuffer: DWORD): DWORD; stdcall; -procedure GetStartupInfo(var lpStartupInfo: TStartupInfo); stdcall; -function GetStringTypeEx(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PKOLChar; cchSrc: Integer; var lpCharType): BOOL; stdcall; -function GetSystemDirectory(lpBuffer: PKOLChar; uSize: UINT): UINT; stdcall; -function GetTempFileName(lpPathName, lpPrefixString: PKOLChar; - uUnique: UINT; lpTempFileName: PKOLChar): UINT; stdcall; -function GetTempPath(nBufferLength: DWORD; lpBuffer: PKOLChar): DWORD; stdcall; -function GetTimeFormat(Locale: LCID; dwFlags: DWORD; lpTime: PSystemTime; - lpFormat: PKOLChar; lpTimeStr: PKOLChar; cchTime: Integer): Integer; stdcall; -function GetVersionEx(var lpVersionInformation: TOSVersionInfo): BOOL; stdcall; -function GetVolumeInformation(lpRootPathName: PKOLChar; - lpVolumeNameBuffer: PKOLChar; nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; - lpFileSystemNameBuffer: PKOLChar; nFileSystemNameSize: DWORD): BOOL; stdcall; -function GetWindowsDirectory(lpBuffer: PKOLChar; uSize: UINT): UINT; stdcall; -function GlobalAddAtom(lpString: PKOLChar): ATOM; stdcall; -function GlobalFindAtom(lpString: PKOLChar): ATOM; stdcall; -function GlobalGetAtomName(nAtom: ATOM; lpBuffer: PKOLChar; nSize: Integer): UINT; stdcall; -function IsBadStringPtr(lpsz: PKOLChar; ucchMax: UINT): BOOL; stdcall; -function LCMapString(Locale: LCID; dwMapFlags: DWORD; lpSrcStr: PKOLChar; - cchSrc: Integer; lpDestStr: PKOLChar; cchDest: Integer): Integer; stdcall; -function LoadLibrary(lpLibFileName: PKOLChar): HMODULE; stdcall; -function LoadLibraryEx(lpLibFileName: PKOLChar; hFile: THandle; dwFlags: DWORD): HMODULE; stdcall; -function MoveFile(lpExistingFileName, lpNewFileName: PKOLChar): BOOL; stdcall; -function MoveFileEx(lpExistingFileName, lpNewFileName: PKOLChar; dwFlags: DWORD): BOOL; stdcall; -{$IFDEF _D3orHigher} -function MoveFileWithProgress(lpExistingFileName, lpNewFileName: PKOLChar; lpProgressRoutine: TFNProgressRoutine; - lpData: Pointer; dwFlags: DWORD): BOOL; stdcall; -{$ENDIF _D3orHigher} -function OpenEvent(dwDesiredAccess: DWORD; bInheritHandle: BOOL; lpName: PKOLChar): THandle; stdcall; -function OpenFileMapping(dwDesiredAccess: DWORD; bInheritHandle: BOOL; lpName: PKOLChar): THandle; stdcall; -function OpenMutex(dwDesiredAccess: DWORD; bInheritHandle: BOOL; lpName: PKOLChar): THandle; stdcall; -function OpenSemaphore(dwDesiredAccess: DWORD; bInheritHandle: BOOL; lpName: PKOLChar): THandle; stdcall; -function OpenWaitableTimer(dwDesiredAccess: DWORD; bInheritHandle: BOOL; - lpTimerName: PKOLChar): THandle; stdcall; -procedure OutputDebugString(lpOutputString: PKOLChar); stdcall; -function PeekConsoleInput(hConsoleInput: THandle; var lpBuffer: TInputRecord; - nLength: DWORD; var lpNumberOfEventsRead: DWORD): BOOL; stdcall; -function QueryDosDevice(lpDeviceName: PKOLChar; lpTargetPath: PKOLChar; ucchMax: DWORD): DWORD; stdcall; -function QueryRecoveryAgents(p1: PKOLChar; var p2: Pointer; var p3: TRecoveryAgentInformation): DWORD; stdcall; -function ReadConsole(hConsoleInput: THandle; lpBuffer: Pointer; - nNumberOfCharsToRead: DWORD; var lpNumberOfCharsRead: DWORD; lpReserved: Pointer): BOOL; stdcall; -function ReadConsoleInput(hConsoleInput: THandle; var lpBuffer: TInputRecord; - nLength: DWORD; var lpNumberOfEventsRead: DWORD): BOOL; stdcall; -function ReadConsoleOutput(hConsoleOutput: THandle; lpBuffer: Pointer; - dwBufferSize, dwBufferCoord: TCoord; var lpReadRegion: TSmallRect): BOOL; stdcall; -function ReadConsoleOutputCharacter(hConsoleOutput: THandle; lpCharacter: PKOLChar; - nLength: DWORD; dwReadCoord: TCoord; var lpNumberOfCharsRead: DWORD): BOOL; stdcall; -function RemoveDirectory(lpPathName: PKOLChar): BOOL; stdcall; -function ScrollConsoleScreenBuffer(hConsoleOutput: THandle; - const lpScrollRectangle: TSmallRect; lpClipRectangle: PSmallRect; - dwDestinationOrigin: TCoord; var lpFill: TCharInfo): BOOL; stdcall; -function SearchPath(lpPath, lpFileName, lpExtension: PKOLChar; - nBufferLength: DWORD; lpBuffer: PKOLChar; var lpFilePart: PKOLChar): DWORD; stdcall; -function SetComputerName(lpComputerName: PKOLChar): BOOL; stdcall; -function SetConsoleTitle(lpConsoleTitle: PKOLChar): BOOL; stdcall; -function SetCurrentDirectory(lpPathName: PKOLChar): BOOL; stdcall; -function SetDefaultCommConfig(lpszName: PKOLChar; lpCC: PCommConfig; dwSize: DWORD): BOOL; stdcall; -function SetEnvironmentVariable(lpName, lpValue: PKOLChar): BOOL; stdcall; -function SetFileAttributes(lpFileName: PKOLChar; dwFileAttributes: DWORD): BOOL; stdcall; -function SetLocaleInfo(Locale: LCID; LCType: LCTYPE; lpLCData: PKOLChar): BOOL; stdcall; -function SetVolumeLabel(lpRootPathName: PKOLChar; lpVolumeName: PKOLChar): BOOL; stdcall; -function UpdateResource(hUpdate: THandle; lpType, lpName: PKOLChar; - wLanguage: Word; lpData: Pointer; cbData: DWORD): BOOL; stdcall; -function VerLanguageName(wLang: DWORD; szLang: PKOLChar; nSize: DWORD): DWORD; stdcall; -function WaitNamedPipe(lpNamedPipeName: PKOLChar; nTimeOut: DWORD): BOOL; stdcall; -function WriteConsole(hConsoleOutput: THandle; const lpBuffer: Pointer; - nNumberOfCharsToWrite: DWORD; var lpNumberOfCharsWritten: DWORD; lpReserved: Pointer): BOOL; stdcall; -function WriteConsoleInput(hConsoleInput: THandle; const lpBuffer: TInputRecord; - nLength: DWORD; var lpNumberOfEventsWritten: DWORD): BOOL; stdcall; -function WriteConsoleOutput(hConsoleOutput: THandle; lpBuffer: Pointer; - dwBufferSize, dwBufferCoord: TCoord; var lpWriteRegion: TSmallRect): BOOL; stdcall; -function WriteConsoleOutputCharacter(hConsoleOutput: THandle;lpCharacter: PKOLChar; - nLength: DWORD; dwWriteCoord: TCoord; var lpNumberOfCharsWritten: DWORD): BOOL; stdcall; -function WritePrivateProfileSection(lpAppName, lpString, lpFileName: PKOLChar): BOOL; stdcall; -function WritePrivateProfileString(lpAppName, lpKeyName, lpString, lpFileName: PKOLChar): BOOL; stdcall; -function WriteProfileSection(lpAppName, lpString: PKOLChar): BOOL; stdcall; -function WriteProfileString(lpAppName, lpKeyName, lpString: PKOLChar): BOOL; stdcall; -function lstrcat(lpString1, lpString2: PKOLChar): PKOLChar; stdcall; -function lstrcmp(lpString1, lpString2: PKOLChar): Integer; stdcall; -function lstrcmpi(lpString1, lpString2: PKOLChar): Integer; stdcall; -function lstrcpy(lpString1, lpString2: PKOLChar): PKOLChar; stdcall; -function lstrcpyn(lpString1, lpString2: PKOLChar; iMaxLength: Integer): PKOLChar; stdcall; -function lstrlen(lpString: PKOLChar): Integer; stdcall; -function MultinetGetConnectionPerformance(lpNetResource: PNetResource; - lpNetConnectInfoStruc: PNetConnectInfoStruct): DWORD; stdcall; -function WNetAddConnection2(var lpNetResource: TNetResource; - lpPassword, lpUserName: PKOLChar; dwFlags: DWORD): DWORD; stdcall; -function WNetAddConnection3(hwndOwner: HWND; var lpNetResource: TNetResource; - lpPassword, lpUserName: PKOLChar; dwFlags: DWORD): DWORD; stdcall; -function WNetAddConnection(lpRemoteName, lpPassword, lpLocalName: PKOLChar): DWORD; stdcall; -function WNetCancelConnection2(lpName: PKOLChar; dwFlags: DWORD; fForce: BOOL): DWORD; stdcall; -function WNetCancelConnection(lpName: PKOLChar; fForce: BOOL): DWORD; stdcall; -function WNetConnectionDialog1(var lpConnDlgStruct: TConnectDlgStruct): DWORD; stdcall; -function WNetDisconnectDialog1(var lpConnDlgStruct: TDiscDlgStruct): DWORD; stdcall; -function WNetEnumResource(hEnum: THandle; var lpcCount: DWORD; - lpBuffer: Pointer; var lpBufferSize: DWORD): DWORD; stdcall; -function WNetGetConnection(lpLocalName: PKOLChar; - lpRemoteName: PKOLChar; var lpnLength: DWORD): DWORD; stdcall; -function WNetGetLastError(var lpError: DWORD; lpErrorBuf: PKOLChar; - nErrorBufSize: DWORD; lpNameBuf: PKOLChar; nNameBufSize: DWORD): DWORD; stdcall; -function WNetGetNetworkInformation(lpProvider: PKOLChar; - var lpNetInfoStruct: TNetInfoStruct): DWORD; stdcall; -function WNetGetProviderName(dwNetType: DWORD; lpProviderName: PKOLChar; - var lpBufferSize: DWORD): DWORD; stdcall; -function WNetGetResourceParent(lpNetResource: PNetResource; - lpBuffer: Pointer; var cbBuffer: DWORD): DWORD; stdcall; -function WNetGetUniversalName(lpLocalPath: PKOLChar; dwInfoLevel: DWORD; - lpBuffer: Pointer; var lpBufferSize: DWORD): DWORD; stdcall; -function WNetGetUser(lpName: PKOLChar; lpUserName: PKOLChar; var lpnLength: DWORD): DWORD; stdcall; -function WNetOpenEnum(dwScope, dwType, dwUsage: DWORD; - lpNetResource: PNetResource; var lphEnum: THandle): DWORD; stdcall; -function WNetSetConnection(lpName: PKOLChar; dwProperties: DWORD; pvValues: Pointer): DWORD; stdcall; -function WNetUseConnection(hwndOwner: HWND; - var lpNetResource: TNetResource; lpUserID: PKOLChar; - lpPassword: PKOLChar; dwFlags: DWORD; lpAccessName: PKOLChar; - var lpBufferSize: DWORD; var lpResult: DWORD): DWORD; stdcall; -function GetFileVersionInfo(lptstrFilename: PKOLChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; stdcall; -function GetFileVersionInfoSize(lptstrFilename: PKOLChar; var lpdwHandle: DWORD): DWORD; stdcall; -function VerFindFile(uFlags: DWORD; szFileName, szWinDir, szAppDir, szCurDir: PKOLChar; - var lpuCurDirLen: UINT; szDestDir: PKOLChar; var lpuDestDirLen: UINT): DWORD; stdcall; -function VerInstallFile(uFlags: DWORD; - szSrcFileName, szDestFileName, szSrcDir, szDestDir, szCurDir, szTmpFile: PKOLChar; - var lpuTmpFileLen: UINT): DWORD; stdcall; -function VerQueryValue(pBlock: Pointer; lpSubBlock: PKOLChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; stdcall; -function GetPrivateProfileStruct(lpszSection, lpszKey: PKOLChar; - lpStruct: Pointer; uSizeStruct: UINT; szFile: PKOLChar): BOOL; stdcall; -function WritePrivateProfileStruct(lpszSection, lpszKey: PKOLChar; - lpStruct: Pointer; uSizeStruct: UINT; szFile: PKOLChar): BOOL; stdcall; -function AddFontResource(FileName: PKOLChar): Integer; stdcall; -function AddFontResourceEx(p1: PKOLChar; p2: DWORD; p3: PDesignVector): Integer; stdcall; -function CopyEnhMetaFile(p1: HENHMETAFILE; p2: PKOLChar): HENHMETAFILE; stdcall; -function CopyMetaFile(p1: HMETAFILE; p2: PKOLChar): HMETAFILE; stdcall; -function CreateColorSpace(var ColorSpace: TLogColorSpace): HCOLORSPACE; stdcall; -function CreateDC(lpszDriver, lpszDevice, lpszOutput: PKOLChar; - lpdvmInit: PDeviceMode): HDC; stdcall; -function CreateEnhMetaFile(DC: HDC; FileName: PKOLChar; Rect: PRect; Desc: PKOLChar): HDC; stdcall; -function CreateFont(nHeight, nWidth, nEscapement, nOrientaion, fnWeight: Integer; - fdwItalic, fdwUnderline, fdwStrikeOut, fdwCharSet, fdwOutputPrecision, - fdwClipPrecision, fdwQuality, fdwPitchAndFamily: DWORD; lpszFace: PKOLChar): HFONT; stdcall; -function CreateFontIndirect(const p1: TLogFont): HFONT; stdcall; -function CreateFontIndirectEx(const p1: PEnumLogFontExDV): HFONT; stdcall; -function CreateIC(lpszDriver, lpszDevice, lpszOutput: PKOLChar; lpdvmInit: PDeviceMode): HDC; stdcall; -function CreateMetaFile(p1: PKOLChar): HDC; stdcall; -function CreateScalableFontResource(p1: DWORD; p2, p3, p4: PKOLChar): BOOL; stdcall; -function DeviceCapabilities(pDriverName, pDeviceName, pPort: PKOLChar; - iIndex: Integer; pOutput: PKOLChar; DevMode: PDeviceMode): Integer; stdcall; -function EnumFontFamilies(DC: HDC; p2: PKOLChar; p3: TFNFontEnumProc; p4: LPARAM): BOOL; stdcall; -function EnumFontFamiliesEx(DC: HDC; var p2: TLogFont; - p3: TFNFontEnumProc; p4: LPARAM; p5: DWORD): BOOL; stdcall; -function EnumFonts(DC: HDC; lpszFace: PKOLChar; fntenmprc: TFNFontEnumProc; - lpszData: PKOLChar): Integer; stdcall; -function EnumICMProfiles(DC: HDC; ICMProc: TFNICMEnumProc; p3: LPARAM): Integer; stdcall; -function ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; - Rect: PRect; Str: PKOLChar; Count: Longint; Dx: PInteger): BOOL; stdcall; -function GetCharABCWidths(DC: HDC; FirstChar, LastChar: UINT; const ABCStructs): BOOL; stdcall; -function GetCharABCWidthsFloat(DC: HDC; FirstChar, LastChar: UINT; const ABCFloatSturcts): BOOL; stdcall; -function GetCharWidth32(DC: HDC; FirstChar, LastChar: UINT; const Widths): BOOL; stdcall; -function GetCharWidth(DC: HDC; FirstChar, LastChar: UINT; const Widths): BOOL; stdcall; -function GetCharWidthFloat(DC: HDC; FirstChar, LastChar: UINT; const Widths): BOOL; stdcall; -function GetCharacterPlacement(DC: HDC; p2: PKOLChar; p3, p4: BOOL; - var p5: TGCPResults; p6: DWORD): DWORD; stdcall; -function GetEnhMetaFile(p1: PKOLChar): HENHMETAFILE; stdcall; -function GetEnhMetaFileDescription(p1: HENHMETAFILE; p2: UINT; p3: PKOLChar): UINT; stdcall; -function GetGlyphIndices(DC: HDC; p2: PKOLChar; p3: Integer; p4: PWORD; p5: DWORD): DWORD; stdcall; -function GetGlyphOutline(DC: HDC; uChar, uFormat: UINT; - const lpgm: TGlyphMetrics; cbBuffer: DWORD; lpvBuffer: Pointer; const lpmat2: TMat2): DWORD; stdcall; -function GetICMProfile(DC: HDC; var Size: DWORD; Name: PKOLChar): BOOL; stdcall; -function GetLogColorSpace(p1: HCOLORSPACE; var ColorSpace: TLogColorSpace; Size: DWORD): BOOL; stdcall; -function GetMetaFile(p1: PKOLChar): HMETAFILE; stdcall; -function GetObject(p1: HGDIOBJ; p2: Integer; p3: Pointer): Integer; stdcall; -function GetOutlineTextMetrics(DC: HDC; p2: UINT; OTMetricStructs: Pointer): UINT; stdcall; -function GetTextExtentExPoint(DC: HDC; p2: PKOLChar; - p3, p4: Integer; p5, p6: PInteger; var p7: TSize): BOOL; stdcall; -function GetTextExtentPoint32(DC: HDC; Str: PKOLChar; Count: Integer; - var Size: TSize): BOOL; stdcall; -function GetTextExtentPoint(DC: HDC; Str: PKOLChar; Count: Integer; - var Size: TSize): BOOL; stdcall; -function GetTextFace(DC: HDC; Count: Integer; Buffer: PKOLChar): Integer; stdcall; -function GetTextMetrics(DC: HDC; var TM: TTextMetric): BOOL; stdcall; -function PolyTextOut(DC: HDC; const PolyTextArray; Strings: Integer): BOOL; stdcall; -function RemoveFontResource(FileName: PKOLChar): BOOL; stdcall; -function RemoveFontResourceEx(p1: PKOLChar; p2: DWORD; p3: PDesignVector): BOOL; stdcall; -function ResetDC(DC: HDC; const InitData: TDeviceMode): HDC; stdcall; -function SetICMProfile(DC: HDC; Name: PKOLChar): BOOL; stdcall; -function StartDoc(DC: HDC; const p2: TDocInfo): Integer; stdcall; -function TextOut(DC: HDC; X, Y: Integer; Str: PKOLChar; Count: Integer): BOOL; stdcall; -function UpdateICMRegKey(p1: DWORD; p2, p3: PKOLChar; p4: UINT): BOOL; stdcall; -function wglUseFontBitmaps(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; -function wglUseFontOutlines(p1: HDC; p2, p3, p4: DWORD; - p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; -function AnsiToOem(const lpszSrc: LPCSTR; lpszDst: LPSTR): BOOL; stdcall; -function AnsiToOemBuff(lpszSrc: LPCSTR; lpszDst: LPSTR; cchDstLength: DWORD): BOOL; stdcall; -function AnsiUpper(lpsz: LPSTR): LPSTR; stdcall; -function AnsiUpperBuff(lpsz: LPSTR; cchLength: DWORD): DWORD; stdcall; -function AnsiLower(lpsz: LPSTR): LPSTR; stdcall; -function AnsiLowerBuff(lpsz: LPSTR; cchLength: DWORD): DWORD; stdcall; -function AnsiNext(const lpsz: LPCSTR): LPSTR; stdcall; -function AnsiPrev(const lpszStart: LPCSTR; const lpszCurrent: LPCSTR): LPSTR; stdcall; -function AppendMenu(hMenu: HMENU; uFlags, uIDNewItem: UINT; - lpNewItem: PKOLChar): BOOL; stdcall; -//function BroadcastSystemMessage(Flags: DWORD; Recipients: PDWORD; -// uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall; -//function BroadcastSystemMessageW(Flags: DWORD; Recipients: PDWORD; -// uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall; -function CallMsgFilter(var lpMsg: TMsg; nCode: Integer): BOOL; stdcall; -function CallWindowProc(lpPrevWndFunc: TFNWndProc; hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function ChangeDisplaySettings(var lpDevMode: TDeviceMode; dwFlags: DWORD): Longint; stdcall; -function ChangeDisplaySettingsEx(lpszDeviceName: PKOLChar; var lpDevMode: TDeviceMode; - wnd: HWND; dwFlags: DWORD; lParam: Pointer): Longint; stdcall; -function ChangeMenu(hMenu: HMENU; cmd: UINT; lpszNewItem: PKOLChar; - cmdInsert: UINT; flags: UINT): BOOL; stdcall; -function CharLower(lpsz: PKOLChar): PKOLChar; stdcall; -function CharLowerBuff(lpsz: PKOLChar; cchLength: DWORD): DWORD; stdcall; -function CharNext(lpsz: PKOLChar): PKOLChar; stdcall; -function CharNextEx(CodePage: Word; lpCurrentChar: LPCSTR; dwFlags: DWORD): LPSTR; stdcall; -function CharPrev(lpszStart: PKOLChar; lpszCurrent: PKOLChar): PKOLChar; stdcall; -function CharPrevEx(CodePage: Word; lpStart, lpCurrentChar: LPCSTR; dwFlags: DWORD): LPSTR; stdcall; -function CharToOem(lpszSrc: PKOLChar; lpszDst: PKOLChar): BOOL; stdcall; -function CharToOemBuff(lpszSrc: PKOLChar; lpszDst: PKOLChar; cchDstLength: DWORD): BOOL; stdcall; -function CharUpper(lpsz: PKOLChar): PKOLChar; stdcall; -function CharUpperBuff(lpsz: PKOLChar; cchLength: DWORD): DWORD; stdcall; -function CopyAcceleratorTable(hAccelSrc: HACCEL; var lpAccelDst; cAccelEntries: Integer): Integer; stdcall; -function CreateAcceleratorTable(var Accel; Count: Integer): HACCEL; stdcall; -function CreateDesktop(lpszDesktop, lpszDevice: PKOLChar; - pDevmode: PDeviceMode; dwFlags: DWORD; dwDesiredAccess: - DWORD; lpsa: PSecurityAttributes): HDESK; stdcall; -function CreateDialogIndirectParam(hInstance: HINST; const lpTemplate: TDlgTemplate; - hWndParent: HWND; lpDialogFunc: TFNDlgProc; dwInitParam: LPARAM): HWND; stdcall; -function CreateDialogParam(hInstance: HINST; lpTemplateName: PKOLChar; - hWndParent: HWND; lpDialogFunc: TFNDlgProc; dwInitParam: LPARAM): HWND; stdcall; -function CreateMDIWindow(lpClassName, lpWindowName: PKOLChar; - dwStyle: DWORD; X, Y, nWidth, nHeight: Integer; - hWndParent: HWND; hInstance: HINST; lParam: LPARAM): HWND; stdcall; -function CreateWindowEx(dwExStyle: DWORD; lpClassName: PKOLChar; - lpWindowName: PKOLChar; dwStyle: DWORD; X, Y, nWidth, nHeight: Integer; - hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: Pointer): HWND; stdcall; -function CreateWindowStation(lpwinsta: PKOLChar; dwReserved, dwDesiredAccess: DWORD; - lpsa: PSecurityAttributes): HWINSTA; stdcall; -function DefDlgProc(hDlg: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function DefFrameProc(hWnd, hWndMDIClient: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function DefMDIChildProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function DefWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function DialogBoxIndirectParam(hInstance: HINST; const lpDialogTemplate: TDlgTemplate; - hWndParent: HWND; lpDialogFunc: TFNDlgProc; dwInitParam: LPARAM): Integer; stdcall; -function DialogBoxParam(hInstance: HINST; lpTemplateName: PKOLChar; - hWndParent: HWND; lpDialogFunc: TFNDlgProc; dwInitParam: LPARAM): Integer; stdcall; -function DispatchMessage(const lpMsg: TMsg): Longint; stdcall; -function DlgDirList(hDlg: HWND; lpPathSpec: PKOLChar; - nIDListBox, nIDStaticPath: Integer; uFileType: UINT): Integer; stdcall; -function DlgDirListComboBox(hDlg: HWND; lpPathSpec: PKOLChar; - nIDComboBox, nIDStaticPath: Integer; uFiletype: UINT): Integer; stdcall; -function DlgDirSelectComboBoxEx(hDlg: HWND; lpString: PKOLChar; - nCount, nIDComboBox: Integer): BOOL; stdcall; -function DlgDirSelectEx(hDlg: HWND; lpString: PKOLChar; nCount, nIDListBox: Integer): BOOL; stdcall; -function DrawState(DC: HDC; Brush: HBRUSH; CBFunc: TFNDrawStateProc; - lData: LPARAM; wData: WPARAM; x, y, cx, cy: Integer; Flags: UINT): BOOL; stdcall; -function DrawText(hDC: HDC; lpString: PKOLChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; stdcall; -function DrawTextEx(DC: HDC; lpchText: PKOLChar; cchText: Integer; var p4: TRect; - dwDTFormat: UINT; DTParams: PDrawTextParams): Integer; stdcall; -function EnumDesktops(hwinsta: HWINSTA; lpEnumFunc: TFNDeskTopEnumProc; lParam: LPARAM): BOOL; stdcall; -function EnumDisplaySettings(lpszDeviceName: PKOLChar; iModeNum: DWORD; - var lpDevMode: TDeviceMode): BOOL; stdcall; -function EnumDisplayDevices(Unused: Pointer; iDevNum: DWORD; - var lpDisplayDevice: TDisplayDevice; dwFlags: DWORD): BOOL; stdcall; -function EnumProps(hWnd: HWND; lpEnumFunc: TFNPropEnumProc): Integer; stdcall; -function EnumPropsEx(hWnd: HWND; lpEnumFunc: TFNPropEnumProcEx; lParam: LPARAM): Integer; stdcall; -function EnumWindowStations(lpEnumFunc: TFNWinStaEnumProc; lParam: LPARAM): BOOL; stdcall; -function FindWindow(lpClassName, lpWindowName: PKOLChar): HWND; stdcall; -function FindWindowEx(Parent, Child: HWND; ClassName, WindowName: PKOLChar): HWND; stdcall; -function GetAltTabInfo(hwnd: HWND; iItem: Integer; var pati: TAltTabInfo; - pszItemText: PKOLChar; cchItemText: UINT): BOOL; stdcall; -function GetClassInfo(hInstance: HINST; lpClassName: PKOLChar; - var lpWndClass: TWndClass): BOOL; stdcall; -function GetClassInfoEx(Instance: HINST; Classname: PKOLChar; var WndClass: TWndClassEx): BOOL; stdcall; -function GetClassLong(hWnd: HWND; nIndex: Integer): DWORD; stdcall; -function GetClassName(hWnd: HWND; lpClassName: PKOLChar; nMaxCount: Integer): Integer; stdcall; -function GetClipboardFormatName(format: UINT; lpszFormatName: PKOLChar; - cchMaxCount: Integer): Integer; stdcall; -function GetDlgItemText(hDlg: HWND; nIDDlgItem: Integer; - lpString: PKOLChar; nMaxCount: Integer): UINT; stdcall; -function GetKeyNameText(lParam: Longint; lpString: PKOLChar; nSize: Integer): Integer; stdcall; -function GetKeyboardLayoutName(pwszKLID: PKOLChar): BOOL; stdcall; -function GetMenuItemInfo(p1: HMENU; p2: UINT; p3: BOOL; var p4: TMenuItemInfo): BOOL; stdcall; -function GetMenuString(hMenu: HMENU; uIDItem: UINT; lpString: PKOLChar; - nMaxCount: Integer; uFlag: UINT): Integer; stdcall; -function GetMessage(var lpMsg: TMsg; hWnd: HWND; - wMsgFilterMin, wMsgFilterMax: UINT): BOOL; stdcall; -function GetProp(hWnd: HWND; lpString: PKOLChar): THandle; stdcall; -function GetTabbedTextExtent(hDC: HDC; lpString: PKOLChar; - nCount, nTabPositions: Integer; var lpnTabStopPositions): DWORD; stdcall; -function GetUserObjectInformation(hObj: THandle; nIndex: Integer; pvInfo: Pointer; - nLength: DWORD; var lpnLengthNeeded: DWORD): BOOL; stdcall; -function GetWindowLong(hWnd: HWND; nIndex: Integer): Longint; stdcall; -function GetWindowModuleFileName(hwnd: HWND; pszFileName: PKOLChar; cchFileNameMax: UINT): UINT; stdcall; -function GetWindowText(hWnd: HWND; lpString: PKOLChar; nMaxCount: Integer): Integer; stdcall; -function GetWindowTextLength(hWnd: HWND): Integer; stdcall; -function GrayString(hDC: HDC; hBrush: HBRUSH; lpOutputFunc: TFNGrayStringProc; - lpData: LPARAM; nCount, X, Y, nWidth, nHeight: Integer): BOOL; stdcall; -function InsertMenu(hMenu: HMENU; uPosition, uFlags, uIDNewItem: UINT; - lpNewItem: PKOLChar): BOOL; stdcall; -function InsertMenuItem(p1: HMENU; p2: UINT; p3: BOOL; const p4: TMenuItemInfo): BOOL; stdcall; -function IsCharAlpha(ch: KOLChar): BOOL; stdcall; -function IsCharAlphaNumeric(ch: KOLChar): BOOL; stdcall; -function IsCharLower(ch: KOLChar): BOOL; stdcall; -function IsCharUpper(ch: KOLChar): BOOL; stdcall; -function IsDialogMessage(hDlg: HWND; var lpMsg: TMsg): BOOL; stdcall; -function LoadAccelerators(hInstance: HINST; lpTableName: PKOLChar): HACCEL; stdcall; -function LoadBitmap(hInstance: HINST; lpBitmapName: PKOLChar): HBITMAP; stdcall; -function LoadCursor(hInstance: HINST; lpCursorName: PKOLChar): HCURSOR; stdcall; -function LoadCursorFromFile(lpFileName: PKOLChar): HCURSOR; stdcall; -function LoadIcon(hInstance: HINST; lpIconName: PKOLChar): HICON; stdcall; -function LoadImage(hInst: HINST; ImageName: PKOLChar; ImageType: UINT; X, Y: Integer; Flags: UINT): THandle; stdcall; -function LoadKeyboardLayout(pwszKLID: PKOLChar; Flags: UINT): HKL; stdcall; -function LoadMenu(hInstance: HINST; lpMenuName: PKOLChar): HMENU; stdcall; -function LoadMenuIndirect(lpMenuTemplate: Pointer): HMENU; stdcall; -function LoadString(hInstance: HINST; uID: UINT; lpBuffer: PKOLChar; nBufferMax: Integer): Integer; stdcall; -function MapVirtualKey(uCode, uMapType: UINT): UINT; stdcall; -function MapVirtualKeyEx(uCode, uMapType: UINT; dwhkl: HKL): UINT; stdcall; -function MessageBox(hWnd: HWND; lpText, lpCaption: PKOLChar; uType: UINT): Integer; stdcall; -function MessageBoxEx(hWnd: HWND; lpText, lpCaption: PKOLChar; - uType: UINT; wLanguageId: Word): Integer; stdcall; -function MessageBoxIndirect(const MsgBoxParams: TMsgBoxParams): BOOL; stdcall; -function ModifyMenu(hMnu: HMENU; uPosition, uFlags, uIDNewItem: UINT; - lpNewItem: PKOLChar): BOOL; stdcall; -function OemToAnsi(const lpszSrc: LPCSTR; lpszDst: LPSTR): BOOL; stdcall; -function OemToAnsiBuff(lpszSrc: LPCSTR; lpszDst: LPSTR; cchDstLength: DWORD): BOOL; stdcall; -function OemToChar(lpszSrc: PKOLChar; lpszDst: PKOLChar): BOOL; stdcall; -function OemToCharBuff(lpszSrc: PKOLChar; lpszDst: PKOLChar; cchDstLength: DWORD): BOOL; stdcall; -function OpenDesktop(lpszDesktop: PKOLChar; dwFlags: DWORD; fInherit: BOOL; - dwDesiredAccess: DWORD): HDESK; stdcall; -function OpenWindowStation(lpszWinSta: PKOLChar; fInherit: BOOL; - dwDesiredAccess: DWORD): HWINSTA; stdcall; -function PeekMessage(var lpMsg: TMsg; hWnd: HWND; - wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): BOOL; stdcall; -function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; stdcall; -function PostThreadMessage(idThread: DWORD; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; stdcall; -function RealGetWindowClass(hwnd: HWND; pszType: PKOLChar; cchType: UINT): UINT; stdcall; -function RegisterClass(const lpWndClass: TWndClass): ATOM; stdcall; -function RegisterClassEx(const WndClass: TWndClassEx): ATOM; stdcall; -function RegisterClipboardFormat(lpszFormat: PKOLChar): UINT; stdcall; -function RegisterDeviceNotification(hRecipient: THandle; NotificationFilter: Pointer; Flags: DWORD): HDEVNOTIFY; stdcall; -function RegisterWindowMessage(lpString: PKOLChar): UINT; stdcall; -function RemoveProp(hWnd: HWND; lpString: PKOLChar): THandle; stdcall; -function SendDlgItemMessage(hDlg: HWND; nIDDlgItem: Integer; - Msg: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall; -function SendMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function SendMessageCallback(hWnd: HWND; Msg: UINT; wParam: WPARAM; - lParam: LPARAM; lpResultCallBack: TFNSendAsyncProc; dwData: DWORD): BOOL; stdcall; -function SendMessageTimeout(hWnd: HWND; Msg: UINT; wParam: WPARAM; - lParam: LPARAM; fuFlags, uTimeout: UINT; var lpdwResult: DWORD): LRESULT; stdcall; -function SendNotifyMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; - lParam: LPARAM): BOOL; stdcall; -function SetClassLong(hWnd: HWND; nIndex: Integer; dwNewLong: Longint): DWORD; stdcall; -function SetDlgItemText(hDlg: HWND; nIDDlgItem: Integer; lpString: PKOLChar): BOOL; stdcall; -function SetMenuItemInfo(p1: HMENU; p2: UINT; p3: BOOL; const p4: TMenuItemInfo): BOOL; stdcall; -function SetProp(hWnd: HWND; lpString: PKOLChar; hData: THandle): BOOL; stdcall; -function SetUserObjectInformation(hObj: THandle; nIndex: Integer; - pvInfo: Pointer; nLength: DWORD): BOOL; stdcall; -function SetWindowLong(hWnd: HWND; nIndex: Integer; dwNewLong: Longint): Longint; stdcall; -function SetWindowText(hWnd: HWND; lpString: PKOLChar): BOOL; stdcall; -function SetWindowsHook(nFilterType: Integer; pfnFilterProc: TFNHookProc): HHOOK; stdcall; -function SetWindowsHookEx(idHook: Integer; lpfn: TFNHookProc; hmod: HINST; dwThreadId: DWORD): HHOOK; stdcall; -function SystemParametersInfo(uiAction, uiParam: UINT; - pvParam: Pointer; fWinIni: UINT): BOOL; stdcall; -function TabbedTextOut(hDC: HDC; X, Y: Integer; lpString: PKOLChar; nCount, nTabPositions: Integer; - var lpnTabStopPositions; nTabOrigin: Integer): Longint; stdcall; -function TranslateAccelerator(hWnd: HWND; hAccTable: HACCEL; var lpMsg: TMsg): Integer; stdcall; -function UnregisterClass(lpClassName: PKOLChar; hInstance: HINST): BOOL; stdcall; -function VkKeyScan(ch: KOLChar): SHORT; stdcall; -function VkKeyScanEx(ch: KOLChar; dwhkl: HKL): SHORT; stdcall; -function WinHelp(hWndMain: HWND; lpszHelp: PKOLChar; uCommand: UINT; dwData: DWORD): BOOL; stdcall; -function wsprintf(Output: PKOLChar; Format: PKOLChar): Integer; stdcall; -function wvsprintf(Output: PKOLChar; Format: PKOLChar; arglist: {$IFDEF UNICODE} PAnsiChar {$ELSE} va_list {$ENDIF}): Integer; stdcall; -function CreateMutex(lpMutexAttributes: PSecurityAttributes; bInitialOwner: BOOL; lpName: PAnsiChar): THandle; - -const - IDC_ARROW = MakeIntResource(32512); - IDC_IBEAM = MakeIntResource(32513); - IDC_WAIT = MakeIntResource(32514); - IDC_CROSS = MakeIntResource(32515); - IDC_UPARROW = MakeIntResource(32516); - IDC_SIZE = MakeIntResource(32640); - IDC_ICON = MakeIntResource(32641); - IDC_SIZENWSE = MakeIntResource(32642); - IDC_SIZENESW = MakeIntResource(32643); - IDC_SIZEWE = MakeIntResource(32644); - IDC_SIZENS = MakeIntResource(32645); - IDC_SIZEALL = MakeIntResource(32646); - IDC_NO = MakeIntResource(32648); - IDC_HANDs = MakeIntResource(32649); - IDC_APPSTARTING = MakeIntResource(32650); - IDC_HELP = MakeIntResource(32651); -{$ENDIF interface_part} //////////////////////////////////////////////////////// - -{$IFDEF implementation_part} /////////////////////////////////////////////////// -function AbortSystemShutdown; external advapi32 name 'AbortSystemShutdownA'; -function AccessCheckAndAuditAlarm; external advapi32 name 'AccessCheckAndAuditAlarmA'; -{$IFDEF _D4orHigher} -function AccessCheckByTypeAndAuditAlarm; external advapi32 name 'AccessCheckByTypeAndAuditAlarmA'; -function AccessCheckByTypeResultListAndAuditAlarm; external advapi32 name 'AccessCheckByTypeResultListAndAuditAlarmA'; -{$ENDIF _D4orHigher} -function BackupEventLog; external advapi32 name 'BackupEventLogA'; -function ClearEventLog; external advapi32 name 'ClearEventLogA'; -function CreateProcessAsUser; external advapi32 name 'CreateProcessAsUserA'; -{$IFDEF _D3orHigher} -function GetCurrentHwProfile; external advapi32 name 'GetCurrentHwProfileA'; -{$ENDIF _D3orHigher} -function GetFileSecurity; external advapi32 name 'GetFileSecurityA'; -function GetUserName; external advapi32 name 'GetUserNameA'; -function InitiateSystemShutdown; external advapi32 name 'InitiateSystemShutdownA'; -function LogonUser; external advapi32 name 'LogonUserA'; -function LookupAccountName; external advapi32 name 'LookupAccountNameA'; -function LookupAccountSid; external advapi32 name 'LookupAccountSidA'; -function LookupPrivilegeDisplayName; external advapi32 name 'LookupPrivilegeDisplayNameA'; -function LookupPrivilegeName; external advapi32 name 'LookupPrivilegeNameA'; -function LookupPrivilegeValue; external advapi32 name 'LookupPrivilegeValueA'; -function ObjectCloseAuditAlarm; external advapi32 name 'ObjectCloseAuditAlarmA'; -function ObjectDeleteAuditAlarm; external advapi32 name 'ObjectDeleteAuditAlarmA'; -function ObjectOpenAuditAlarm; external advapi32 name 'ObjectOpenAuditAlarmA'; -function ObjectPrivilegeAuditAlarm; external advapi32 name 'ObjectPrivilegeAuditAlarmA'; -function OpenBackupEventLog; external advapi32 name 'OpenBackupEventLogA'; -function OpenEventLog; external advapi32 name 'OpenEventLogA'; -function PrivilegedServiceAuditAlarm; external advapi32 name 'PrivilegedServiceAuditAlarmA'; -function ReadEventLog; external advapi32 name 'ReadEventLogA'; -function RegConnectRegistry; external advapi32 name 'RegConnectRegistryA'; -function RegCreateKey; external advapi32 name 'RegCreateKeyA'; -function RegCreateKeyEx; external advapi32 name 'RegCreateKeyExA'; -function RegDeleteKey; external advapi32 name 'RegDeleteKeyA'; -function RegDeleteValue; external advapi32 name 'RegDeleteValueA'; -function RegEnumKeyEx; external advapi32 name 'RegEnumKeyExA'; -function RegEnumKey; external advapi32 name 'RegEnumKeyA'; -function RegEnumValue; external advapi32 name 'RegEnumValueA'; -function RegLoadKey; external advapi32 name 'RegLoadKeyA'; -function RegOpenKey; external advapi32 name 'RegOpenKeyA'; -function RegOpenKeyEx; external advapi32 name 'RegOpenKeyExA'; -function RegQueryInfoKey; external advapi32 name 'RegQueryInfoKeyA'; -function RegQueryMultipleValues; external advapi32 name 'RegQueryMultipleValuesA'; -function RegQueryValue; external advapi32 name 'RegQueryValueA'; -function RegQueryValueEx; external advapi32 name 'RegQueryValueExA'; -function RegReplaceKey; external advapi32 name 'RegReplaceKeyA'; -function RegRestoreKey; external advapi32 name 'RegRestoreKeyA'; -function RegSaveKey; external advapi32 name 'RegSaveKeyA'; -function RegSetValue; external advapi32 name 'RegSetValueA'; -function RegSetValueEx; external advapi32 name 'RegSetValueExA'; -function RegUnLoadKey; external advapi32 name 'RegUnLoadKeyA'; -function RegisterEventSource; external advapi32 name 'RegisterEventSourceA'; -function ReportEvent; external advapi32 name 'ReportEventA'; -function SetFileSecurity; external advapi32 name 'SetFileSecurityA'; -function AddAtom; external kernel32 name 'AddAtomA'; -function BeginUpdateResource; external kernel32 name 'BeginUpdateResourceA'; -function BuildCommDCB; external kernel32 name 'BuildCommDCBA'; -function BuildCommDCBAndTimeouts; external kernel32 name 'BuildCommDCBAndTimeoutsA'; -function CallNamedPipe; external kernel32 name 'CallNamedPipeA'; -function CommConfigDialog; external kernel32 name 'CommConfigDialogA'; -function CompareString; external kernel32 name 'CompareStringA'; -function CopyFile; external kernel32 name 'CopyFileA'; -{$IFDEF _D3orHigher} -function CopyFileEx; external kernel32 name 'CopyFileExA'; -{$ENDIF _D3orHigher} -function CreateDirectory; external kernel32 name 'CreateDirectoryA'; -function CreateDirectoryEx; external kernel32 name 'CreateDirectoryExA'; -function CreateEvent; external kernel32 name 'CreateEventA'; -function CreateFile; external kernel32 name 'CreateFileA'; -function CreateFileMapping; external kernel32 name 'CreateFileMappingA'; -function CreateHardLink; external kernel32 name 'CreateHardLinkA'; -function CreateMailslot; external kernel32 name 'CreateMailslotA'; -function CreateNamedPipe; external kernel32 name 'CreateNamedPipeA'; -function CreateProcess; external kernel32 name 'CreateProcessA'; -function CreateSemaphore; external kernel32 name 'CreateSemaphoreA'; -function CreateWaitableTimer; external kernel32 name 'CreateWaitableTimerA'; -function DefineDosDevice; external kernel32 name 'DefineDosDeviceA'; -function DeleteFile; external kernel32 name 'DeleteFileA'; -function EndUpdateResource; external kernel32 name 'EndUpdateResourceA'; -function EnumCalendarInfo; external kernel32 name 'EnumCalendarInfoA'; -function EnumDateFormats; external kernel32 name 'EnumDateFormatsA'; -function EnumResourceLanguages; external kernel32 name 'EnumResourceLanguagesA'; -function EnumResourceNames; external kernel32 name 'EnumResourceNamesA'; -function EnumResourceTypes; external kernel32 name 'EnumResourceTypesA'; -function EnumSystemCodePages; external kernel32 name 'EnumSystemCodePagesA'; -function EnumSystemLocales; external kernel32 name 'EnumSystemLocalesA'; -function EnumTimeFormats; external kernel32 name 'EnumTimeFormatsA'; -function ExpandEnvironmentStrings; external kernel32 name 'ExpandEnvironmentStringsA'; -procedure FatalAppExit; external kernel32 name 'FatalAppExitA'; -function FillConsoleOutputCharacter; external kernel32 name 'FillConsoleOutputCharacterA'; -function FindAtom; external kernel32 name 'FindAtomA'; -function FindFirstChangeNotification; external kernel32 name 'FindFirstChangeNotificationA'; -function FindFirstFile; external kernel32 name 'FindFirstFileA'; -{$IFDEF _D3orHigher} -function FindFirstFileEx; external kernel32 name 'FindFirstFileExA'; -{$ENDIF _D3orHigher} -function FindNextFile; external kernel32 name 'FindNextFileA'; -function FindResource; external kernel32 name 'FindResourceA'; -function FindResourceEx; external kernel32 name 'FindResourceExA'; -function FoldString; external kernel32 name 'FoldStringA'; -function FormatMessage; external kernel32 name 'FormatMessageA'; -function FreeEnvironmentStrings; external kernel32 name 'FreeEnvironmentStringsA'; -function GetAtomName; external kernel32 name 'GetAtomNameA'; -function GetBinaryType; external kernel32 name 'GetBinaryTypeA'; -function GetCommandLine; external kernel32 name 'GetCommandLineA'; -function GetCompressedFileSize; external kernel32 name 'GetCompressedFileSizeA'; -function GetComputerName; external kernel32 name 'GetComputerNameA'; -function GetConsoleTitle; external kernel32 name 'GetConsoleTitleA'; -function GetCurrencyFormat; external kernel32 name 'GetCurrencyFormatA'; -function GetCurrentDirectory; external kernel32 name 'GetCurrentDirectoryA'; -function GetDateFormat; external kernel32 name 'GetDateFormatA'; -function GetDefaultCommConfig; external kernel32 name 'GetDefaultCommConfigA'; -function GetDiskFreeSpace; external kernel32 name 'GetDiskFreeSpaceA'; -function GetDiskFreeSpaceEx; external kernel32 name 'GetDiskFreeSpaceExA'; -function GetDriveType; external kernel32 name 'GetDriveTypeA'; -function GetEnvironmentStrings; external kernel32 name 'GetEnvironmentStringsA'; -function GetEnvironmentVariable(lpName: PKOLChar; lpBuffer: PKOLChar; - nSize: DWORD): DWORD; external kernel32 name 'GetEnvironmentVariableA'; -function GetFileAttributes; external kernel32 name 'GetFileAttributesA'; -{$IFDEF _D3orHigher} -function GetFileAttributesEx; external kernel32 name 'GetFileAttributesExA'; -{$ENDIF _D3orHigher} -function GetFullPathName; external kernel32 name 'GetFullPathNameA'; -function GetLocaleInfo; external kernel32 name 'GetLocaleInfoA'; -function GetLogicalDriveStrings; external kernel32 name 'GetLogicalDriveStringsA'; -function GetModuleFileName; external kernel32 name 'GetModuleFileNameA'; -function GetModuleHandle; external kernel32 name 'GetModuleHandleA'; -function GetNamedPipeHandleState; external kernel32 name 'GetNamedPipeHandleStateA'; -function GetNumberFormat; external kernel32 name 'GetNumberFormatA'; -function GetPrivateProfileInt; external kernel32 name 'GetPrivateProfileIntA'; -function GetPrivateProfileSection; external kernel32 name 'GetPrivateProfileSectionA'; -function GetPrivateProfileSectionNames; external kernel32 name 'GetPrivateProfileSectionNamesA'; -function GetPrivateProfileString; external kernel32 name 'GetPrivateProfileStringA'; -function GetProfileInt; external kernel32 name 'GetProfileIntA'; -function GetProfileSection; external kernel32 name 'GetProfileSectionA'; -function GetProfileString; external kernel32 name 'GetProfileStringA'; -function GetShortPathName; external kernel32 name 'GetShortPathNameA'; -procedure GetStartupInfo; external kernel32 name 'GetStartupInfoA'; -function GetStringTypeEx; external kernel32 name 'GetStringTypeExA'; -function GetSystemDirectory; external kernel32 name 'GetSystemDirectoryA'; -function GetTempFileName; external kernel32 name 'GetTempFileNameA'; -function GetTempPath; external kernel32 name 'GetTempPathA'; -function GetTimeFormat; external kernel32 name 'GetTimeFormatA'; -function GetVersionEx; external kernel32 name 'GetVersionExA'; -function GetVolumeInformation; external kernel32 name 'GetVolumeInformationA'; -function GetWindowsDirectory; external kernel32 name 'GetWindowsDirectoryA'; -function GlobalAddAtom; external kernel32 name 'GlobalAddAtomA'; -function GlobalFindAtom; external kernel32 name 'GlobalFindAtomA'; -function GlobalGetAtomName; external kernel32 name 'GlobalGetAtomNameA'; -function IsBadStringPtr; external kernel32 name 'IsBadStringPtrA'; -function LCMapString; external kernel32 name 'LCMapStringA'; -function LoadLibrary; external kernel32 name 'LoadLibraryA'; -function LoadLibraryEx; external kernel32 name 'LoadLibraryExA'; -function MoveFile; external kernel32 name 'MoveFileA'; -function MoveFileEx; external kernel32 name 'MoveFileExA'; -{$IFDEF _D3orHigher} -function MoveFileWithProgress; external kernel32 name 'MoveFileWithProgressA'; -{$ENDIF _D3orHigher} -function OpenEvent; external kernel32 name 'OpenEventA'; -function OpenFileMapping; external kernel32 name 'OpenFileMappingA'; -function OpenMutex; external kernel32 name 'OpenMutexA'; -function OpenSemaphore; external kernel32 name 'OpenSemaphoreA'; -function OpenWaitableTimer; external kernel32 name 'OpenWaitableTimerA'; -procedure OutputDebugString; external kernel32 name 'OutputDebugStringA'; -function PeekConsoleInput; external kernel32 name 'PeekConsoleInputA'; -function QueryDosDevice; external kernel32 name 'QueryDosDeviceA'; -function QueryRecoveryAgents; external kernel32 name 'QueryRecoveryAgentsA'; -function ReadConsole; external kernel32 name 'ReadConsoleA'; -function ReadConsoleInput; external kernel32 name 'ReadConsoleInputA'; -function ReadConsoleOutput; external kernel32 name 'ReadConsoleOutputA'; -function ReadConsoleOutputCharacter; external kernel32 name 'ReadConsoleOutputCharacterA'; -function RemoveDirectory; external kernel32 name 'RemoveDirectoryA'; -function ScrollConsoleScreenBuffer; external kernel32 name 'ScrollConsoleScreenBufferA'; -function SearchPath; external kernel32 name 'SearchPathA'; -function SetComputerName; external kernel32 name 'SetComputerNameA'; -function SetConsoleTitle; external kernel32 name 'SetConsoleTitleA'; -function SetCurrentDirectory; external kernel32 name 'SetCurrentDirectoryA'; -function SetDefaultCommConfig; external kernel32 name 'SetDefaultCommConfigA'; -function SetEnvironmentVariable; external kernel32 name 'SetEnvironmentVariableA'; -function SetFileAttributes; external kernel32 name 'SetFileAttributesA'; -function SetLocaleInfo; external kernel32 name 'SetLocaleInfoA'; -function SetVolumeLabel; external kernel32 name 'SetVolumeLabelA'; -function UpdateResource; external kernel32 name 'UpdateResourceA'; -function VerLanguageName; external kernel32 name 'VerLanguageNameA'; -function WaitNamedPipe; external kernel32 name 'WaitNamedPipeA'; -function WriteConsole; external kernel32 name 'WriteConsoleA'; -function WriteConsoleInput; external kernel32 name 'WriteConsoleInputA'; -function WriteConsoleOutput; external kernel32 name 'WriteConsoleOutputA'; -function WriteConsoleOutputCharacter; external kernel32 name 'WriteConsoleOutputCharacterA'; -function WritePrivateProfileSection; external kernel32 name 'WritePrivateProfileSectionA'; -function WritePrivateProfileString; external kernel32 name 'WritePrivateProfileStringA'; -function WriteProfileSection; external kernel32 name 'WriteProfileSectionA'; -function WriteProfileString; external kernel32 name 'WriteProfileStringA'; -function lstrcat; external kernel32 name 'lstrcatA'; -function lstrcmp; external kernel32 name 'lstrcmpA'; -function lstrcmpi; external kernel32 name 'lstrcmpiA'; -function lstrcpy; external kernel32 name 'lstrcpyA'; -function lstrcpyn; external kernel32 name 'lstrcpynA'; -function lstrlen; external kernel32 name 'lstrlenA'; -function MultinetGetConnectionPerformance; external mpr name 'MultinetGetConnectionPerformanceA'; -function WNetAddConnection2; external mpr name 'WNetAddConnection2A'; -function WNetAddConnection3; external mpr name 'WNetAddConnection3A'; -function WNetAddConnection; external mpr name 'WNetAddConnectionA'; -function WNetCancelConnection2; external mpr name 'WNetCancelConnection2A'; -function WNetCancelConnection; external mpr name 'WNetCancelConnectionA'; -function WNetConnectionDialog1; external mpr name 'WNetConnectionDialog1A'; -function WNetDisconnectDialog1; external mpr name 'WNetDisconnectDialog1A'; -function WNetEnumResource; external mpr name 'WNetEnumResourceA'; -function WNetGetConnection; external mpr name 'WNetGetConnectionA'; -function WNetGetLastError; external mpr name 'WNetGetLastErrorA'; -function WNetGetNetworkInformation; external mpr name 'WNetGetNetworkInformationA'; -function WNetGetProviderName; external mpr name 'WNetGetProviderNameA'; -function WNetGetResourceParent; external mpr name 'WNetGetResourceParentA'; -function WNetGetUniversalName; external mpr name 'WNetGetUniversalNameA'; -function WNetGetUser; external mpr name 'WNetGetUserA'; -function WNetOpenEnum; external mpr name 'WNetOpenEnumA'; -function WNetSetConnection; external mpr name 'WNetSetConnectionA'; -function WNetUseConnection; external mpr name 'WNetUseConnectionA'; -function GetFileVersionInfo; external version name 'GetFileVersionInfoA'; -function GetFileVersionInfoSize; external version name 'GetFileVersionInfoSizeA'; -function VerFindFile; external version name 'VerFindFileA'; -function VerInstallFile; external version name 'VerInstallFileA'; -function VerQueryValue; external version name 'VerQueryValueA'; -function GetPrivateProfileStruct; external kernel32 name 'GetPrivateProfileStructA'; -function WritePrivateProfileStruct; external kernel32 name 'WritePrivateProfileStructA'; -function AddFontResource; external gdi32 name 'AddFontResourceA'; -function AddFontResourceEx; external gdi32 name 'AddFontResourceExA'; -function CopyEnhMetaFile; external gdi32 name 'CopyEnhMetaFileA'; -function CopyMetaFile; external gdi32 name 'CopyMetaFileA'; -function CreateColorSpace; external gdi32 name 'CreateColorSpaceA'; -function CreateDC; external gdi32 name 'CreateDCA'; -function CreateEnhMetaFile; external gdi32 name 'CreateEnhMetaFileA'; -function CreateFont; external gdi32 name 'CreateFontA'; -function CreateFontIndirect; external gdi32 name 'CreateFontIndirectA'; -function CreateFontIndirectEx; external gdi32 name 'CreateFontIndirectExA'; -function CreateIC; external gdi32 name 'CreateICA'; -function CreateMetaFile; external gdi32 name 'CreateMetaFileA'; -function CreateScalableFontResource; external gdi32 name 'CreateScalableFontResourceA'; -function DeviceCapabilities; external gdi32 name 'DeviceCapabilitiesA'; -function EnumFontFamilies; external gdi32 name 'EnumFontFamiliesA'; -function EnumFontFamiliesEx; external gdi32 name 'EnumFontFamiliesExA'; -function EnumFonts; external gdi32 name 'EnumFontsA'; -function EnumICMProfiles; external gdi32 name 'EnumICMProfilesA'; -function ExtTextOut; external gdi32 name 'ExtTextOutA'; -function GetCharABCWidths; external gdi32 name 'GetCharABCWidthsA'; -function GetCharABCWidthsFloat; external gdi32 name 'GetCharABCWidthsFloatA'; -function GetCharWidth32; external gdi32 name 'GetCharWidth32A'; -function GetCharWidth; external gdi32 name 'GetCharWidthA'; -function GetCharWidthFloat; external gdi32 name 'GetCharWidthFloatA'; -function GetCharacterPlacement; external gdi32 name 'GetCharacterPlacementA'; -function GetEnhMetaFile; external gdi32 name 'GetEnhMetaFileA'; -function GetEnhMetaFileDescription; external gdi32 name 'GetEnhMetaFileDescriptionA'; -function GetGlyphIndices; external gdi32 name 'GetGlyphIndicesA'; -function GetGlyphOutline; external gdi32 name 'GetGlyphOutlineA'; -function GetICMProfile; external gdi32 name 'GetICMProfileA'; -function GetLogColorSpace; external gdi32 name 'GetLogColorSpaceA'; -function GetMetaFile; external gdi32 name 'GetMetaFileA'; -function GetObject; external gdi32 name 'GetObjectA'; -function GetOutlineTextMetrics; external gdi32 name 'GetOutlineTextMetricsA'; -function GetTextExtentExPoint; external gdi32 name 'GetTextExtentExPointA'; -function GetTextExtentPoint32; external gdi32 name 'GetTextExtentPoint32A'; -function GetTextExtentPoint; external gdi32 name 'GetTextExtentPointA'; -function GetTextFace; external gdi32 name 'GetTextFaceA'; -function GetTextMetrics; external gdi32 name 'GetTextMetricsA'; -function PolyTextOut; external gdi32 name 'PolyTextOutA'; -function RemoveFontResource; external gdi32 name 'RemoveFontResourceA'; -function RemoveFontResourceEx; external gdi32 name 'RemoveFontResourceExA'; -function ResetDC; external gdi32 name 'ResetDCA'; -function SetICMProfile; external gdi32 name 'SetICMProfileA'; -function StartDoc; external gdi32 name 'StartDocA'; -function TextOut; external gdi32 name 'TextOutA'; -function UpdateICMRegKey; external gdi32 name 'UpdateICMRegKeyA'; -function wglUseFontBitmaps; external opengl32 name 'wglUseFontBitmapsA'; -function wglUseFontOutlines; external opengl32 name 'wglUseFontOutlinesA'; -function AnsiToOem; external user32 name 'CharToOemA'; -function AnsiToOemBuff; external user32 name 'CharToOemBuffA'; -function AnsiUpper; external user32 name 'CharUpperA'; -function AnsiUpperBuff; external user32 name 'CharUpperBuffA'; -function AnsiLower; external user32 name 'CharLowerA'; -function AnsiLowerBuff; external user32 name 'CharLowerBuffA'; -function AnsiNext; external user32 name 'CharNextA'; -function AnsiPrev; external user32 name 'CharPrevA'; -function AppendMenu; external user32 name 'AppendMenuA'; -//function BroadcastSystemMessage; external user32 name 'BroadcastSystemMessageA'; -//function BroadcastSystemMessageA; external user32 name 'BroadcastSystemMessageA'; -function CallMsgFilter; external user32 name 'CallMsgFilterA'; -function CallWindowProc; external user32 name 'CallWindowProcA'; -function ChangeDisplaySettings; external user32 name 'ChangeDisplaySettingsA'; -function ChangeDisplaySettingsEx; external user32 name 'ChangeDisplaySettingsExA'; -function ChangeMenu; external user32 name 'ChangeMenuA'; -function CharLower; external user32 name 'CharLowerA'; -function CharLowerBuff; external user32 name 'CharLowerBuffA'; -function CharNext; external user32 name 'CharNextA'; -function CharNextEx; external user32 name 'CharNextExA'; -function CharPrev; external user32 name 'CharPrevA'; -function CharPrevEx; external user32 name 'CharPrevExA'; -function CharToOem; external user32 name 'CharToOemA'; -function CharToOemBuff; external user32 name 'CharToOemBuffA'; -function CharUpper; external user32 name 'CharUpperA'; -function CharUpperBuff; external user32 name 'CharUpperBuffA'; -function CopyAcceleratorTable; external user32 name 'CopyAcceleratorTableA'; -function CreateAcceleratorTable; external user32 name 'CreateAcceleratorTableA'; -function CreateDesktop; external user32 name 'CreateDesktopA'; -function CreateDialogIndirectParam; external user32 name 'CreateDialogIndirectParamA'; -function CreateDialogParam; external user32 name 'CreateDialogParamA'; -function CreateMDIWindow; external user32 name 'CreateMDIWindowA'; -function CreateWindowEx; external user32 name 'CreateWindowExA'; -function CreateWindowStation; external user32 name 'CreateWindowStationA'; -function DefDlgProc; external user32 name 'DefDlgProcA'; -function DefFrameProc; external user32 name 'DefFrameProcA'; -function DefMDIChildProc; external user32 name 'DefMDIChildProcA'; -function DefWindowProc; external user32 name 'DefWindowProcA'; -function DialogBoxIndirectParam; external user32 name 'DialogBoxIndirectParamA'; -function DialogBoxParam; external user32 name 'DialogBoxParamA'; -function DispatchMessage; external user32 name 'DispatchMessageA'; -function DlgDirList; external user32 name 'DlgDirListA'; -function DlgDirListComboBox; external user32 name 'DlgDirListComboBoxA'; -function DlgDirSelectComboBoxEx; external user32 name 'DlgDirSelectComboBoxExA'; -function DlgDirSelectEx; external user32 name 'DlgDirSelectExA'; -function DrawState; external user32 name 'DrawStateA'; -function DrawText; external user32 name 'DrawTextA'; -function DrawTextEx; external user32 name 'DrawTextExA'; -function EnumDesktops; external user32 name 'EnumDesktopsA'; -function EnumDisplaySettings; external user32 name 'EnumDisplaySettingsA'; -function EnumDisplayDevices; external user32 name 'EnumDisplayDevicesA'; -function EnumProps; external user32 name 'EnumPropsA'; -function EnumPropsEx; external user32 name 'EnumPropsExA'; -function EnumWindowStations; external user32 name 'EnumWindowStationsA'; -function FindWindow; external user32 name 'FindWindowA'; -function FindWindowEx; external user32 name 'FindWindowExA'; -function GetAltTabInfo; external user32 name 'GetAltTabInfoA'; -function GetClassInfo; external user32 name 'GetClassInfoA'; -function GetClassInfoEx; external user32 name 'GetClassInfoExA'; -function GetClassLong; external user32 name 'GetClassLongA'; -function GetClassName; external user32 name 'GetClassNameA'; -function GetClipboardFormatName; external user32 name 'GetClipboardFormatNameA'; -function GetDlgItemText; external user32 name 'GetDlgItemTextA'; -function GetKeyNameText; external user32 name 'GetKeyNameTextA'; -function GetKeyboardLayoutName; external user32 name 'GetKeyboardLayoutNameA'; -function GetMenuItemInfo; external user32 name 'GetMenuItemInfoA'; -function GetMenuString; external user32 name 'GetMenuStringA'; -function GetMessage; external user32 name 'GetMessageA'; -function GetProp; external user32 name 'GetPropA'; -function GetTabbedTextExtent; external user32 name 'GetTabbedTextExtentA'; -function GetUserObjectInformation; external user32 name 'GetUserObjectInformationA'; -function GetWindowLong; external user32 name 'GetWindowLongA'; -function GetWindowModuleFileName; external user32 name 'GetWindowModuleFileNameA'; -function GetWindowText; external user32 name 'GetWindowTextA'; -function GetWindowTextLength; external user32 name 'GetWindowTextLengthA'; -function GrayString; external user32 name 'GrayStringA'; -function InsertMenu; external user32 name 'InsertMenuA'; -function InsertMenuItem; external user32 name 'InsertMenuItemA'; -function IsCharAlpha; external user32 name 'IsCharAlphaA'; -function IsCharAlphaNumeric; external user32 name 'IsCharAlphaNumericA'; -function IsCharLower; external user32 name 'IsCharLowerA'; -function IsCharUpper; external user32 name 'IsCharUpperA'; -function IsDialogMessage; external user32 name 'IsDialogMessageA'; -function LoadAccelerators; external user32 name 'LoadAcceleratorsA'; -function LoadBitmap; external user32 name 'LoadBitmapA'; -function LoadCursor; external user32 name 'LoadCursorA'; -function LoadCursorFromFile; external user32 name 'LoadCursorFromFileA'; -function LoadIcon; external user32 name 'LoadIconA'; -function LoadImage; external user32 name 'LoadImageA'; -function LoadKeyboardLayout; external user32 name 'LoadKeyboardLayoutA'; -function LoadMenu; external user32 name 'LoadMenuA'; -function LoadMenuIndirect; external user32 name 'LoadMenuIndirectA'; -function LoadString; external user32 name 'LoadStringA'; -function MapVirtualKey; external user32 name 'MapVirtualKeyA'; -function MapVirtualKeyEx; external user32 name 'MapVirtualKeyExA'; -function MessageBox; external user32 name 'MessageBoxA'; -function MessageBoxEx; external user32 name 'MessageBoxExA'; -function MessageBoxIndirect; external user32 name 'MessageBoxIndirectA'; -function ModifyMenu; external user32 name 'ModifyMenuA'; -function OemToAnsi; external user32 name 'OemToCharA'; -function OemToAnsiBuff; external user32 name 'OemToCharBuffA'; -function OemToChar; external user32 name 'OemToCharA'; -function OemToCharBuff; external user32 name 'OemToCharBuffA'; -function OpenDesktop; external user32 name 'OpenDesktopA'; -function OpenWindowStation; external user32 name 'OpenWindowStationA'; -function PeekMessage; external user32 name 'PeekMessageA'; -function PostMessage; external user32 name 'PostMessageA'; -function PostThreadMessage; external user32 name 'PostThreadMessageA'; -function RealGetWindowClass; external user32 name 'RealGetWindowClassA'; -function RegisterClass; external user32 name 'RegisterClassA'; -function RegisterClassEx; external user32 name 'RegisterClassExA'; -function RegisterClipboardFormat; external user32 name 'RegisterClipboardFormatA'; -function RegisterDeviceNotification; external user32 name 'RegisterDeviceNotificationA'; -function RegisterWindowMessage; external user32 name 'RegisterWindowMessageA'; -function RemoveProp; external user32 name 'RemovePropA'; -function SendDlgItemMessage; external user32 name 'SendDlgItemMessageA'; -function SendMessage; external user32 name 'SendMessageA'; -function SendMessageCallback; external user32 name 'SendMessageCallbackA'; -function SendMessageTimeout; external user32 name 'SendMessageTimeoutA'; -function SendNotifyMessage; external user32 name 'SendNotifyMessageA'; -function SetClassLong; external user32 name 'SetClassLongA'; -function SetDlgItemText; external user32 name 'SetDlgItemTextA'; -function SetMenuItemInfo; external user32 name 'SetMenuItemInfoA'; -function SetProp; external user32 name 'SetPropA'; -function SetUserObjectInformation; external user32 name 'SetUserObjectInformationA'; -function SetWindowLong; external user32 name 'SetWindowLongA'; -function SetWindowText; external user32 name 'SetWindowTextA'; -function SetWindowsHook; external user32 name 'SetWindowsHookA'; -function SetWindowsHookEx; external user32 name 'SetWindowsHookExA'; -function SystemParametersInfo; external user32 name 'SystemParametersInfoA'; -function TabbedTextOut; external user32 name 'TabbedTextOutA'; -function TranslateAccelerator; external user32 name 'TranslateAcceleratorA'; -function UnregisterClass; external user32 name 'UnregisterClassA'; -function VkKeyScan; external user32 name 'VkKeyScanA'; -function VkKeyScanEx; external user32 name 'VkKeyScanExA'; -function WinHelp; external user32 name 'WinHelpA'; -function wsprintf; external user32 name 'wsprintfA'; -function wvsprintf; external user32 name 'wvsprintfA'; -// NT 4.0 bug workaround - NT 4.0 doesn't test bInitialOwner for zero/nonzero, it tests for 1 -function _CreateMutex(lpMutexAttributes: PSecurityAttributes; - bInitialOwner: Integer; lpName: PAnsiChar): THandle; stdcall; - external kernel32 name 'CreateMutexA'; -function CreateMutex(lpMutexAttributes: PSecurityAttributes; bInitialOwner: BOOL; lpName: PAnsiChar): THandle; -begin - Result := _CreateMutex(lpMutexAttributes, Integer(Boolean(bInitialOwner)), lpName); -end; - -{$ENDIF implementation_part} /////////////////////////////////////////////////// diff --git a/plugins/ImportTXT/kol/KOL_unicode.inc b/plugins/ImportTXT/kol/KOL_unicode.inc deleted file mode 100644 index 30ab926812..0000000000 --- a/plugins/ImportTXT/kol/KOL_unicode.inc +++ /dev/null @@ -1,1277 +0,0 @@ -{******************************************************************************* - KOL_unicode.inc - Some redeclarations from Windows.pas for case, when UNICODE_CTRLS symbol is on. -*******************************************************************************} -{$IFDEF interface_part} //////////////////////////////////////////////////////// - MakeIntAtom = MakeIntAtomW; - {$IFDEF _D4orHigher} - PRecoveryAgentInformation = PRecoveryAgentInformationW; - TRecoveryAgentInformation = TRecoveryAgentInformationW; - RECOVERY_AGENT_INFORMATION = RECOVERY_AGENT_INFORMATIONW; - {$ENDIF} - PWin32FindData = PWin32FindDataW; - TWin32FindData = TWin32FindDataW; - PHWProfileInfo = PHWProfileInfoW; - THWProfileInfo = THWProfileInfoW; - POSVersionInfo = POSVersionInfoW; - TOSVersionInfo = TOSVersionInfoW; - PLogColorSpace = PLogColorSpaceW; - TLogColorSpace = TLogColorSpaceW; - {$IFDEF _D4orHigher} - PTextMetric = PTextMetricW; - tagTEXTMETRIC = tagTEXTMETRICW; - TTextMetric = TTextMetricW; - TEXTMETRIC = TEXTMETRICW; - PNewTextMetric = PNewTextMetricW; - TNewTextMetric = TNewTextMetricW; - NEWTEXTMETRIC = NEWTEXTMETRICW; - PNewTextMetricEx = PNewTextMetricExW; - {$ENDIF} - PLogFont = PLogFontW; - TLogFont = TLogFontW; - {$IFDEF _D4orHigher} - PEnumLogFont = PEnumLogFontW; - TEnumLogFont = TEnumLogFontW; - ENUMLOGFONT = ENUMLOGFONTW; - PEnumLogFontEx = PEnumLogFontExW; - TEnumLogFontEx = TEnumLogFontExW; - ENUMLOGFONTEX = ENUMLOGFONTEXW; - PExtLogFont = PExtLogFontW; - tagEXTLOGFONT = tagEXTLOGFONTW; - TExtLogFont = TExtLogFontW; - EXTLOGFONT = EXTLOGFONTW; - {$ENDIF} - PDeviceMode = PDeviceModeW; - TDeviceMode = TDeviceModeW; - {$IFDEF _D4orHigher} - DEVMODE = DEVMODEW; - PDisplayDevice = PDisplayDeviceW; - TDisplayDevice = TDisplayDeviceW; - {$ENDIF} - POutlineTextmetric = POutlineTextmetricW; - TOutlineTextmetric = TOutlineTextmetricW; - {$IFDEF _D4orHigher} - OUTLINETEXTMETRIC = OUTLINETEXTMETRICW; - {$ENDIF} - PPolyText = PPolyTextW; - {$IFDEF _D4orHigher} - tagPOLYTEXT = tagPOLYTEXTW; - POLYTEXT = POLYTEXTW; - {$ENDIF} - TPolyText = TPolyTextW; - PGCPResults = PGCPResultsW; - TGCPResults = TGCPResultsW; - {$IFDEF _D4orHigher} - GCP_RESULTS = GCP_RESULTSW; - {$ENDIF} - TFNOldFontEnumProc = TFNOldFontEnumProcW; - TFNFontEnumProc = TFNFontEnumProcW; - {$IFDEF _D4orHigher} - PAxisInfo = PAxisInfoW; - PAxesList = PAxesListW; - PEnumLogFontExDV = PEnumLogFontExDVW; - PEnumTextMetric = PEnumTextMetricW; - {$ENDIF} - PDocInfo = PDocInfoW; - TDocInfo = TDocInfoW; - {$IFDEF _D4orHigher} - DOCINFO = DOCINFOW; - {$ENDIF} - MakeIntResource = MakeIntResourceW; - PCreateStruct = PCreateStructW; - TCreateStruct = TCreateStructW; - {$IFDEF _D4orHigher} - CREATESTRUCT = CREATESTRUCTW; - {$ENDIF} - PWndClassEx = PWndClassExW; - TWndClassEx = TWndClassExW; - {$IFDEF _D4orHigher} - WNDCLASSEX = WNDCLASSEXW; - {$ENDIF} - PWndClass = PWndClassW; - TWndClass = TWndClassW; - {$IFDEF _D4orHigher} - WNDCLASS = WNDCLASSW; - {$ENDIF} - //PMenuItemInfo = PMenuItemInfoW; - //TMenuItemInfo = TMenuItemInfoW; - //MENUITEMINFO = MENUITEMINFOW; - PMsgBoxParams = PMsgBoxParamsW; - TMsgBoxParams = TMsgBoxParamsW; - {$IFDEF _D4orHigher} - MSGBOXPARAMS = MSGBOXPARAMSW; - {$ENDIF} - PMDICreateStruct = PMDICreateStructW; - TMDICreateStruct = TMDICreateStructW; - PMultiKeyHelp = PMultiKeyHelpW; - TMultiKeyHelp = TMultiKeyHelpW; - {$IFDEF _D4orHigher} - MULTIKEYHELP = MULTIKEYHELPW; - {$ENDIF} - PHelpWinInfo = PHelpWinInfoW; - THelpWinInfo = THelpWinInfoW; - {$IFDEF _D4orHigher} - HELPWININFO = HELPWININFOW; - {$ENDIF} - PNonClientMetrics = PNonClientMetricsW; - TNonClientMetrics = TNonClientMetricsW; - {$IFDEF _D4orHigher} - NONCLIENTMETRICS = NONCLIENTMETRICSW; - {$ENDIF} - PIconMetrics = PIconMetricsW; - TIconMetrics = TIconMetricsW; - {$IFDEF _D4orHigher} - ICONMETRICS = ICONMETRICSW; - {$ENDIF} - PSerialKeys = PSerialKeysW; - TSerialKeys = TSerialKeysW; - {$IFDEF _D4orHigher} - SERIALKEYS = SERIALKEYSW; - {$ENDIF} - PHighContrast = PHighContrastW; - THighContrast = THighContrastW; - {$IFDEF _D4orHigher} - HIGHCONTRAST = HIGHCONTRASTW; - {$ENDIF} - PSoundsEntry = PSoundsEntryW; - TSoundsEntry = TSoundsEntryW; - {$IFDEF _D4orHigher} - SOUNDSENTRY = SOUNDSENTRYW; - {$ENDIF} - PNumberFmt = PNumberFmtW; - TNumberFmt = TNumberFmtW; - {$IFDEF _D4orHigher} - NUMBERFMT = NUMBERFMTW; - {$ENDIF} - PCurrencyFmt = PCurrencyFmtW; - {$IFDEF _D4orHigher} - _currencyfmt = _currencyfmtW; - {$ENDIF} - TCurrencyFmt = TCurrencyFmtW; - {$IFDEF _D4orHigher} - CURRENCYFMT = CURRENCYFMTW; - {$ENDIF} - PPValue = PPValueW; - {$IFDEF _D4orHigher} - pvalue = pvalueW; - {$ENDIF} - TPValue = TPValueW; - PValueEnt = PValueEntW; - TValueEnt = TValueEntW; - {$IFDEF _D4orHigher} - VALENT = VALENTW; - {$ENDIF} - PNetResource = PNetResourceW; - TNetResource = TNetResourceW; - {$IFDEF _D4orHigher} - NETRESOURCE = NETRESOURCEW; - {$ENDIF} - PDiscDlgStruct = PDiscDlgStructW; - {$IFDEF _D4orHigher} - _DISCDLGSTRUCT = _DISCDLGSTRUCTW; - {$ENDIF} - TDiscDlgStruct = TDiscDlgStructW; - {$IFDEF _D4orHigher} - DISCDLGSTRUCT = DISCDLGSTRUCTW; - {$ENDIF} - PUniversalNameInfo = PUniversalNameInfoW; - TUniversalNameInfo = TUniversalNameInfoW; - {$IFDEF _D4orHigher} - UNIVERSAL_NAME_INFO = UNIVERSAL_NAME_INFOW; - {$ENDIF} - PRemoteNameInfo = PRemoteNameInfoW; - TRemoteNameInfo = TRemoteNameInfoW; - {$IFDEF _D4orHigher} - REMOTE_NAME_INFO = REMOTE_NAME_INFOW; - {$ENDIF} - -function AbortSystemShutdown(lpMachineName: PKOLChar): BOOL; stdcall; -function AccessCheckAndAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; ObjectTypeName, ObjectName: PKOLChar; - SecurityDescriptor: PSecurityDescriptor; DesiredAccess: DWORD; - const GenericMapping: TGenericMapping; ObjectCreation: BOOL; - var GrantedAccess: DWORD; var AccessStatus, pfGenerateOnClose: BOOL): BOOL; stdcall; -{$IFDEF _D4orHigher} -function AccessCheckByTypeAndAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; ObjectTypeName, ObjectName: PKOLChar; - SecurityDescriptor: PSecurityDescriptor; PrincipalSelfSid: PSID; DesiredAccess: DWORD; - AuditType: AUDIT_EVENT_TYPE; Flags: DWORD; ObjectTypeList: PObjectTypeList; - ObjectTypeListLength: DWORD; const GenericMapping: TGenericMapping; ObjectCreation: BOOL; - var GrantedAccess: DWORD; var AccessStatus, pfGenerateOnClose: BOOL): BOOL; stdcall; -function AccessCheckByTypeResultListAndAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; ObjectTypeName, ObjectName: PKOLChar; - SecurityDescriptor: PSecurityDescriptor; PrincipalSelfSid: PSID; DesiredAccess: DWORD; - AuditType: AUDIT_EVENT_TYPE; Flags: DWORD; ObjectTypeList: PObjectTypeList; - ObjectTypeListLength: DWORD; const GenericMapping: TGenericMapping; ObjectCreation: BOOL; - var GrantedAccess: DWORD; var AccessStatusList: DWORD; var pfGenerateOnClose: BOOL): BOOL; stdcall; -{$ENDIF} -function BackupEventLog(hEventLog: THandle; lpBackupFileName: PKOLChar): BOOL; stdcall; -function ClearEventLog(hEventLog: THandle; lpBackupFileName: PKOLChar): BOOL; stdcall; -function CreateProcessAsUser(hToken: THandle; lpApplicationName: PKOLChar; - lpCommandLine: PKOLChar; lpProcessAttributes: PSecurityAttributes; - lpThreadAttributes: PSecurityAttributes; bInheritHandles: BOOL; - dwCreationFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: PKOLChar; - const lpStartupInfo: TStartupInfo; var lpProcessInformation: TProcessInformation): BOOL; stdcall; -function GetCurrentHwProfile(var lpHwProfileInfo: THWProfileInfo): BOOL; stdcall; -function GetFileSecurity(lpFileName: PKOLChar; RequestedInformation: SECURITY_INFORMATION; - pSecurityDescriptor: PSecurityDescriptor; nLength: DWORD; var lpnLengthNeeded: DWORD): BOOL; stdcall; -function GetUserName(lpBuffer: PKOLChar; var nSize: DWORD): BOOL; stdcall; -function InitiateSystemShutdown(lpMachineName, lpMessage: PKOLChar; - dwTimeout: DWORD; bForceAppsClosed, bRebootAfterShutdown: BOOL): BOOL; stdcall; -function LogonUser(lpszUsername, lpszDomain, lpszPassword: PKOLChar; - dwLogonType, dwLogonProvider: DWORD; var phToken: THandle): BOOL; stdcall; -function LookupAccountName(lpSystemName, lpAccountName: PKOLChar; - Sid: PSID; var cbSid: DWORD; ReferencedDomainName: PKOLChar; - var cbReferencedDomainName: DWORD; var peUse: SID_NAME_USE): BOOL; stdcall; -function LookupAccountSid(lpSystemName: PKOLChar; Sid: PSID; - Name: PKOLChar; var cbName: DWORD; ReferencedDomainName: PKOLChar; - var cbReferencedDomainName: DWORD; var peUse: SID_NAME_USE): BOOL; stdcall; -function LookupPrivilegeDisplayName(lpSystemName, lpName: PKOLChar; - lpDisplayName: PKOLChar; var cbDisplayName, lpLanguageId: DWORD): BOOL; stdcall; -function LookupPrivilegeName(lpSystemName: PKOLChar; - var lpLuid: TLargeInteger; lpName: PKOLChar; var cbName: DWORD): BOOL; stdcall; -function LookupPrivilegeValue(lpSystemName, lpName: PKOLChar; - var lpLuid: TLargeInteger): BOOL; stdcall; -function ObjectCloseAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; GenerateOnClose: BOOL): BOOL; stdcall; -function ObjectDeleteAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; GenerateOnClose: BOOL): BOOL; stdcall; -function ObjectOpenAuditAlarm(SubsystemName: PKOLChar; HandleId: Pointer; - ObjectTypeName: PKOLChar; ObjectName: PKOLChar; pSecurityDescriptor: PSecurityDescriptor; - ClientToken: THandle; DesiredAccess, GrantedAccess: DWORD; - var Privileges: TPrivilegeSet; ObjectCreation, AccessGranted: BOOL; - var GenerateOnClose: BOOL): BOOL; stdcall; -function ObjectPrivilegeAuditAlarm(SubsystemName: PKOLChar; - HandleId: Pointer; ClientToken: THandle; DesiredAccess: DWORD; - var Privileges: TPrivilegeSet; AccessGranted: BOOL): BOOL; stdcall; -function OpenBackupEventLog(lpUNCServerName, lpFileName: PKOLChar): THandle; stdcall; -function OpenEventLog(lpUNCServerName, lpSourceName: PKOLChar): THandle; stdcall; -function PrivilegedServiceAuditAlarm(SubsystemName, ServiceName: PKOLChar; - ClientToken: THandle; var Privileges: TPrivilegeSet; AccessGranted: BOOL): BOOL; stdcall; -function ReadEventLog(hEventLog: THandle; dwReadFlags, dwRecordOffset: DWORD; - lpBuffer: Pointer; nNumberOfBytesToRead: DWORD; - var pnBytesRead, pnMinNumberOfBytesNeeded: DWORD): BOOL; stdcall; -function RegConnectRegistry(lpMachineName: PKOLChar; hKey: HKEY; - var phkResult: HKEY): Longint; stdcall; -function RegCreateKey(hKey: HKEY; lpSubKey: PKOLChar; - var phkResult: HKEY): Longint; stdcall; -function RegCreateKeyEx(hKey: HKEY; lpSubKey: PKOLChar; - Reserved: DWORD; lpClass: PKOLChar; dwOptions: DWORD; samDesired: REGSAM; - lpSecurityAttributes: PSecurityAttributes; var phkResult: HKEY; - lpdwDisposition: PDWORD): Longint; stdcall; -function RegDeleteKey(hKey: HKEY; lpSubKey: PKOLChar): Longint; stdcall; -function RegDeleteValue(hKey: HKEY; lpValueName: PKOLChar): Longint; stdcall; -function RegEnumKeyEx(hKey: HKEY; dwIndex: DWORD; lpName: PKOLChar; - var lpcbName: DWORD; lpReserved: Pointer; lpClass: PKOLChar; - lpcbClass: PDWORD; lpftLastWriteTime: PFileTime): Longint; stdcall; -function RegEnumKey(hKey: HKEY; dwIndex: DWORD; lpName: PKOLChar; cbName: DWORD): Longint; stdcall; -function RegEnumValue(hKey: HKEY; dwIndex: DWORD; lpValueName: PKOLChar; - var lpcbValueName: DWORD; lpReserved: Pointer; lpType: PDWORD; - lpData: PByte; lpcbData: PDWORD): Longint; stdcall; -function RegLoadKey(hKey: HKEY; lpSubKey, lpFile: PKOLChar): Longint; stdcall; -function RegOpenKey(hKey: HKEY; lpSubKey: PKOLChar; var phkResult: HKEY): Longint; stdcall; -function RegOpenKeyEx(hKey: HKEY; lpSubKey: PKOLChar; - ulOptions: DWORD; samDesired: REGSAM; var phkResult: HKEY): Longint; stdcall; -function RegQueryInfoKey(hKey: HKEY; lpClass: PKOLChar; - lpcbClass: PDWORD; lpReserved: Pointer; - lpcSubKeys, lpcbMaxSubKeyLen, lpcbMaxClassLen, lpcValues, - lpcbMaxValueNameLen, lpcbMaxValueLen, lpcbSecurityDescriptor: PDWORD; - lpftLastWriteTime: PFileTime): Longint; stdcall; -function RegQueryMultipleValues(hKey: HKEY; var ValList; - NumVals: DWORD; lpValueBuf: PKOLChar; var ldwTotsize: DWORD): Longint; stdcall; -function RegQueryValue(hKey: HKEY; lpSubKey: PKOLChar; - lpValue: PKOLChar; var lpcbValue: Longint): Longint; stdcall; -function RegQueryValueEx(hKey: HKEY; lpValueName: PKOLChar; - lpReserved: Pointer; lpType: PDWORD; lpData: PByte; lpcbData: PDWORD): Longint; stdcall; -function RegReplaceKey(hKey: HKEY; lpSubKey: PKOLChar; - lpNewFile: PKOLChar; lpOldFile: PKOLChar): Longint; stdcall; -function RegRestoreKey(hKey: HKEY; lpFile: PKOLChar; dwFlags: DWORD): Longint; stdcall; -function RegSaveKey(hKey: HKEY; lpFile: PKOLChar; - lpSecurityAttributes: PSecurityAttributes): Longint; stdcall; -function RegSetValue(hKey: HKEY; lpSubKey: PKOLChar; - dwType: DWORD; lpData: PKOLChar; cbData: DWORD): Longint; stdcall; -function RegSetValueEx(hKey: HKEY; lpValueName: PKOLChar; - Reserved: DWORD; dwType: DWORD; lpData: Pointer; cbData: DWORD): Longint; stdcall; -function RegUnLoadKey(hKey: HKEY; lpSubKey: PKOLChar): Longint; stdcall; -function RegisterEventSource(lpUNCServerName, lpSourceName: PKOLChar): THandle; stdcall; -function ReportEvent(hEventLog: THandle; wType, wCategory: Word; - dwEventID: DWORD; lpUserSid: Pointer; wNumStrings: Word; - dwDataSize: DWORD; lpStrings, lpRawData: Pointer): BOOL; stdcall; -function SetFileSecurity(lpFileName: PKOLChar; SecurityInformation: SECURITY_INFORMATION; - pSecurityDescriptor: PSecurityDescriptor): BOOL; stdcall; -function AddAtom(lpString: PKOLChar): ATOM; stdcall; -function BeginUpdateResource(pFileName: PKOLChar; bDeleteExistingResources: BOOL): THandle; stdcall; -function BuildCommDCB(lpDef: PKOLChar; var lpDCB: TDCB): BOOL; stdcall; -function BuildCommDCBAndTimeouts(lpDef: PKOLChar; var lpDCB: TDCB; - var lpCommTimeouts: TCommTimeouts): BOOL; stdcall; -function CallNamedPipe(lpNamedPipeName: PKOLChar; lpInBuffer: Pointer; - nInBufferSize: DWORD; lpOutBuffer: Pointer; nOutBufferSize: DWORD; - var lpBytesRead: DWORD; nTimeOut: DWORD): BOOL; stdcall; -function CommConfigDialog(lpszName: PKOLChar; hWnd: HWND; var lpCC: TCommConfig): BOOL; stdcall; -function CompareString(Locale: LCID; dwCmpFlags: DWORD; lpString1: PKOLChar; - cchCount1: Integer; lpString2: PKOLChar; cchCount2: Integer): Integer; stdcall; -function CopyFile(lpExistingFileName, lpNewFileName: PKOLChar; bFailIfExists: BOOL): BOOL; stdcall; -function CopyFileEx(lpExistingFileName, lpNewFileName: PKOLChar; - lpProgressRoutine: TFNProgressRoutine; lpData: Pointer; pbCancel: PBool; - dwCopyFlags: DWORD): BOOL; stdcall; -function CreateDirectory(lpPathName: PKOLChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; stdcall; -function CreateDirectoryEx(lpTemplateDirectory, lpNewDirectory: PKOLChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; stdcall; -function CreateEvent(lpEventAttributes: PSecurityAttributes; - bManualReset, bInitialState: BOOL; lpName: PKOLChar): THandle; stdcall; -function CreateFile(lpFileName: PKOLChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; stdcall; -function CreateFileMapping(hFile: THandle; lpFileMappingAttributes: PSecurityAttributes; - flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD; lpName: PKOLChar): THandle; stdcall; -function CreateHardLink(lpFileName, lpExistingFileName: PKOLChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; stdcall; -function CreateMailslot(lpName: PKOLChar; nMaxMessageSize: DWORD; - lReadTimeout: DWORD; lpSecurityAttributes: PSecurityAttributes): THandle; stdcall; -function CreateNamedPipe(lpName: PKOLChar; - dwOpenMode, dwPipeMode, nMaxInstances, nOutBufferSize, nInBufferSize, nDefaultTimeOut: DWORD; - lpSecurityAttributes: PSecurityAttributes): THandle; stdcall; -function CreateProcess(lpApplicationName: PKOLChar; lpCommandLine: PKOLChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PKOLChar; const lpStartupInfo: TStartupInfo; - var lpProcessInformation: TProcessInformation): BOOL; stdcall; -function CreateSemaphore(lpSemaphoreAttributes: PSecurityAttributes; - lInitialCount, lMaximumCount: Longint; lpName: PKOLChar): THandle; stdcall; -function CreateWaitableTimer(lpTimerAttributes: PSecurityAttributes; bManualReset: BOOL; lpTimerName: PKOLChar): THandle; stdcall; -function DefineDosDevice(dwFlags: DWORD; lpDeviceName, lpTargetPath: PKOLChar): BOOL; stdcall; -function DeleteFile(lpFileName: PKOLChar): BOOL; stdcall; -function EndUpdateResource(hUpdate: THandle; fDiscard: BOOL): BOOL; stdcall; -function EnumCalendarInfo(lpCalInfoEnumProc: TFNCalInfoEnumProc; Locale: LCID; - Calendar: CALID; CalType: CALTYPE): BOOL; stdcall; -function EnumDateFormats(lpDateFmtEnumProc: TFNDateFmtEnumProc; - Locale: LCID; dwFlags: DWORD): BOOL; stdcall; -function EnumResourceLanguages(hModule: HMODULE; lpType, lpName: PKOLChar; - lpEnumFunc: ENUMRESLANGPROC; lParam: Longint): BOOL; stdcall; -function EnumResourceNames(hModule: HMODULE; lpType: PKOLChar; - lpEnumFunc: ENUMRESNAMEPROC; lParam: Longint): BOOL; stdcall; -function EnumResourceTypes(hModule: HMODULE; lpEnumFunc: ENUMRESTYPEPROC; - lParam: Longint): BOOL; stdcall; -function EnumSystemCodePages(lpCodePageEnumProc: TFNCodepageEnumProc; dwFlags: DWORD): BOOL; stdcall; -function EnumSystemLocales(lpLocaleEnumProc: TFNLocaleEnumProc; dwFlags: DWORD): BOOL; stdcall; -function EnumTimeFormats(lpTimeFmtEnumProc: TFNTimeFmtEnumProc; - Locale: LCID; dwFlags: DWORD): BOOL; stdcall; -function ExpandEnvironmentStrings(lpSrc: PKOLChar; lpDst: PKOLChar; nSize: DWORD): DWORD; stdcall; -procedure FatalAppExit(uAction: UINT; lpMessageText: PKOLChar); stdcall; -function FillConsoleOutputCharacter(hConsoleOutput: THandle; cCharacter: KOLChar; - nLength: DWORD; dwWriteCoord: TCoord; var lpNumberOfCharsWritten: DWORD): BOOL; stdcall; -function FindAtom(lpString: PKOLChar): ATOM; stdcall; -function FindFirstChangeNotification(lpPathName: PKOLChar; - bWatchSubtree: BOOL; dwNotifyFilter: DWORD): THandle; stdcall; -function FindFirstFile(lpFileName: PKOLChar; var lpFindFileData: TWIN32FindData): THandle; stdcall; -function FindFirstFileEx(lpFileName: PKOLChar; fInfoLevelId: TFindexInfoLevels; - lpFindFileData: Pointer; fSearchOp: TFindexSearchOps; lpSearchFilter: Pointer; - dwAdditionalFlags: DWORD): BOOL; stdcall; -function FindNextFile(hFindFile: THandle; var lpFindFileData: TWIN32FindData): BOOL; stdcall; -function FindResource(hModule: HMODULE; lpName, lpType: PKOLChar): HRSRC; stdcall; -function FindResourceEx(hModule: HMODULE; lpType, lpName: PKOLChar; wLanguage: Word): HRSRC; stdcall; -function FoldString(dwMapFlags: DWORD; lpSrcStr: PKOLChar; cchSrc: Integer; - lpDestStr: PKOLChar; cchDest: Integer): Integer; stdcall; -function FormatMessage(dwFlags: DWORD; lpSource: Pointer; dwMessageId: DWORD; dwLanguageId: DWORD; - lpBuffer: PKOLChar; nSize: DWORD; Arguments: Pointer): DWORD; stdcall; -function FreeEnvironmentStrings(EnvBlock: PKOLChar): BOOL; stdcall; -function GetAtomName(nAtom: ATOM; lpBuffer: PKOLChar; nSize: Integer): UINT; stdcall; -function GetBinaryType(lpApplicationName: PKOLChar; var lpBinaryType: DWORD): BOOL; stdcall; -function GetCommandLine: PKOLChar; stdcall; -function GetCompressedFileSize(lpFileName: PKOLChar; lpFileSizeHigh: PDWORD): DWORD; stdcall; -function GetComputerName(lpBuffer: PKOLChar; var nSize: DWORD): BOOL; stdcall; -function GetConsoleTitle(lpConsoleTitle: PKOLChar; nSize: DWORD): DWORD; stdcall; -function GetCurrencyFormat(Locale: LCID; dwFlags: DWORD; lpValue: PKOLChar; - lpFormat: PCurrencyFmt; lpCurrencyStr: PKOLChar; cchCurrency: Integer): Integer; stdcall; -function GetCurrentDirectory(nBufferLength: DWORD; lpBuffer: PKOLChar): DWORD; stdcall; -function GetDateFormat(Locale: LCID; dwFlags: DWORD; lpDate: PSystemTime; - lpFormat: PKOLChar; lpDateStr: PKOLChar; cchDate: Integer): Integer; stdcall; -function GetDefaultCommConfig(lpszName: PKOLChar; - var lpCC: TCommConfig; var lpdwSize: DWORD): BOOL; stdcall; -function GetDiskFreeSpace(lpRootPathName: PKOLChar; - var lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; stdcall; -function GetDiskFreeSpaceEx(lpDirectoryName: PKOLChar; - var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes; lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall; -function GetDriveType(lpRootPathName: PKOLChar): UINT; stdcall; -function GetEnvironmentStrings: PKOLChar; stdcall; -function GetEnvironmentVariable(lpName: PKOLChar; lpBuffer: PKOLChar; nSize: DWORD): DWORD; stdcall; - {$IFDEF _D4orHigher} overload; {$ENDIF} -function GetFileAttributes(lpFileName: PKOLChar): DWORD; stdcall; -function GetFileAttributesEx(lpFileName: PKOLChar; - fInfoLevelId: TGetFileExInfoLevels; lpFileInformation: Pointer): BOOL; stdcall; -function GetFullPathName(lpFileName: PKOLChar; nBufferLength: DWORD; - lpBuffer: PKOLChar; var lpFilePart: PKOLChar): DWORD; stdcall; -function GetLocaleInfo(Locale: LCID; LCType: LCTYPE; lpLCData: PKOLChar; cchData: Integer): Integer; stdcall; -function GetLogicalDriveStrings(nBufferLength: DWORD; lpBuffer: PKOLChar): DWORD; stdcall; -function GetModuleFileName(hModule: HINST; lpFilename: PKOLChar; nSize: DWORD): DWORD; stdcall; -function GetModuleHandle(lpModuleName: PKOLChar): HMODULE; stdcall; -function GetNamedPipeHandleState(hNamedPipe: THandle; - lpState, lpCurInstances, lpMaxCollectionCount, lpCollectDataTimeout: PDWORD; - lpUserName: PKOLChar; nMaxUserNameSize: DWORD): BOOL; stdcall; -function GetNumberFormat(Locale: LCID; dwFlags: DWORD; lpValue: PKOLChar; - lpFormat: PNumberFmt; lpNumberStr: PKOLChar; cchNumber: Integer): Integer; stdcall; -function GetPrivateProfileInt(lpAppName, lpKeyName: PKOLChar; nDefault: Integer; lpFileName: PKOLChar): UINT; stdcall; -function GetPrivateProfileSection(lpAppName: PKOLChar; lpReturnedString: PKOLChar; nSize: DWORD; lpFileName: PKOLChar): DWORD; stdcall; -function GetPrivateProfileSectionNames(lpszReturnBuffer: PKOLChar; nSize: DWORD; lpFileName: PKOLChar): DWORD; stdcall; -function GetPrivateProfileString(lpAppName, lpKeyName, lpDefault: PKOLChar; - lpReturnedString: PKOLChar; nSize: DWORD; lpFileName: PKOLChar): DWORD; stdcall; -function GetProfileInt(lpAppName, lpKeyName: PKOLChar; nDefault: Integer): UINT; stdcall; -function GetProfileSection(lpAppName: PKOLChar; lpReturnedString: PKOLChar; nSize: DWORD): DWORD; stdcall; -function GetProfileString(lpAppName, lpKeyName, lpDefault: PKOLChar; - lpReturnedString: PKOLChar; nSize: DWORD): DWORD; stdcall; -function GetShortPathName(lpszLongPath: PKOLChar; lpszShortPath: PKOLChar; - cchBuffer: DWORD): DWORD; stdcall; -procedure GetStartupInfo(var lpStartupInfo: TStartupInfo); stdcall; -function GetStringTypeEx(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PKOLChar; cchSrc: Integer; var lpCharType): BOOL; stdcall; -function GetSystemDirectory(lpBuffer: PKOLChar; uSize: UINT): UINT; stdcall; -function GetTempFileName(lpPathName, lpPrefixString: PKOLChar; - uUnique: UINT; lpTempFileName: PKOLChar): UINT; stdcall; -function GetTempPath(nBufferLength: DWORD; lpBuffer: PKOLChar): DWORD; stdcall; -function GetTimeFormat(Locale: LCID; dwFlags: DWORD; lpTime: PSystemTime; - lpFormat: PKOLChar; lpTimeStr: PKOLChar; cchTime: Integer): Integer; stdcall; -function GetVersionEx(var lpVersionInformation: TOSVersionInfo): BOOL; stdcall; -function GetVolumeInformation(lpRootPathName: PKOLChar; - lpVolumeNameBuffer: PKOLChar; nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; - lpFileSystemNameBuffer: PKOLChar; nFileSystemNameSize: DWORD): BOOL; stdcall; -function GetWindowsDirectory(lpBuffer: PKOLChar; uSize: UINT): UINT; stdcall; -function GlobalAddAtom(lpString: PKOLChar): ATOM; stdcall; -function GlobalFindAtom(lpString: PKOLChar): ATOM; stdcall; -function GlobalGetAtomName(nAtom: ATOM; lpBuffer: PKOLChar; nSize: Integer): UINT; stdcall; -function IsBadStringPtr(lpsz: PKOLChar; ucchMax: UINT): BOOL; stdcall; -function LCMapString(Locale: LCID; dwMapFlags: DWORD; lpSrcStr: PKOLChar; - cchSrc: Integer; lpDestStr: PKOLChar; cchDest: Integer): Integer; stdcall; -function LoadLibrary(lpLibFileName: PKOLChar): HMODULE; stdcall; -function LoadLibraryEx(lpLibFileName: PKOLChar; hFile: THandle; dwFlags: DWORD): HMODULE; stdcall; -function MoveFile(lpExistingFileName, lpNewFileName: PKOLChar): BOOL; stdcall; -function MoveFileEx(lpExistingFileName, lpNewFileName: PKOLChar; dwFlags: DWORD): BOOL; stdcall; -function MoveFileWithProgress(lpExistingFileName, lpNewFileName: PKOLChar; lpProgressRoutine: TFNProgressRoutine; - lpData: Pointer; dwFlags: DWORD): BOOL; stdcall; -function OpenEvent(dwDesiredAccess: DWORD; bInheritHandle: BOOL; lpName: PKOLChar): THandle; stdcall; -function OpenFileMapping(dwDesiredAccess: DWORD; bInheritHandle: BOOL; lpName: PKOLChar): THandle; stdcall; -function OpenMutex(dwDesiredAccess: DWORD; bInheritHandle: BOOL; lpName: PKOLChar): THandle; stdcall; -function OpenSemaphore(dwDesiredAccess: DWORD; bInheritHandle: BOOL; lpName: PKOLChar): THandle; stdcall; -function OpenWaitableTimer(dwDesiredAccess: DWORD; bInheritHandle: BOOL; - lpTimerName: PKOLChar): THandle; stdcall; -procedure OutputDebugString(lpOutputString: PKOLChar); stdcall; -function PeekConsoleInput(hConsoleInput: THandle; var lpBuffer: TInputRecord; - nLength: DWORD; var lpNumberOfEventsRead: DWORD): BOOL; stdcall; -function QueryDosDevice(lpDeviceName: PKOLChar; lpTargetPath: PKOLChar; ucchMax: DWORD): DWORD; stdcall; -{$IFDEF _D4orHigher} -function QueryRecoveryAgents(p1: PKOLChar; var p2: Pointer; var p3: TRecoveryAgentInformation): DWORD; stdcall; -{$ENDIF} -function ReadConsole(hConsoleInput: THandle; lpBuffer: Pointer; - nNumberOfCharsToRead: DWORD; var lpNumberOfCharsRead: DWORD; lpReserved: Pointer): BOOL; stdcall; -function ReadConsoleInput(hConsoleInput: THandle; var lpBuffer: TInputRecord; - nLength: DWORD; var lpNumberOfEventsRead: DWORD): BOOL; stdcall; -function ReadConsoleOutput(hConsoleOutput: THandle; lpBuffer: Pointer; - dwBufferSize, dwBufferCoord: TCoord; var lpReadRegion: TSmallRect): BOOL; stdcall; -function ReadConsoleOutputCharacter(hConsoleOutput: THandle; lpCharacter: PKOLChar; - nLength: DWORD; dwReadCoord: TCoord; var lpNumberOfCharsRead: DWORD): BOOL; stdcall; -function RemoveDirectory(lpPathName: PKOLChar): BOOL; stdcall; -function ScrollConsoleScreenBuffer(hConsoleOutput: THandle; - const lpScrollRectangle: TSmallRect; lpClipRectangle: PSmallRect; - dwDestinationOrigin: TCoord; var lpFill: TCharInfo): BOOL; stdcall; -function SearchPath(lpPath, lpFileName, lpExtension: PKOLChar; - nBufferLength: DWORD; lpBuffer: PKOLChar; var lpFilePart: PKOLChar): DWORD; stdcall; -function SetComputerName(lpComputerName: PKOLChar): BOOL; stdcall; -function SetConsoleTitle(lpConsoleTitle: PKOLChar): BOOL; stdcall; -function SetCurrentDirectory(lpPathName: PKOLChar): BOOL; stdcall; -function SetDefaultCommConfig(lpszName: PKOLChar; lpCC: PCommConfig; dwSize: DWORD): BOOL; stdcall; -function SetEnvironmentVariable(lpName, lpValue: PKOLChar): BOOL; stdcall; -function SetFileAttributes(lpFileName: PKOLChar; dwFileAttributes: DWORD): BOOL; stdcall; -function SetLocaleInfo(Locale: LCID; LCType: LCTYPE; lpLCData: PKOLChar): BOOL; stdcall; -function SetVolumeLabel(lpRootPathName: PKOLChar; lpVolumeName: PKOLChar): BOOL; stdcall; -function UpdateResource(hUpdate: THandle; lpType, lpName: PKOLChar; - wLanguage: Word; lpData: Pointer; cbData: DWORD): BOOL; stdcall; -function VerLanguageName(wLang: DWORD; szLang: PKOLChar; nSize: DWORD): DWORD; stdcall; -function WaitNamedPipe(lpNamedPipeName: PKOLChar; nTimeOut: DWORD): BOOL; stdcall; -function WriteConsole(hConsoleOutput: THandle; const lpBuffer: Pointer; - nNumberOfCharsToWrite: DWORD; var lpNumberOfCharsWritten: DWORD; lpReserved: Pointer): BOOL; stdcall; -function WriteConsoleInput(hConsoleInput: THandle; const lpBuffer: TInputRecord; - nLength: DWORD; var lpNumberOfEventsWritten: DWORD): BOOL; stdcall; -function WriteConsoleOutput(hConsoleOutput: THandle; lpBuffer: Pointer; - dwBufferSize, dwBufferCoord: TCoord; var lpWriteRegion: TSmallRect): BOOL; stdcall; -function WriteConsoleOutputCharacter(hConsoleOutput: THandle;lpCharacter: PKOLChar; - nLength: DWORD; dwWriteCoord: TCoord; var lpNumberOfCharsWritten: DWORD): BOOL; stdcall; -function WritePrivateProfileSection(lpAppName, lpString, lpFileName: PKOLChar): BOOL; stdcall; -function WritePrivateProfileString(lpAppName, lpKeyName, lpString, lpFileName: PKOLChar): BOOL; stdcall; -function WriteProfileSection(lpAppName, lpString: PKOLChar): BOOL; stdcall; -function WriteProfileString(lpAppName, lpKeyName, lpString: PKOLChar): BOOL; stdcall; -function lstrcat(lpString1, lpString2: PKOLChar): PKOLChar; stdcall; -function lstrcmp(lpString1, lpString2: PKOLChar): Integer; stdcall; -function lstrcmpi(lpString1, lpString2: PKOLChar): Integer; stdcall; -function lstrcpy(lpString1, lpString2: PKOLChar): PKOLChar; stdcall; -function lstrcpyn(lpString1, lpString2: PKOLChar; iMaxLength: Integer): PKOLChar; stdcall; -function lstrlen(lpString: PKOLChar): Integer; stdcall; -function MultinetGetConnectionPerformance(lpNetResource: PNetResource; - lpNetConnectInfoStruc: PNetConnectInfoStruct): DWORD; stdcall; -function WNetAddConnection2(var lpNetResource: TNetResource; - lpPassword, lpUserName: PKOLChar; dwFlags: DWORD): DWORD; stdcall; -function WNetAddConnection3(hwndOwner: HWND; var lpNetResource: TNetResource; - lpPassword, lpUserName: PKOLChar; dwFlags: DWORD): DWORD; stdcall; -function WNetAddConnection(lpRemoteName, lpPassword, lpLocalName: PKOLChar): DWORD; stdcall; -function WNetCancelConnection2(lpName: PKOLChar; dwFlags: DWORD; fForce: BOOL): DWORD; stdcall; -function WNetCancelConnection(lpName: PKOLChar; fForce: BOOL): DWORD; stdcall; -function WNetConnectionDialog1(var lpConnDlgStruct: TConnectDlgStruct): DWORD; stdcall; -function WNetDisconnectDialog1(var lpConnDlgStruct: TDiscDlgStruct): DWORD; stdcall; -function WNetEnumResource(hEnum: THandle; var lpcCount: DWORD; - lpBuffer: Pointer; var lpBufferSize: DWORD): DWORD; stdcall; -function WNetGetConnection(lpLocalName: PKOLChar; - lpRemoteName: PKOLChar; var lpnLength: DWORD): DWORD; stdcall; -function WNetGetLastError(var lpError: DWORD; lpErrorBuf: PKOLChar; - nErrorBufSize: DWORD; lpNameBuf: PKOLChar; nNameBufSize: DWORD): DWORD; stdcall; -function WNetGetNetworkInformation(lpProvider: PKOLChar; - var lpNetInfoStruct: TNetInfoStruct): DWORD; stdcall; -function WNetGetProviderName(dwNetType: DWORD; lpProviderName: PKOLChar; - var lpBufferSize: DWORD): DWORD; stdcall; -function WNetGetResourceParent(lpNetResource: PNetResource; - lpBuffer: Pointer; var cbBuffer: DWORD): DWORD; stdcall; -function WNetGetUniversalName(lpLocalPath: PKOLChar; dwInfoLevel: DWORD; - lpBuffer: Pointer; var lpBufferSize: DWORD): DWORD; stdcall; -function WNetGetUser(lpName: PKOLChar; lpUserName: PKOLChar; var lpnLength: DWORD): DWORD; stdcall; -function WNetOpenEnum(dwScope, dwType, dwUsage: DWORD; - lpNetResource: PNetResource; var lphEnum: THandle): DWORD; stdcall; -function WNetSetConnection(lpName: PKOLChar; dwProperties: DWORD; pvValues: Pointer): DWORD; stdcall; -function WNetUseConnection(hwndOwner: HWND; - var lpNetResource: TNetResource; lpUserID: PKOLChar; - lpPassword: PKOLChar; dwFlags: DWORD; lpAccessName: PKOLChar; - var lpBufferSize: DWORD; var lpResult: DWORD): DWORD; stdcall; -function GetFileVersionInfo(lptstrFilename: PKOLChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; stdcall; -function GetFileVersionInfoSize(lptstrFilename: PKOLChar; var lpdwHandle: DWORD): DWORD; stdcall; -function VerFindFile(uFlags: DWORD; szFileName, szWinDir, szAppDir, szCurDir: PKOLChar; - var lpuCurDirLen: UINT; szDestDir: PKOLChar; var lpuDestDirLen: UINT): DWORD; stdcall; -function VerInstallFile(uFlags: DWORD; - szSrcFileName, szDestFileName, szSrcDir, szDestDir, szCurDir, szTmpFile: PKOLChar; - var lpuTmpFileLen: UINT): DWORD; stdcall; -function VerQueryValue(pBlock: Pointer; lpSubBlock: PKOLChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; stdcall; -function GetPrivateProfileStruct(lpszSection, lpszKey: PKOLChar; - lpStruct: Pointer; uSizeStruct: UINT; szFile: PKOLChar): BOOL; stdcall; -function WritePrivateProfileStruct(lpszSection, lpszKey: PKOLChar; - lpStruct: Pointer; uSizeStruct: UINT; szFile: PKOLChar): BOOL; stdcall; -function AddFontResource(FileName: PKOLChar): Integer; stdcall; -{$IFDEF _D4orHigher} -function AddFontResourceEx(p1: PKOLChar; p2: DWORD; p3: PDesignVector): Integer; stdcall; -{$ENDIF} -function CopyEnhMetaFile(p1: HENHMETAFILE; p2: PKOLChar): HENHMETAFILE; stdcall; -function CopyMetaFile(p1: HMETAFILE; p2: PKOLChar): HMETAFILE; stdcall; -function CreateColorSpace(var ColorSpace: TLogColorSpace): HCOLORSPACE; stdcall; -function CreateDC(lpszDriver, lpszDevice, lpszOutput: PKOLChar; - lpdvmInit: PDeviceMode): HDC; stdcall; -function CreateEnhMetaFile(DC: HDC; FileName: PKOLChar; Rect: PRect; Desc: PKOLChar): HDC; stdcall; -function CreateFont(nHeight, nWidth, nEscapement, nOrientaion, fnWeight: Integer; - fdwItalic, fdwUnderline, fdwStrikeOut, fdwCharSet, fdwOutputPrecision, - fdwClipPrecision, fdwQuality, fdwPitchAndFamily: DWORD; lpszFace: PKOLChar): HFONT; stdcall; -function CreateFontIndirect(const p1: TLogFont): HFONT; stdcall; -{$IFDEF _D4orHigher} -function CreateFontIndirectEx(const p1: PEnumLogFontExDV): HFONT; stdcall; -{$ENDIF} -function CreateIC(lpszDriver, lpszDevice, lpszOutput: PKOLChar; lpdvmInit: PDeviceMode): HDC; stdcall; -function CreateMetaFile(p1: PKOLChar): HDC; stdcall; -function CreateScalableFontResource(p1: DWORD; p2, p3, p4: PKOLChar): BOOL; stdcall; -function DeviceCapabilities(pDriverName, pDeviceName, pPort: PKOLChar; - iIndex: Integer; pOutput: PKOLChar; DevMode: PDeviceMode): Integer; stdcall; -function EnumFontFamilies(DC: HDC; p2: PKOLChar; p3: TFNFontEnumProc; p4: LPARAM): BOOL; stdcall; -function EnumFontFamiliesEx(DC: HDC; var p2: TLogFont; - p3: TFNFontEnumProc; p4: LPARAM; p5: DWORD): BOOL; stdcall; -function EnumFonts(DC: HDC; lpszFace: PKOLChar; fntenmprc: TFNFontEnumProc; - lpszData: PKOLChar): Integer; stdcall; -function EnumICMProfiles(DC: HDC; ICMProc: TFNICMEnumProc; p3: LPARAM): Integer; stdcall; -function ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; - Rect: PRect; Str: PKOLChar; Count: Longint; Dx: PInteger): BOOL; stdcall; -function GetCharABCWidths(DC: HDC; FirstChar, LastChar: UINT; const ABCStructs): BOOL; stdcall; -function GetCharABCWidthsFloat(DC: HDC; FirstChar, LastChar: UINT; const ABCFloatSturcts): BOOL; stdcall; -function GetCharWidth32(DC: HDC; FirstChar, LastChar: UINT; const Widths): BOOL; stdcall; -function GetCharWidth(DC: HDC; FirstChar, LastChar: UINT; const Widths): BOOL; stdcall; -function GetCharWidthFloat(DC: HDC; FirstChar, LastChar: UINT; const Widths): BOOL; stdcall; -function GetCharacterPlacement(DC: HDC; p2: PKOLChar; p3, p4: BOOL; - var p5: TGCPResults; p6: DWORD): DWORD; stdcall; -function GetEnhMetaFile(p1: PKOLChar): HENHMETAFILE; stdcall; -function GetEnhMetaFileDescription(p1: HENHMETAFILE; p2: UINT; p3: PKOLChar): UINT; stdcall; -function GetGlyphIndices(DC: HDC; p2: PKOLChar; p3: Integer; p4: PWORD; p5: DWORD): DWORD; stdcall; -function GetGlyphOutline(DC: HDC; uChar, uFormat: UINT; - const lpgm: TGlyphMetrics; cbBuffer: DWORD; lpvBuffer: Pointer; const lpmat2: TMat2): DWORD; stdcall; -function GetICMProfile(DC: HDC; var Size: DWORD; Name: PKOLChar): BOOL; stdcall; -function GetLogColorSpace(p1: HCOLORSPACE; var ColorSpace: TLogColorSpace; Size: DWORD): BOOL; stdcall; -function GetMetaFile(p1: PKOLChar): HMETAFILE; stdcall; -function GetObject(p1: HGDIOBJ; p2: Integer; p3: Pointer): Integer; stdcall; -function GetOutlineTextMetrics(DC: HDC; p2: UINT; OTMetricStructs: Pointer): UINT; stdcall; -function GetTextExtentExPoint(DC: HDC; p2: PKOLChar; - p3, p4: Integer; p5, p6: PInteger; var p7: TSize): BOOL; stdcall; -function GetTextExtentPoint32(DC: HDC; Str: PKOLChar; Count: Integer; - var Size: TSize): BOOL; stdcall; -function GetTextExtentPoint(DC: HDC; Str: PKOLChar; Count: Integer; - var Size: TSize): BOOL; stdcall; -function GetTextFace(DC: HDC; Count: Integer; Buffer: PKOLChar): Integer; stdcall; -function GetTextMetrics(DC: HDC; var TM: TTextMetric): BOOL; stdcall; -function PolyTextOut(DC: HDC; const PolyTextArray; Strings: Integer): BOOL; stdcall; -function RemoveFontResource(FileName: PKOLChar): BOOL; stdcall; -{$IFDEF _D4orHigher} -function RemoveFontResourceEx(p1: PKOLChar; p2: DWORD; p3: PDesignVector): BOOL; stdcall; -{$ENDIF} -function ResetDC(DC: HDC; const InitData: TDeviceMode): HDC; stdcall; -function SetICMProfile(DC: HDC; Name: PKOLChar): BOOL; stdcall; -function StartDoc(DC: HDC; const p2: TDocInfo): Integer; stdcall; -function TextOut(DC: HDC; X, Y: Integer; Str: PKOLChar; Count: Integer): BOOL; stdcall; -function UpdateICMRegKey(p1: DWORD; p2, p3: PKOLChar; p4: UINT): BOOL; stdcall; -function wglUseFontBitmaps(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; -function wglUseFontOutlines(p1: HDC; p2, p3, p4: DWORD; - p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; -function AnsiToOem(const lpszSrc: LPCSTR; lpszDst: LPSTR): BOOL; stdcall; -function AnsiToOemBuff(lpszSrc: LPCSTR; lpszDst: LPSTR; cchDstLength: DWORD): BOOL; stdcall; -function AnsiUpper(lpsz: LPSTR): LPSTR; stdcall; -function AnsiUpperBuff(lpsz: LPSTR; cchLength: DWORD): DWORD; stdcall; -function AnsiLower(lpsz: LPSTR): LPSTR; stdcall; -function AnsiLowerBuff(lpsz: LPSTR; cchLength: DWORD): DWORD; stdcall; -function AnsiNext(const lpsz: LPCSTR): LPSTR; stdcall; -function AnsiPrev(const lpszStart: LPCSTR; const lpszCurrent: LPCSTR): LPSTR; stdcall; -function AppendMenu(hMenu: HMENU; uFlags, uIDNewItem: UINT; - lpNewItem: PKOLChar): BOOL; stdcall; -//function BroadcastSystemMessage(Flags: DWORD; Recipients: PDWORD; -// uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall; -//function BroadcastSystemMessageW(Flags: DWORD; Recipients: PDWORD; -// uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall; -function CallMsgFilter(var lpMsg: TMsg; nCode: Integer): BOOL; stdcall; -function CallWindowProc(lpPrevWndFunc: TFNWndProc; hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function ChangeDisplaySettings(var lpDevMode: TDeviceMode; dwFlags: DWORD): Longint; stdcall; -function ChangeDisplaySettingsEx(lpszDeviceName: PKOLChar; var lpDevMode: TDeviceMode; - wnd: HWND; dwFlags: DWORD; lParam: Pointer): Longint; stdcall; -function ChangeMenu(hMenu: HMENU; cmd: UINT; lpszNewItem: PKOLChar; - cmdInsert: UINT; flags: UINT): BOOL; stdcall; -function CharLower(lpsz: PKOLChar): PKOLChar; stdcall; -function CharLowerBuff(lpsz: PKOLChar; cchLength: DWORD): DWORD; stdcall; -function CharNext(lpsz: PKOLChar): PKOLChar; stdcall; -function CharNextEx(CodePage: Word; lpCurrentChar: LPCSTR; dwFlags: DWORD): LPSTR; stdcall; -function CharPrev(lpszStart: PKOLChar; lpszCurrent: PKOLChar): PKOLChar; stdcall; -function CharPrevEx(CodePage: Word; lpStart, lpCurrentChar: LPCSTR; dwFlags: DWORD): LPSTR; stdcall; -function CharToOem(lpszSrc: PKOLChar; lpszDst: PKOLChar): BOOL; stdcall; -function CharToOemBuff(lpszSrc: PKOLChar; lpszDst: PKOLChar; cchDstLength: DWORD): BOOL; stdcall; -function CharUpper(lpsz: PKOLChar): PKOLChar; stdcall; -function CharUpperBuff(lpsz: PKOLChar; cchLength: DWORD): DWORD; stdcall; -function CopyAcceleratorTable(hAccelSrc: HACCEL; var lpAccelDst; cAccelEntries: Integer): Integer; stdcall; -function CreateAcceleratorTable(var Accel; Count: Integer): HACCEL; stdcall; -function CreateDesktop(lpszDesktop, lpszDevice: PKOLChar; - pDevmode: PDeviceMode; dwFlags: DWORD; dwDesiredAccess: - DWORD; lpsa: PSecurityAttributes): HDESK; stdcall; -function CreateDialogIndirectParam(hInstance: HINST; const lpTemplate: TDlgTemplate; - hWndParent: HWND; lpDialogFunc: TFNDlgProc; dwInitParam: LPARAM): HWND; stdcall; -function CreateDialogParam(hInstance: HINST; lpTemplateName: PKOLChar; - hWndParent: HWND; lpDialogFunc: TFNDlgProc; dwInitParam: LPARAM): HWND; stdcall; -function CreateMDIWindow(lpClassName, lpWindowName: PKOLChar; - dwStyle: DWORD; X, Y, nWidth, nHeight: Integer; - hWndParent: HWND; hInstance: HINST; lParam: LPARAM): HWND; stdcall; -function CreateWindowEx(dwExStyle: DWORD; lpClassName: PKOLChar; - lpWindowName: PKOLChar; dwStyle: DWORD; X, Y, nWidth, nHeight: Integer; - hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: Pointer): HWND; stdcall; -function CreateWindowStation(lpwinsta: PKOLChar; dwReserved, dwDesiredAccess: DWORD; - lpsa: PSecurityAttributes): HWINSTA; stdcall; -function DefDlgProc(hDlg: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function DefFrameProc(hWnd, hWndMDIClient: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function DefMDIChildProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function DefWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function DialogBoxIndirectParam(hInstance: HINST; const lpDialogTemplate: TDlgTemplate; - hWndParent: HWND; lpDialogFunc: TFNDlgProc; dwInitParam: LPARAM): Integer; stdcall; -function DialogBoxParam(hInstance: HINST; lpTemplateName: PKOLChar; - hWndParent: HWND; lpDialogFunc: TFNDlgProc; dwInitParam: LPARAM): Integer; stdcall; -function DispatchMessage(const lpMsg: TMsg): Longint; stdcall; -function DlgDirList(hDlg: HWND; lpPathSpec: PKOLChar; - nIDListBox, nIDStaticPath: Integer; uFileType: UINT): Integer; stdcall; -function DlgDirListComboBox(hDlg: HWND; lpPathSpec: PKOLChar; - nIDComboBox, nIDStaticPath: Integer; uFiletype: UINT): Integer; stdcall; -function DlgDirSelectComboBoxEx(hDlg: HWND; lpString: PKOLChar; - nCount, nIDComboBox: Integer): BOOL; stdcall; -function DlgDirSelectEx(hDlg: HWND; lpString: PKOLChar; nCount, nIDListBox: Integer): BOOL; stdcall; -function DrawState(DC: HDC; Brush: HBRUSH; CBFunc: TFNDrawStateProc; - lData: LPARAM; wData: WPARAM; x, y, cx, cy: Integer; Flags: UINT): BOOL; stdcall; -function DrawText(hDC: HDC; lpString: PKOLChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; stdcall; -function DrawTextEx(DC: HDC; lpchText: PKOLChar; cchText: Integer; var p4: TRect; - dwDTFormat: UINT; DTParams: PDrawTextParams): Integer; stdcall; -function EnumDesktops(hwinsta: HWINSTA; lpEnumFunc: TFNDeskTopEnumProc; lParam: LPARAM): BOOL; stdcall; -function EnumDisplaySettings(lpszDeviceName: PKOLChar; iModeNum: DWORD; - var lpDevMode: TDeviceMode): BOOL; stdcall; -{$IFDEF _D4orHigher} -function EnumDisplayDevices(Unused: Pointer; iDevNum: DWORD; - var lpDisplayDevice: TDisplayDevice; dwFlags: DWORD): BOOL; stdcall; -{$ENDIF} -function EnumProps(hWnd: HWND; lpEnumFunc: TFNPropEnumProc): Integer; stdcall; -function EnumPropsEx(hWnd: HWND; lpEnumFunc: TFNPropEnumProcEx; lParam: LPARAM): Integer; stdcall; -function EnumWindowStations(lpEnumFunc: TFNWinStaEnumProc; lParam: LPARAM): BOOL; stdcall; -function FindWindow(lpClassName, lpWindowName: PKOLChar): HWND; stdcall; -function FindWindowEx(Parent, Child: HWND; ClassName, WindowName: PKOLChar): HWND; stdcall; -{$IFDEF _D4orHigher} -function GetAltTabInfo(hwnd: HWND; iItem: Integer; var pati: TAltTabInfo; - pszItemText: PKOLChar; cchItemText: UINT): BOOL; stdcall; -{$ENDIF} -function GetClassInfo(hInstance: HINST; lpClassName: PKOLChar; - var lpWndClass: TWndClass): BOOL; stdcall; -function GetClassInfoEx(Instance: HINST; Classname: PKOLChar; var WndClass: TWndClassEx): BOOL; stdcall; -function GetClassLong(hWnd: HWND; nIndex: Integer): DWORD; stdcall; -function GetClassName(hWnd: HWND; lpClassName: PKOLChar; nMaxCount: Integer): Integer; stdcall; -function GetClipboardFormatName(format: UINT; lpszFormatName: PKOLChar; - cchMaxCount: Integer): Integer; stdcall; -function GetDlgItemText(hDlg: HWND; nIDDlgItem: Integer; - lpString: PKOLChar; nMaxCount: Integer): UINT; stdcall; -function GetKeyNameText(lParam: Longint; lpString: PKOLChar; nSize: Integer): Integer; stdcall; -function GetKeyboardLayoutName(pwszKLID: PKOLChar): BOOL; stdcall; -function GetMenuItemInfo(p1: HMENU; p2: UINT; p3: BOOL; var p4: TMenuItemInfo): BOOL; stdcall; -function GetMenuString(hMenu: HMENU; uIDItem: UINT; lpString: PKOLChar; - nMaxCount: Integer; uFlag: UINT): Integer; stdcall; -function GetMessage(var lpMsg: TMsg; hWnd: HWND; - wMsgFilterMin, wMsgFilterMax: UINT): BOOL; stdcall; -function GetProp(hWnd: HWND; lpString: PKOLChar): THandle; stdcall; -function GetTabbedTextExtent(hDC: HDC; lpString: PKOLChar; - nCount, nTabPositions: Integer; var lpnTabStopPositions): DWORD; stdcall; -function GetUserObjectInformation(hObj: THandle; nIndex: Integer; pvInfo: Pointer; - nLength: DWORD; var lpnLengthNeeded: DWORD): BOOL; stdcall; -function GetWindowLong(hWnd: HWND; nIndex: Integer): Longint; stdcall; -function GetWindowModuleFileName(hwnd: HWND; pszFileName: PKOLChar; cchFileNameMax: UINT): UINT; stdcall; -function GetWindowText(hWnd: HWND; lpString: PKOLChar; nMaxCount: Integer): Integer; stdcall; -function GetWindowTextLength(hWnd: HWND): Integer; stdcall; -function GrayString(hDC: HDC; hBrush: HBRUSH; lpOutputFunc: TFNGrayStringProc; - lpData: LPARAM; nCount, X, Y, nWidth, nHeight: Integer): BOOL; stdcall; -function InsertMenu(hMenu: HMENU; uPosition, uFlags, uIDNewItem: UINT; - lpNewItem: PKOLChar): BOOL; stdcall; -function InsertMenuItem(p1: HMENU; p2: UINT; p3: BOOL; const p4: TMenuItemInfo): BOOL; stdcall; -function IsCharAlpha(ch: KOLChar): BOOL; stdcall; -function IsCharAlphaNumeric(ch: KOLChar): BOOL; stdcall; -function IsCharLower(ch: KOLChar): BOOL; stdcall; -function IsCharUpper(ch: KOLChar): BOOL; stdcall; -function IsDialogMessage(hDlg: HWND; var lpMsg: TMsg): BOOL; stdcall; -function LoadAccelerators(hInstance: HINST; lpTableName: PKOLChar): HACCEL; stdcall; -function LoadBitmap(hInstance: HINST; lpBitmapName: PKOLChar): HBITMAP; stdcall; -function LoadCursor(hInstance: HINST; lpCursorName: PKOLChar): HCURSOR; stdcall; -function LoadCursorFromFile(lpFileName: PKOLChar): HCURSOR; stdcall; -function LoadIcon(hInstance: HINST; lpIconName: PKOLChar): HICON; stdcall; -function LoadImage(hInst: HINST; ImageName: PKOLChar; ImageType: UINT; X, Y: Integer; Flags: UINT): THandle; stdcall; -function LoadKeyboardLayout(pwszKLID: PKOLChar; Flags: UINT): HKL; stdcall; -function LoadMenu(hInstance: HINST; lpMenuName: PKOLChar): HMENU; stdcall; -function LoadMenuIndirect(lpMenuTemplate: Pointer): HMENU; stdcall; -function LoadString(hInstance: HINST; uID: UINT; lpBuffer: PKOLChar; nBufferMax: Integer): Integer; stdcall; -function MapVirtualKey(uCode, uMapType: UINT): UINT; stdcall; -function MapVirtualKeyEx(uCode, uMapType: UINT; dwhkl: HKL): UINT; stdcall; -function MessageBox(hWnd: HWND; lpText, lpCaption: PKOLChar; uType: UINT): Integer; stdcall; -function MessageBoxEx(hWnd: HWND; lpText, lpCaption: PKOLChar; - uType: UINT; wLanguageId: Word): Integer; stdcall; -function MessageBoxIndirect(const MsgBoxParams: TMsgBoxParams): BOOL; stdcall; -function ModifyMenu(hMnu: HMENU; uPosition, uFlags, uIDNewItem: UINT; - lpNewItem: PKOLChar): BOOL; stdcall; -function OemToAnsi(const lpszSrc: LPCSTR; lpszDst: LPSTR): BOOL; stdcall; -function OemToAnsiBuff(lpszSrc: LPCSTR; lpszDst: LPSTR; cchDstLength: DWORD): BOOL; stdcall; -function OemToChar(lpszSrc: PKOLChar; lpszDst: PKOLChar): BOOL; stdcall; -function OemToCharBuff(lpszSrc: PKOLChar; lpszDst: PKOLChar; cchDstLength: DWORD): BOOL; stdcall; -function OpenDesktop(lpszDesktop: PKOLChar; dwFlags: DWORD; fInherit: BOOL; - dwDesiredAccess: DWORD): HDESK; stdcall; -function OpenWindowStation(lpszWinSta: PKOLChar; fInherit: BOOL; - dwDesiredAccess: DWORD): HWINSTA; stdcall; -function PeekMessage(var lpMsg: TMsg; hWnd: HWND; - wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): BOOL; stdcall; -function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; stdcall; -function PostThreadMessage(idThread: DWORD; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; stdcall; -function RealGetWindowClass(hwnd: HWND; pszType: PKOLChar; cchType: UINT): UINT; stdcall; -function RegisterClass(const lpWndClass: TWndClass): ATOM; stdcall; -function RegisterClassEx(const WndClass: TWndClassEx): ATOM; stdcall; -function RegisterClipboardFormat(lpszFormat: PKOLChar): UINT; stdcall; -{$IFDEF _D4orHigher} -function RegisterDeviceNotification(hRecipient: THandle; NotificationFilter: Pointer; Flags: DWORD): HDEVNOTIFY; stdcall; -{$ENDIF} -function RegisterWindowMessage(lpString: PKOLChar): UINT; stdcall; -function RemoveProp(hWnd: HWND; lpString: PKOLChar): THandle; stdcall; -function SendDlgItemMessage(hDlg: HWND; nIDDlgItem: Integer; - Msg: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall; -function SendMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -function SendMessageCallback(hWnd: HWND; Msg: UINT; wParam: WPARAM; - lParam: LPARAM; lpResultCallBack: TFNSendAsyncProc; dwData: DWORD): BOOL; stdcall; -function SendMessageTimeout(hWnd: HWND; Msg: UINT; wParam: WPARAM; - lParam: LPARAM; fuFlags, uTimeout: UINT; var lpdwResult: DWORD): LRESULT; stdcall; -function SendNotifyMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; - lParam: LPARAM): BOOL; stdcall; -function SetClassLong(hWnd: HWND; nIndex: Integer; dwNewLong: Longint): DWORD; stdcall; -function SetDlgItemText(hDlg: HWND; nIDDlgItem: Integer; lpString: PKOLChar): BOOL; stdcall; -function SetMenuItemInfo(p1: HMENU; p2: UINT; p3: BOOL; const p4: TMenuItemInfo): BOOL; stdcall; -function SetProp(hWnd: HWND; lpString: PKOLChar; hData: THandle): BOOL; stdcall; -function SetUserObjectInformation(hObj: THandle; nIndex: Integer; - pvInfo: Pointer; nLength: DWORD): BOOL; stdcall; -function SetWindowLong(hWnd: HWND; nIndex: Integer; dwNewLong: Longint): Longint; stdcall; -function SetWindowText(hWnd: HWND; lpString: PKOLChar): BOOL; stdcall; -function SetWindowsHook(nFilterType: Integer; pfnFilterProc: TFNHookProc): HHOOK; stdcall; -function SetWindowsHookEx(idHook: Integer; lpfn: TFNHookProc; hmod: HINST; dwThreadId: DWORD): HHOOK; stdcall; -function SystemParametersInfo(uiAction, uiParam: UINT; - pvParam: Pointer; fWinIni: UINT): BOOL; stdcall; -function TabbedTextOut(hDC: HDC; X, Y: Integer; lpString: PKOLChar; nCount, nTabPositions: Integer; - var lpnTabStopPositions; nTabOrigin: Integer): Longint; stdcall; -function TranslateAccelerator(hWnd: HWND; hAccTable: HACCEL; var lpMsg: TMsg): Integer; stdcall; -function UnregisterClass(lpClassName: PKOLChar; hInstance: HINST): BOOL; stdcall; -function VkKeyScan(ch: KOLChar): SHORT; stdcall; -function VkKeyScanEx(ch: KOLChar; dwhkl: HKL): SHORT; stdcall; -function WinHelp(hWndMain: HWND; lpszHelp: PKOLChar; uCommand: UINT; dwData: DWORD): BOOL; stdcall; -function wsprintf(Output: PKOLChar; Format: PKOLChar): Integer; stdcall; -function wvsprintf(Output: PKOLChar; Format: PKOLChar; arglist: va_list): Integer; stdcall; -function CreateMutex(lpMutexAttributes: PSecurityAttributes; bInitialOwner: BOOL; lpName: PWideChar): THandle; - -const - IDC_ARROW = MakeIntResource(32512); - IDC_IBEAM = MakeIntResource(32513); - IDC_WAIT = MakeIntResource(32514); - IDC_CROSS = MakeIntResource(32515); - IDC_UPARROW = MakeIntResource(32516); - IDC_SIZE = MakeIntResource(32640); - IDC_ICON = MakeIntResource(32641); - IDC_SIZENWSE = MakeIntResource(32642); - IDC_SIZENESW = MakeIntResource(32643); - IDC_SIZEWE = MakeIntResource(32644); - IDC_SIZENS = MakeIntResource(32645); - IDC_SIZEALL = MakeIntResource(32646); - IDC_NO = MakeIntResource(32648); - IDC_HAND = MakeIntResource(32649); - IDC_APPSTARTING = MakeIntResource(32650); - IDC_HELP = MakeIntResource(32651); - RT_CURSOR = PKOLChar(1); - RT_BITMAP = PKOLChar(2); - RT_ICON = PKOLChar(3); - RT_MENU = PKOLChar(4); - RT_DIALOG = PKOLChar(5); - RT_STRING = PKOLChar(6); - RT_FONTDIR = PKOLChar(7); - RT_FONT = PKOLChar(8); - RT_ACCELERATOR = PKOLChar(9); - RT_RCDATA = PKOLChar(10); - RT_MESSAGETABLE = PKOLChar(11); - RT_VERSION = PKOLChar(16); - RT_DLGINCLUDE = PKOLChar(17); - RT_PLUGPLAY = PKOLChar(19); - RT_VXD = PKOLChar(20); - RT_ANICURSOR = PKOLChar(21); - RT_ANIICON = PKOLChar(22); - -{$ENDIF interface_part} //////////////////////////////////////////////////////// - -{$IFDEF implementation_part} /////////////////////////////////////////////////// -function AbortSystemShutdown; external advapi32 name 'AbortSystemShutdownW'; -function AccessCheckAndAuditAlarm; external advapi32 name 'AccessCheckAndAuditAlarmW'; -{$IFDEF _D4orHigher} -function AccessCheckByTypeAndAuditAlarm; external advapi32 name 'AccessCheckByTypeAndAuditAlarmW'; -function AccessCheckByTypeResultListAndAuditAlarm; external advapi32 name 'AccessCheckByTypeResultListAndAuditAlarmW'; -{$ENDIF} -function BackupEventLog; external advapi32 name 'BackupEventLogW'; -function ClearEventLog; external advapi32 name 'ClearEventLogW'; -function CreateProcessAsUser; external advapi32 name 'CreateProcessAsUserW'; -function GetCurrentHwProfile; external advapi32 name 'GetCurrentHwProfileW'; -function GetFileSecurity; external advapi32 name 'GetFileSecurityW'; -function GetUserName; external advapi32 name 'GetUserNameW'; -function InitiateSystemShutdown; external advapi32 name 'InitiateSystemShutdownW'; -function LogonUser; external advapi32 name 'LogonUserW'; -function LookupAccountName; external advapi32 name 'LookupAccountNameW'; -function LookupAccountSid; external advapi32 name 'LookupAccountSidW'; -function LookupPrivilegeDisplayName; external advapi32 name 'LookupPrivilegeDisplayNameW'; -function LookupPrivilegeName; external advapi32 name 'LookupPrivilegeNameW'; -function LookupPrivilegeValue; external advapi32 name 'LookupPrivilegeValueW'; -function ObjectCloseAuditAlarm; external advapi32 name 'ObjectCloseAuditAlarmW'; -function ObjectDeleteAuditAlarm; external advapi32 name 'ObjectDeleteAuditAlarmW'; -function ObjectOpenAuditAlarm; external advapi32 name 'ObjectOpenAuditAlarmW'; -function ObjectPrivilegeAuditAlarm; external advapi32 name 'ObjectPrivilegeAuditAlarmW'; -function OpenBackupEventLog; external advapi32 name 'OpenBackupEventLogW'; -function OpenEventLog; external advapi32 name 'OpenEventLogW'; -function PrivilegedServiceAuditAlarm; external advapi32 name 'PrivilegedServiceAuditAlarmW'; -function ReadEventLog; external advapi32 name 'ReadEventLogW'; -function RegConnectRegistry; external advapi32 name 'RegConnectRegistryW'; -function RegCreateKey; external advapi32 name 'RegCreateKeyW'; -function RegCreateKeyEx; external advapi32 name 'RegCreateKeyExW'; -function RegDeleteKey; external advapi32 name 'RegDeleteKeyW'; -function RegDeleteValue; external advapi32 name 'RegDeleteValueW'; -function RegEnumKeyEx; external advapi32 name 'RegEnumKeyExW'; -function RegEnumKey; external advapi32 name 'RegEnumKeyW'; -function RegEnumValue; external advapi32 name 'RegEnumValueW'; -function RegLoadKey; external advapi32 name 'RegLoadKeyW'; -function RegOpenKey; external advapi32 name 'RegOpenKeyW'; -function RegOpenKeyEx; external advapi32 name 'RegOpenKeyExW'; -function RegQueryInfoKey; external advapi32 name 'RegQueryInfoKeyW'; -function RegQueryMultipleValues; external advapi32 name 'RegQueryMultipleValuesW'; -function RegQueryValue; external advapi32 name 'RegQueryValueW'; -function RegQueryValueEx; external advapi32 name 'RegQueryValueExW'; -function RegReplaceKey; external advapi32 name 'RegReplaceKeyW'; -function RegRestoreKey; external advapi32 name 'RegRestoreKeyW'; -function RegSaveKey; external advapi32 name 'RegSaveKeyW'; -function RegSetValue; external advapi32 name 'RegSetValueW'; -function RegSetValueEx; external advapi32 name 'RegSetValueExW'; -function RegUnLoadKey; external advapi32 name 'RegUnLoadKeyW'; -function RegisterEventSource; external advapi32 name 'RegisterEventSourceW'; -function ReportEvent; external advapi32 name 'ReportEventW'; -function SetFileSecurity; external advapi32 name 'SetFileSecurityW'; -function AddAtom; external kernel32 name 'AddAtomW'; -function BeginUpdateResource; external kernel32 name 'BeginUpdateResourceW'; -function BuildCommDCB; external kernel32 name 'BuildCommDCBW'; -function BuildCommDCBAndTimeouts; external kernel32 name 'BuildCommDCBAndTimeoutsW'; -function CallNamedPipe; external kernel32 name 'CallNamedPipeW'; -function CommConfigDialog; external kernel32 name 'CommConfigDialogW'; -function CompareString; external kernel32 name 'CompareStringW'; -function CopyFile; external kernel32 name 'CopyFileW'; -function CopyFileEx; external kernel32 name 'CopyFileExW'; -function CreateDirectory; external kernel32 name 'CreateDirectoryW'; -function CreateDirectoryEx; external kernel32 name 'CreateDirectoryExW'; -function CreateEvent; external kernel32 name 'CreateEventW'; -function CreateFile; external kernel32 name 'CreateFileW'; -function CreateFileMapping; external kernel32 name 'CreateFileMappingW'; -function CreateHardLink; external kernel32 name 'CreateHardLinkW'; -function CreateMailslot; external kernel32 name 'CreateMailslotW'; -function CreateNamedPipe; external kernel32 name 'CreateNamedPipeW'; -function CreateProcess; external kernel32 name 'CreateProcessW'; -function CreateSemaphore; external kernel32 name 'CreateSemaphoreW'; -function CreateWaitableTimer; external kernel32 name 'CreateWaitableTimerW'; -function DefineDosDevice; external kernel32 name 'DefineDosDeviceW'; -function DeleteFile; external kernel32 name 'DeleteFileW'; -function EndUpdateResource; external kernel32 name 'EndUpdateResourceW'; -function EnumCalendarInfo; external kernel32 name 'EnumCalendarInfoW'; -function EnumDateFormats; external kernel32 name 'EnumDateFormatsW'; -function EnumResourceLanguages; external kernel32 name 'EnumResourceLanguagesW'; -function EnumResourceNames; external kernel32 name 'EnumResourceNamesW'; -function EnumResourceTypes; external kernel32 name 'EnumResourceTypesW'; -function EnumSystemCodePages; external kernel32 name 'EnumSystemCodePagesW'; -function EnumSystemLocales; external kernel32 name 'EnumSystemLocalesW'; -function EnumTimeFormats; external kernel32 name 'EnumTimeFormatsW'; -function ExpandEnvironmentStrings; external kernel32 name 'ExpandEnvironmentStringsW'; -procedure FatalAppExit; external kernel32 name 'FatalAppExitW'; -function FillConsoleOutputCharacter; external kernel32 name 'FillConsoleOutputCharacterW'; -function FindAtom; external kernel32 name 'FindAtomW'; -function FindFirstChangeNotification; external kernel32 name 'FindFirstChangeNotificationW'; -function FindFirstFile; external kernel32 name 'FindFirstFileW'; -function FindFirstFileEx; external kernel32 name 'FindFirstFileExW'; -function FindNextFile; external kernel32 name 'FindNextFileW'; -function FindResource; external kernel32 name 'FindResourceW'; -function FindResourceEx; external kernel32 name 'FindResourceExW'; -function FoldString; external kernel32 name 'FoldStringW'; -function FormatMessage; external kernel32 name 'FormatMessageW'; -function FreeEnvironmentStrings; external kernel32 name 'FreeEnvironmentStringsW'; -function GetAtomName; external kernel32 name 'GetAtomNameW'; -function GetBinaryType; external kernel32 name 'GetBinaryTypeW'; -function GetCommandLine; external kernel32 name 'GetCommandLineW'; -function GetCompressedFileSize; external kernel32 name 'GetCompressedFileSizeW'; -function GetComputerName; external kernel32 name 'GetComputerNameW'; -function GetConsoleTitle; external kernel32 name 'GetConsoleTitleW'; -function GetCurrencyFormat; external kernel32 name 'GetCurrencyFormatW'; -function GetCurrentDirectory; external kernel32 name 'GetCurrentDirectoryW'; -function GetDateFormat; external kernel32 name 'GetDateFormatW'; -function GetDefaultCommConfig; external kernel32 name 'GetDefaultCommConfigW'; -function GetDiskFreeSpace; external kernel32 name 'GetDiskFreeSpaceW'; -function GetDiskFreeSpaceEx; external kernel32 name 'GetDiskFreeSpaceExW'; -function GetDriveType; external kernel32 name 'GetDriveTypeW'; -function GetEnvironmentStrings; external kernel32 name 'GetEnvironmentStringsW'; -function GetEnvironmentVariable(lpName: PKOLChar; lpBuffer: PKOLChar; - nSize: DWORD): DWORD; external kernel32 name 'GetEnvironmentVariableW'; -function GetFileAttributes; external kernel32 name 'GetFileAttributesW'; -function GetFileAttributesEx; external kernel32 name 'GetFileAttributesExW'; -function GetFullPathName; external kernel32 name 'GetFullPathNameW'; -function GetLocaleInfo; external kernel32 name 'GetLocaleInfoW'; -function GetLogicalDriveStrings; external kernel32 name 'GetLogicalDriveStringsW'; -function GetModuleFileName; external kernel32 name 'GetModuleFileNameW'; -function GetModuleHandle; external kernel32 name 'GetModuleHandleW'; -function GetNamedPipeHandleState; external kernel32 name 'GetNamedPipeHandleStateW'; -function GetNumberFormat; external kernel32 name 'GetNumberFormatW'; -function GetPrivateProfileInt; external kernel32 name 'GetPrivateProfileIntW'; -function GetPrivateProfileSection; external kernel32 name 'GetPrivateProfileSectionW'; -function GetPrivateProfileSectionNames; external kernel32 name 'GetPrivateProfileSectionNamesW'; -function GetPrivateProfileString; external kernel32 name 'GetPrivateProfileStringW'; -function GetProfileInt; external kernel32 name 'GetProfileIntW'; -function GetProfileSection; external kernel32 name 'GetProfileSectionW'; -function GetProfileString; external kernel32 name 'GetProfileStringW'; -function GetShortPathName; external kernel32 name 'GetShortPathNameW'; -procedure GetStartupInfo; external kernel32 name 'GetStartupInfoW'; -function GetStringTypeEx; external kernel32 name 'GetStringTypeExW'; -function GetSystemDirectory; external kernel32 name 'GetSystemDirectoryW'; -function GetTempFileName; external kernel32 name 'GetTempFileNameW'; -function GetTempPath; external kernel32 name 'GetTempPathW'; -function GetTimeFormat; external kernel32 name 'GetTimeFormatW'; -function GetVersionEx; external kernel32 name 'GetVersionExW'; -function GetVolumeInformation; external kernel32 name 'GetVolumeInformationW'; -function GetWindowsDirectory; external kernel32 name 'GetWindowsDirectoryW'; -function GlobalAddAtom; external kernel32 name 'GlobalAddAtomW'; -function GlobalFindAtom; external kernel32 name 'GlobalFindAtomW'; -function GlobalGetAtomName; external kernel32 name 'GlobalGetAtomNameW'; -function IsBadStringPtr; external kernel32 name 'IsBadStringPtrW'; -function LCMapString; external kernel32 name 'LCMapStringW'; -function LoadLibrary; external kernel32 name 'LoadLibraryW'; -function LoadLibraryEx; external kernel32 name 'LoadLibraryExW'; -function MoveFile; external kernel32 name 'MoveFileW'; -function MoveFileEx; external kernel32 name 'MoveFileExW'; -function MoveFileWithProgress; external kernel32 name 'MoveFileWithProgressW'; -function OpenEvent; external kernel32 name 'OpenEventW'; -function OpenFileMapping; external kernel32 name 'OpenFileMappingW'; -function OpenMutex; external kernel32 name 'OpenMutexW'; -function OpenSemaphore; external kernel32 name 'OpenSemaphoreW'; -function OpenWaitableTimer; external kernel32 name 'OpenWaitableTimerW'; -procedure OutputDebugString; external kernel32 name 'OutputDebugStringW'; -function PeekConsoleInput; external kernel32 name 'PeekConsoleInputW'; -function QueryDosDevice; external kernel32 name 'QueryDosDeviceW'; -{$IFDEF _D4orHigher} -function QueryRecoveryAgents; external kernel32 name 'QueryRecoveryAgentsW'; -{$ENDIF} -function ReadConsole; external kernel32 name 'ReadConsoleW'; -function ReadConsoleInput; external kernel32 name 'ReadConsoleInputW'; -function ReadConsoleOutput; external kernel32 name 'ReadConsoleOutputW'; -function ReadConsoleOutputCharacter; external kernel32 name 'ReadConsoleOutputCharacterW'; -function RemoveDirectory; external kernel32 name 'RemoveDirectoryW'; -function ScrollConsoleScreenBuffer; external kernel32 name 'ScrollConsoleScreenBufferW'; -function SearchPath; external kernel32 name 'SearchPathW'; -function SetComputerName; external kernel32 name 'SetComputerNameW'; -function SetConsoleTitle; external kernel32 name 'SetConsoleTitleW'; -function SetCurrentDirectory; external kernel32 name 'SetCurrentDirectoryW'; -function SetDefaultCommConfig; external kernel32 name 'SetDefaultCommConfigW'; -function SetEnvironmentVariable; external kernel32 name 'SetEnvironmentVariableW'; -function SetFileAttributes; external kernel32 name 'SetFileAttributesW'; -function SetLocaleInfo; external kernel32 name 'SetLocaleInfoW'; -function SetVolumeLabel; external kernel32 name 'SetVolumeLabelW'; -function UpdateResource; external kernel32 name 'UpdateResourceW'; -function VerLanguageName; external kernel32 name 'VerLanguageNameW'; -function WaitNamedPipe; external kernel32 name 'WaitNamedPipeW'; -function WriteConsole; external kernel32 name 'WriteConsoleW'; -function WriteConsoleInput; external kernel32 name 'WriteConsoleInputW'; -function WriteConsoleOutput; external kernel32 name 'WriteConsoleOutputW'; -function WriteConsoleOutputCharacter; external kernel32 name 'WriteConsoleOutputCharacterW'; -function WritePrivateProfileSection; external kernel32 name 'WritePrivateProfileSectionW'; -function WritePrivateProfileString; external kernel32 name 'WritePrivateProfileStringW'; -function WriteProfileSection; external kernel32 name 'WriteProfileSectionW'; -function WriteProfileString; external kernel32 name 'WriteProfileStringW'; -function lstrcat; external kernel32 name 'lstrcatW'; -function lstrcmp; external kernel32 name 'lstrcmpW'; -function lstrcmpi; external kernel32 name 'lstrcmpiW'; -function lstrcpy; external kernel32 name 'lstrcpyW'; -function lstrcpyn; external kernel32 name 'lstrcpynW'; -function lstrlen; external kernel32 name 'lstrlenW'; -function MultinetGetConnectionPerformance; external mpr name 'MultinetGetConnectionPerformanceW'; -function WNetAddConnection2; external mpr name 'WNetAddConnection2W'; -function WNetAddConnection3; external mpr name 'WNetAddConnection3W'; -function WNetAddConnection; external mpr name 'WNetAddConnectionW'; -function WNetCancelConnection2; external mpr name 'WNetCancelConnection2W'; -function WNetCancelConnection; external mpr name 'WNetCancelConnectionW'; -function WNetConnectionDialog1; external mpr name 'WNetConnectionDialog1W'; -function WNetDisconnectDialog1; external mpr name 'WNetDisconnectDialog1W'; -function WNetEnumResource; external mpr name 'WNetEnumResourceW'; -function WNetGetConnection; external mpr name 'WNetGetConnectionW'; -function WNetGetLastError; external mpr name 'WNetGetLastErrorW'; -function WNetGetNetworkInformation; external mpr name 'WNetGetNetworkInformationW'; -function WNetGetProviderName; external mpr name 'WNetGetProviderNameW'; -function WNetGetResourceParent; external mpr name 'WNetGetResourceParentW'; -function WNetGetUniversalName; external mpr name 'WNetGetUniversalNameW'; -function WNetGetUser; external mpr name 'WNetGetUserW'; -function WNetOpenEnum; external mpr name 'WNetOpenEnumW'; -function WNetSetConnection; external mpr name 'WNetSetConnectionW'; -function WNetUseConnection; external mpr name 'WNetUseConnectionW'; -function GetFileVersionInfo; external version name 'GetFileVersionInfoW'; -function GetFileVersionInfoSize; external version name 'GetFileVersionInfoSizeW'; -function VerFindFile; external version name 'VerFindFileW'; -function VerInstallFile; external version name 'VerInstallFileW'; -function VerQueryValue; external version name 'VerQueryValueW'; -function GetPrivateProfileStruct; external kernel32 name 'GetPrivateProfileStructW'; -function WritePrivateProfileStruct; external kernel32 name 'WritePrivateProfileStructW'; -function AddFontResource; external gdi32 name 'AddFontResourceW'; -{$IFDEF _D4orHigher} -function AddFontResourceEx; external gdi32 name 'AddFontResourceExW'; -{$ENDIF} -function CopyEnhMetaFile; external gdi32 name 'CopyEnhMetaFileW'; -function CopyMetaFile; external gdi32 name 'CopyMetaFileW'; -function CreateColorSpace; external gdi32 name 'CreateColorSpaceW'; -function CreateDC; external gdi32 name 'CreateDCW'; -function CreateEnhMetaFile; external gdi32 name 'CreateEnhMetaFileW'; -function CreateFont; external gdi32 name 'CreateFontW'; -function CreateFontIndirect; external gdi32 name 'CreateFontIndirectW'; -{$IFDEF _D4orHigher} -function CreateFontIndirectEx; external gdi32 name 'CreateFontIndirectExW'; -{$ENDIF} -function CreateIC; external gdi32 name 'CreateICW'; -function CreateMetaFile; external gdi32 name 'CreateMetaFileW'; -function CreateScalableFontResource; external gdi32 name 'CreateScalableFontResourceW'; -function DeviceCapabilities; external gdi32 name 'DeviceCapabilitiesW'; -function EnumFontFamilies; external gdi32 name 'EnumFontFamiliesW'; -function EnumFontFamiliesEx; external gdi32 name 'EnumFontFamiliesExW'; -function EnumFonts; external gdi32 name 'EnumFontsW'; -function EnumICMProfiles; external gdi32 name 'EnumICMProfilesW'; -function ExtTextOut; external gdi32 name 'ExtTextOutW'; -function GetCharABCWidths; external gdi32 name 'GetCharABCWidthsW'; -function GetCharABCWidthsFloat; external gdi32 name 'GetCharABCWidthsFloatW'; -function GetCharWidth32; external gdi32 name 'GetCharWidth32W'; -function GetCharWidth; external gdi32 name 'GetCharWidthW'; -function GetCharWidthFloat; external gdi32 name 'GetCharWidthFloatW'; -function GetCharacterPlacement; external gdi32 name 'GetCharacterPlacementW'; -function GetEnhMetaFile; external gdi32 name 'GetEnhMetaFileW'; -function GetEnhMetaFileDescription; external gdi32 name 'GetEnhMetaFileDescriptionW'; -function GetGlyphIndices; external gdi32 name 'GetGlyphIndicesW'; -function GetGlyphOutline; external gdi32 name 'GetGlyphOutlineW'; -function GetICMProfile; external gdi32 name 'GetICMProfileW'; -function GetLogColorSpace; external gdi32 name 'GetLogColorSpaceW'; -function GetMetaFile; external gdi32 name 'GetMetaFileW'; -function GetObject; external gdi32 name 'GetObjectW'; -function GetOutlineTextMetrics; external gdi32 name 'GetOutlineTextMetricsW'; -function GetTextExtentExPoint; external gdi32 name 'GetTextExtentExPointW'; -function GetTextExtentPoint32; external gdi32 name 'GetTextExtentPoint32W'; -function GetTextExtentPoint; external gdi32 name 'GetTextExtentPointW'; -function GetTextFace; external gdi32 name 'GetTextFaceW'; -function GetTextMetrics; external gdi32 name 'GetTextMetricsW'; -function PolyTextOut; external gdi32 name 'PolyTextOutW'; -function RemoveFontResource; external gdi32 name 'RemoveFontResourceW'; -{$IFDEF _D4orHigher} -function RemoveFontResourceEx; external gdi32 name 'RemoveFontResourceExW'; -{$ENDIF} -function ResetDC; external gdi32 name 'ResetDCW'; -function SetICMProfile; external gdi32 name 'SetICMProfileW'; -function StartDoc; external gdi32 name 'StartDocW'; -function TextOut; external gdi32 name 'TextOutW'; -function UpdateICMRegKey; external gdi32 name 'UpdateICMRegKeyW'; -function wglUseFontBitmaps; external opengl32 name 'wglUseFontBitmapsW'; -function wglUseFontOutlines; external opengl32 name 'wglUseFontOutlinesW'; -function AnsiToOem; external user32 name 'CharToOemW'; -function AnsiToOemBuff; external user32 name 'CharToOemBuffW'; -function AnsiUpper; external user32 name 'CharUpperW'; -function AnsiUpperBuff; external user32 name 'CharUpperBuffW'; -function AnsiLower; external user32 name 'CharLowerW'; -function AnsiLowerBuff; external user32 name 'CharLowerBuffW'; -function AnsiNext; external user32 name 'CharNextW'; -function AnsiPrev; external user32 name 'CharPrevW'; -function AppendMenu; external user32 name 'AppendMenuW'; -//function BroadcastSystemMessage; external user32 name 'BroadcastSystemMessageW'; -//function BroadcastSystemMessageW; external user32 name 'BroadcastSystemMessageW'; -function CallMsgFilter; external user32 name 'CallMsgFilterW'; -function CallWindowProc; external user32 name 'CallWindowProcW'; -function ChangeDisplaySettings; external user32 name 'ChangeDisplaySettingsW'; -function ChangeDisplaySettingsEx; external user32 name 'ChangeDisplaySettingsExW'; -function ChangeMenu; external user32 name 'ChangeMenuW'; -function CharLower; external user32 name 'CharLowerW'; -function CharLowerBuff; external user32 name 'CharLowerBuffW'; -function CharNext; external user32 name 'CharNextW'; -function CharNextEx; external user32 name 'CharNextExW'; -function CharPrev; external user32 name 'CharPrevW'; -function CharPrevEx; external user32 name 'CharPrevExW'; -function CharToOem; external user32 name 'CharToOemW'; -function CharToOemBuff; external user32 name 'CharToOemBuffW'; -function CharUpper; external user32 name 'CharUpperW'; -function CharUpperBuff; external user32 name 'CharUpperBuffW'; -function CopyAcceleratorTable; external user32 name 'CopyAcceleratorTableW'; -function CreateAcceleratorTable; external user32 name 'CreateAcceleratorTableW'; -function CreateDesktop; external user32 name 'CreateDesktopW'; -function CreateDialogIndirectParam; external user32 name 'CreateDialogIndirectParamW'; -function CreateDialogParam; external user32 name 'CreateDialogParamW'; -function CreateMDIWindow; external user32 name 'CreateMDIWindowW'; -function CreateWindowEx; external user32 name 'CreateWindowExW'; -function CreateWindowStation; external user32 name 'CreateWindowStationW'; -function DefDlgProc; external user32 name 'DefDlgProcW'; -function DefFrameProc; external user32 name 'DefFrameProcW'; -function DefMDIChildProc; external user32 name 'DefMDIChildProcW'; -function DefWindowProc; external user32 name 'DefWindowProcW'; -function DialogBoxIndirectParam; external user32 name 'DialogBoxIndirectParamW'; -function DialogBoxParam; external user32 name 'DialogBoxParamW'; -function DispatchMessage; external user32 name 'DispatchMessageW'; -function DlgDirList; external user32 name 'DlgDirListW'; -function DlgDirListComboBox; external user32 name 'DlgDirListComboBoxW'; -function DlgDirSelectComboBoxEx; external user32 name 'DlgDirSelectComboBoxExW'; -function DlgDirSelectEx; external user32 name 'DlgDirSelectExW'; -function DrawState; external user32 name 'DrawStateW'; -function DrawText; external user32 name 'DrawTextW'; -function DrawTextEx; external user32 name 'DrawTextExW'; -function EnumDesktops; external user32 name 'EnumDesktopsW'; -function EnumDisplaySettings; external user32 name 'EnumDisplaySettingsW'; -{$IFDEF _D4orHigher} -function EnumDisplayDevices; external user32 name 'EnumDisplayDevicesW'; -{$ENDIF} -function EnumProps; external user32 name 'EnumPropsW'; -function EnumPropsEx; external user32 name 'EnumPropsExW'; -function EnumWindowStations; external user32 name 'EnumWindowStationsW'; -function FindWindow; external user32 name 'FindWindowW'; -function FindWindowEx; external user32 name 'FindWindowExW'; -{$IFDEF _D4orHigher} -function GetAltTabInfo; external user32 name 'GetAltTabInfoW'; -{$ENDIF} -function GetClassInfo; external user32 name 'GetClassInfoW'; -function GetClassInfoEx; external user32 name 'GetClassInfoExW'; -function GetClassLong; external user32 name 'GetClassLongW'; -function GetClassName; external user32 name 'GetClassNameW'; -function GetClipboardFormatName; external user32 name 'GetClipboardFormatNameW'; -function GetDlgItemText; external user32 name 'GetDlgItemTextW'; -function GetKeyNameText; external user32 name 'GetKeyNameTextW'; -function GetKeyboardLayoutName; external user32 name 'GetKeyboardLayoutNameW'; -function GetMenuItemInfo; external user32 name 'GetMenuItemInfoW'; -function GetMenuString; external user32 name 'GetMenuStringW'; -function GetMessage; external user32 name 'GetMessageW'; -function GetProp; external user32 name 'GetPropW'; -function GetTabbedTextExtent; external user32 name 'GetTabbedTextExtentW'; -function GetUserObjectInformation; external user32 name 'GetUserObjectInformationW'; -function GetWindowLong; external user32 name 'GetWindowLongW'; -function GetWindowModuleFileName; external user32 name 'GetWindowModuleFileNameW'; -function GetWindowText; external user32 name 'GetWindowTextW'; -function GetWindowTextLength; external user32 name 'GetWindowTextLengthW'; -function GrayString; external user32 name 'GrayStringW'; -function InsertMenu; external user32 name 'InsertMenuW'; -function InsertMenuItem; external user32 name 'InsertMenuItemW'; -function IsCharAlpha; external user32 name 'IsCharAlphaW'; -function IsCharAlphaNumeric; external user32 name 'IsCharAlphaNumericW'; -function IsCharLower; external user32 name 'IsCharLowerW'; -function IsCharUpper; external user32 name 'IsCharUpperW'; -function IsDialogMessage; external user32 name 'IsDialogMessageW'; -function LoadAccelerators; external user32 name 'LoadAcceleratorsW'; -function LoadBitmap; external user32 name 'LoadBitmapW'; -function LoadCursor; external user32 name 'LoadCursorW'; -function LoadCursorFromFile; external user32 name 'LoadCursorFromFileW'; -function LoadIcon; external user32 name 'LoadIconW'; -function LoadImage; external user32 name 'LoadImageW'; -function LoadKeyboardLayout; external user32 name 'LoadKeyboardLayoutW'; -function LoadMenu; external user32 name 'LoadMenuW'; -function LoadMenuIndirect; external user32 name 'LoadMenuIndirectW'; -function LoadString; external user32 name 'LoadStringW'; -function MapVirtualKey; external user32 name 'MapVirtualKeyW'; -function MapVirtualKeyEx; external user32 name 'MapVirtualKeyExW'; -function MessageBox; external user32 name 'MessageBoxW'; -function MessageBoxEx; external user32 name 'MessageBoxExW'; -function MessageBoxIndirect; external user32 name 'MessageBoxIndirectW'; -function ModifyMenu; external user32 name 'ModifyMenuW'; -function OemToAnsi; external user32 name 'OemToCharW'; -function OemToAnsiBuff; external user32 name 'OemToCharBuffW'; -function OemToChar; external user32 name 'OemToCharW'; -function OemToCharBuff; external user32 name 'OemToCharBuffW'; -function OpenDesktop; external user32 name 'OpenDesktopW'; -function OpenWindowStation; external user32 name 'OpenWindowStationW'; -function PeekMessage; external user32 name 'PeekMessageW'; -function PostMessage; external user32 name 'PostMessageW'; -function PostThreadMessage; external user32 name 'PostThreadMessageW'; -function RealGetWindowClass; external user32 name 'RealGetWindowClassW'; -function RegisterClass; external user32 name 'RegisterClassW'; -function RegisterClassEx; external user32 name 'RegisterClassExW'; -function RegisterClipboardFormat; external user32 name 'RegisterClipboardFormatW'; -{$IFDEF _D4orHigher} -function RegisterDeviceNotification; external user32 name 'RegisterDeviceNotificationW'; -{$ENDIF} -function RegisterWindowMessage; external user32 name 'RegisterWindowMessageW'; -function RemoveProp; external user32 name 'RemovePropW'; -function SendDlgItemMessage; external user32 name 'SendDlgItemMessageW'; -function SendMessage; external user32 name 'SendMessageW'; -function SendMessageCallback; external user32 name 'SendMessageCallbackW'; -function SendMessageTimeout; external user32 name 'SendMessageTimeoutW'; -function SendNotifyMessage; external user32 name 'SendNotifyMessageW'; -function SetClassLong; external user32 name 'SetClassLongW'; -function SetDlgItemText; external user32 name 'SetDlgItemTextW'; -function SetMenuItemInfo; external user32 name 'SetMenuItemInfoW'; -function SetProp; external user32 name 'SetPropW'; -function SetUserObjectInformation; external user32 name 'SetUserObjectInformationW'; -function SetWindowLong; external user32 name 'SetWindowLongW'; -function SetWindowText; external user32 name 'SetWindowTextW'; -function SetWindowsHook; external user32 name 'SetWindowsHookW'; -function SetWindowsHookEx; external user32 name 'SetWindowsHookExW'; -function SystemParametersInfo; external user32 name 'SystemParametersInfoW'; -function TabbedTextOut; external user32 name 'TabbedTextOutW'; -function TranslateAccelerator; external user32 name 'TranslateAcceleratorW'; -function UnregisterClass; external user32 name 'UnregisterClassW'; -function VkKeyScan; external user32 name 'VkKeyScanW'; -function VkKeyScanEx; external user32 name 'VkKeyScanExW'; -function WinHelp; external user32 name 'WinHelpW'; -function wsprintf; external user32 name 'wsprintfW'; -function wvsprintf; external user32 name 'wvsprintfW'; -// NT 4.0 bug workaround - NT 4.0 doesn't test bInitialOwner for zero/nonzero, it tests for 1 -function _CreateMutex(lpMutexAttributes: PSecurityAttributes; - bInitialOwner: Integer; lpName: PWideChar): THandle; stdcall; - external kernel32 name 'CreateMutexW'; -function CreateMutex(lpMutexAttributes: PSecurityAttributes; bInitialOwner: BOOL; lpName: PWideChar): THandle; -begin - Result := _CreateMutex(lpMutexAttributes, Integer(Boolean(bInitialOwner)), lpName); -end; -{$ENDIF implementation_part} /////////////////////////////////////////////////// diff --git a/plugins/ImportTXT/kol/LICENSE.txt b/plugins/ImportTXT/kol/LICENSE.txt deleted file mode 100644 index 44ce85874a..0000000000 --- a/plugins/ImportTXT/kol/LICENSE.txt +++ /dev/null @@ -1,150 +0,0 @@ -KOL&MCK Library Software License Agreement - -BEFORE PROCEEDING WITH THE INSTALLATION -AND/OR USE OF THIS SOFTWARE, CAREFULLY -READ THE FOLLOWING TERMS AND CONDITIONS -OF THIS LICENSE AGREEMENT AND LIMITED -WARRANTY (The "Agreement"). - -BY INSTALLING OR USING THIS SOFTWARE YOU -INDICATE YOUR ACCEPTANCE OF THIS -AGREEMENT. IF YOU DO NOT ACCEPT OR AGREE -WITH THESE TERMS, YOU MAY NOT INSTALL OR -USE THIS SOFTWARE! - -PREAMBLE - -The terms and conditions of the KOL&MCK -Library Software License Agreement have -one major goal in mind; to foster a development -community based around the KOL (Key Objects -Library) and MCK (Mirror Classes Kit for KOL) -and associated source code. -KOL&MCK Library does however reserve the -right as the sole distributor of the library -source code. Hence although I encourage -you to change and modify the library to -suit your needs, you may not distribute -derivative works based on the library -source code without express written -permission from KOL&MCK Library author. -Worthwhile changes and modifications to -the libraries may be submitted to KOL&MCK -Library author for integration into a -future release of the product. - -LICENSE - -This software, including documentation, -source code, object code and/or additional -materials (the "Software") is owned by -KOL&MCK author. -This Agreement does not provide you with -title or ownership of Product, but only a -right of limited use as outlined in this -license agreement. KOL&MCK Library author -hereby grant you a non-exclusive, -royalty free license to use the Software -as set forth below: - - . integrate the Software with your - Applications or DLLs, subject to the - redistribution terms below. - . modify or adapt the Software in whole - or in part for the development of - Applications based on the Software. - . use portions of the KOL&MCK Library - source code or KOL&MCK Library Demo - Programs in your own products and - libraries. - -REDISTRIBUTION RIGHTS - -You are granted a non-exclusive, -royalty-free right to reproduce and -redistribute executable files created -using the Software (the "Executable Code") -in conjunction with software products that -you develop and/or market (the -"Applications"). - -RESTRICTIONS - -Without the expressed, written consent of -KOL&MCK Library author, you may NOT: - - . distribute modified versions of the - Software, in whole or in part without - providing an information about it for - your customers (such information - must refer to any Copyright and legal - notes on portions of Software distributed, - version information on Software used - to redistribute, notes on changes - made, if any, and must include any - necessary information to provide a chance - for your customers to find and re-use - the original Software if they want to - do so). - . rent or lease the Software. - . sell any portion of the Software on - its own, without integrating it into - your Applications or DLLs as Executable - Code. - -SELECTION AND USE - -You assume full responsibility for the -selection of the Software to achieve your -intended results and for the installation, -use and results obtained from the Software. - -LIMITED WARRANTY - -THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT -WARRANTY OF ANY KIND EITHER EXPRESSED OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE -IMPLIED WARRANTIES MERCHANTIBILITY AND -FITNESS FOR A PARTICULAR PURPOSE. THE -ENTIRE RISK AS TO THE QUALITY AND -PERFORMANCE OF THE PRODUCT IS WITH YOU. -SHOULD THE PRODUCT PROVE DEFECTIVE, YOU -ASSUME THE COST OF ALL NECESSARY SERVICING -OR ERROR CORRECTION. - -KOL&MCK LIBRARY AUTHOR DO NOT WARRANT THAT -THE FUNCTIONS CONTAINED IN THE SOFTWARE -WILL MEET YOUR REQUIREMENTS OR THAT THE -OPERATION OF THE SOFTWARE WILL BE -UNINTERRUPTED OR ERROR FREE. - -No oral or written information given by -KOL&MCK Library shall create a warranty. - -LIMITATION OF REMEDIES AND LIABILITY. - -IN NO EVENT SHALL KOL&MCK LIBRARY AUTHOR, OR -ANY OTHER PARTY WHO MAY HAVE DISTRIBUTED -THE SOFTWARE AS PERMITTED ABOVE, BE LIABLE -FOR DAMAGES, INCLUDING ANY GENERAL, -SPECIAL, INCIDENTAL, OR CONSEQUENTIAL -DAMAGES ARISING OUT OF THE USE OR -INABILITY TO USE THE SOFTWARE (INCLUDING -BUT NOT LIMITED TO LOSS OF DATA OR DATA -BEING RENDERED INACCURATE OR LOSSES -SUSTAINED BY YOU OR THIRD PARTIES OR -FAILURE OF THE SOFTWARE TO OPERATE WITH -ANY OTHER PRODUCTS), EVEN IF SUCH HOLDER -OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - -If you have any questions regarding this -agreement, please contact KOL&MCK Library -author at his e-mail addresses: - - vk@kolmck.net - bonanzas@online.sinor.ru - -KOL&MCK Library Web Site: - http://www.kolmck.net - diff --git a/plugins/ImportTXT/kol/MCKfakeClasses.inc b/plugins/ImportTXT/kol/MCKfakeClasses.inc deleted file mode 100644 index 5483d42442..0000000000 --- a/plugins/ImportTXT/kol/MCKfakeClasses.inc +++ /dev/null @@ -1,79 +0,0 @@ -{ - KOL MCK (C) 2000 by Vladimir Kladov - - MCKfakeClasses.inc - - This file redefines mirror class types to PControl / PObj - to use it by Delphi compiler - while compiling mirror KOL - project. At design time these definitions are not visible - for Delphi IDE because of conditional compiling directives. -} - -{$I KOLDEF.INC} -{$IFNDEF FPC} -{$IFDEF _D7orHigher} - {$WARN UNSAFE_TYPE OFF} // Too many such warnings in Delphi7 - {$WARN UNSAFE_CODE OFF} - {$WARN UNSAFE_CAST OFF} -{$ENDIF} -{$ENDIF} - - TKOLProject = Pointer; - TKOLApplet = Pointer; - TKOLForm = Pointer; - TKOLDataModule = Pointer; - TKOLFrame = Pointer; - TKOLMDIClient = PControl; - TKOLMDIChild = Pointer; - TKOLService = Pointer; - TBringFront = Pointer; - - TKOLButton = PControl; - TKOLLabel = PControl; - TKOLLabelEffect = PControl; - TKOLPanel = PControl; - TKOLSplitter = PControl; - TKOLGradientPanel = PControl; - TKOLBitBtn = PControl; - TKOLGroupBox = PControl; - TKOLCheckBox = PControl; - TKOLRadioBox = PControl; - TKOLEditBox = PControl; - TKOLMemo = PControl; - TKOLListBox = PControl; - TKOLComboBox = PControl; - TKOLPaintBox = PControl; - TKOLImageShow = PControl; - - TKOLRichEdit = PControl; - TKOLProgressBar = PControl; - TKOLListView = PControl; - TKOLTreeView = PControl; - TKOLToolbar = PControl; - TKOLTabControl = PControl; - TKOLTabPage = PControl; - TTabPage = PControl; - TKOLScrollBox = PControl; - TKOLDateTimePicker = PControl; - - TKOLTimer = PTimer; - TKOLThread = PThread; - TKOLImageList = PImageList; - TKOLMainMenu = PMenu; - TKOLPopupMenu = PMenu; - TKOLOpenSaveDialog = POpenSaveDialog; - //TKOLOpenDirDialog = POpenDirDialog; - TKOLTrayIcon = PTrayIcon; - TKOLColorDialog = PColorDialog; - //TKOLActionList = PActionList; - //TKOLAction = PAction; - TKOLScrollBar = PControl; - -{$IFNDEF FPC} -{$IFDEF _D7orHigher} - //{$WARN UNSAFE_TYPE ON} // Too many such warnings in Delphi7 - //{$WARN UNSAFE_CODE ON} - //{$WARN UNSAFE_CAST ON} -{$ENDIF} -{$ENDIF} - diff --git a/plugins/ImportTXT/kol/MCKfakeClasses200x.inc b/plugins/ImportTXT/kol/MCKfakeClasses200x.inc deleted file mode 100644 index 53aed52a68..0000000000 --- a/plugins/ImportTXT/kol/MCKfakeClasses200x.inc +++ /dev/null @@ -1,51 +0,0 @@ -{$IFNDEF INPACKAGE} -type - TKOLProject = Pointer; - TKOLApplet = Pointer; - TKOLForm = Pointer; - TKOLDataModule = Pointer; - TKOLFrame = Pointer; - TKOLMDIClient = PControl; - TKOLMDIChild = Pointer; - TKOLService = Pointer; - - TKOLButton = PControl; - TKOLLabel = PControl; - TKOLLabelEffect = PControl; - TKOLPanel = PControl; - TKOLSplitter = PControl; - TKOLGradientPanel = PControl; - TKOLBitBtn = PControl; - TKOLGroupBox = PControl; - TKOLCheckBox = PControl; - TKOLRadioBox = PControl; - TKOLEditBox = PControl; - TKOLMemo = PControl; - TKOLListBox = PControl; - TKOLComboBox = PControl; - TKOLPaintBox = PControl; - TKOLImageShow = PControl; - - TKOLRichEdit = PControl; - TKOLProgressBar = PControl; - TKOLListView = PControl; - TKOLTreeView = PControl; - TKOLToolbar = PControl; - TKOLTabControl = PControl; - TTabPage = PControl; - TKOLScrollBox = PControl; - TKOLDateTimePicker = PControl; - - TKOLTimer = PTimer; - TKOLThread = PThread; - TKOLImageList = PImageList; - TKOLMainMenu = PMenu; - TKOLPopupMenu = PMenu; - TKOLOpenSaveDialog = POpenSaveDialog; - //TKOLOpenDirDialog = POpenDirDialog; - TKOLTrayIcon = PTrayIcon; - TKOLColorDialog = PColorDialog; - //TKOLActionList = PActionList; - //TKOLAction = PAction; - TKOLScrollBar = PControl; -{$ENDIF} \ No newline at end of file diff --git a/plugins/ImportTXT/kol/Mmx.pas b/plugins/ImportTXT/kol/Mmx.pas deleted file mode 100644 index cb9ee7c8b7..0000000000 --- a/plugins/ImportTXT/kol/Mmx.pas +++ /dev/null @@ -1,361 +0,0 @@ -unit Mmx; -{* MMX support unit. By Vladimir Kladov, 2003. } - -interface - -{$I KOLDEF.INC} - -uses - Windows, Kol; - -type - TCpuId = ( cpuNew486, cpuMMX, cpuMMX_Plus, cpu3DNow, cpu3DNow_Plus, - cpuSSE, cpuSSE2 ); - {* Enumeration type to represent CPU type. - cpuOld486: Old 486 Processor and earlier - cpuNew486: New 486 Processor to Pentium1 without MMX - cpuMMX : MMX supported (but not SSE or SSE2) - cpuSSE : MMX and SSE supported (but not SSE2) - cpuSSE2 : MMX, SSE and SSE2 supported - } - - TCpuCaps = set of TCpuId; - -function GetCPUType: TCpuCaps; -{* Checks CPU (Intel PC x86 Architecture) for MMX support. -|

- -Use following constants in shuffle commands (like "pshufw") as third operand -to instruct to which locations (0,1,2,3) source parts should be placed: } -const - SH0000 = $00; - SH0001 = $01; - SH0002 = $02; - SH0003 = $03; - SH0010 = $04; - SH0011 = $05; - SH0012 = $06; - SH0013 = $07; - SH0020 = $08; - SH0021 = $09; - SH0022 = $0A; - SH0023 = $0B; - SH0030 = $0C; - SH0031 = $0D; - SH0032 = $0E; - SH0033 = $0F; - SH0100 = $10; - SH0101 = $11; - SH0102 = $12; - SH0103 = $13; - SH0110 = $14; - SH0111 = $15; - SH0112 = $16; - SH0113 = $17; - SH0120 = $18; - SH0121 = $19; - SH0122 = $1A; - SH0123 = $1B; - SH0130 = $1C; - SH0131 = $1D; - SH0132 = $1E; - SH0133 = $1F; - SH0200 = $20; - SH0201 = $21; - SH0202 = $22; - SH0203 = $23; - SH0210 = $24; - SH0211 = $25; - SH0212 = $26; - SH0213 = $27; - SH0220 = $28; - SH0221 = $29; - SH0222 = $2A; - SH0223 = $2B; - SH0230 = $2C; - SH0231 = $2D; - SH0232 = $2E; - SH0233 = $2F; - SH0300 = $30; - SH0301 = $31; - SH0302 = $32; - SH0303 = $33; - SH0310 = $34; - SH0311 = $35; - SH0312 = $36; - SH0313 = $37; - SH0320 = $38; - SH0321 = $39; - SH0322 = $3A; - SH0323 = $3B; - SH0330 = $3C; - SH0331 = $3D; - SH0332 = $3E; - SH0333 = $3F; - SH1000 = $40; - SH1001 = $41; - SH1002 = $42; - SH1003 = $43; - SH1010 = $44; - SH1011 = $45; - SH1012 = $46; - SH1013 = $47; - SH1020 = $48; - SH1021 = $49; - SH1022 = $4A; - SH1023 = $4B; - SH1030 = $4C; - SH1031 = $4D; - SH1032 = $4E; - SH1033 = $4F; - SH1100 = $50; - SH1101 = $51; - SH1102 = $52; - SH1103 = $53; - SH1110 = $54; - SH1111 = $55; - SH1112 = $56; - SH1113 = $57; - SH1120 = $58; - SH1121 = $59; - SH1122 = $5A; - SH1123 = $5B; - SH1130 = $5C; - SH1131 = $5D; - SH1132 = $5E; - SH1133 = $5F; - SH1200 = $60; - SH1201 = $61; - SH1202 = $62; - SH1203 = $63; - SH1210 = $64; - SH1211 = $65; - SH1212 = $66; - SH1213 = $67; - SH1220 = $68; - SH1221 = $69; - SH1222 = $6A; - SH1223 = $6B; - SH1230 = $6C; - SH1231 = $6D; - SH1232 = $6E; - SH1233 = $6F; - SH1300 = $70; - SH1301 = $71; - SH1302 = $72; - SH1303 = $73; - SH1310 = $74; - SH1311 = $75; - SH1312 = $76; - SH1313 = $77; - SH1320 = $78; - SH1321 = $79; - SH1322 = $7A; - SH1323 = $7B; - SH1330 = $7C; - SH1331 = $7D; - SH1332 = $7E; - SH1333 = $7F; - SH2000 = $80; - SH2001 = $81; - SH2002 = $82; - SH2003 = $83; - SH2010 = $84; - SH2011 = $85; - SH2012 = $86; - SH2013 = $87; - SH2020 = $88; - SH2021 = $89; - SH2022 = $8A; - SH2023 = $8B; - SH2030 = $8C; - SH2031 = $8D; - SH2032 = $8E; - SH2033 = $8F; - SH2100 = $90; - SH2101 = $91; - SH2102 = $92; - SH2103 = $93; - SH2110 = $94; - SH2111 = $95; - SH2112 = $96; - SH2113 = $97; - SH2120 = $98; - SH2121 = $99; - SH2122 = $9A; - SH2123 = $9B; - SH2130 = $9C; - SH2131 = $9D; - SH2132 = $9E; - SH2133 = $9F; - SH2200 = $A0; - SH2201 = $A1; - SH2202 = $A2; - SH2203 = $A3; - SH2210 = $A4; - SH2211 = $A5; - SH2212 = $A6; - SH2213 = $A7; - SH2220 = $A8; - SH2221 = $A9; - SH2222 = $AA; - SH2223 = $AB; - SH2230 = $AC; - SH2231 = $AD; - SH2232 = $AE; - SH2233 = $AF; - SH2300 = $B0; - SH2301 = $B1; - SH2302 = $B2; - SH2303 = $B3; - SH2310 = $B4; - SH2311 = $B5; - SH2312 = $B6; - SH2313 = $B7; - SH2320 = $B8; - SH2321 = $B9; - SH2322 = $BA; - SH2323 = $BB; - SH2330 = $BC; - SH2331 = $BD; - SH2332 = $BE; - SH2333 = $BF; - SH3000 = $C0; - SH3001 = $C1; - SH3002 = $C2; - SH3003 = $C3; - SH3010 = $C4; - SH3011 = $C5; - SH3012 = $C6; - SH3013 = $C7; - SH3020 = $C8; - SH3021 = $C9; - SH3022 = $CA; - SH3023 = $CB; - SH3030 = $CC; - SH3031 = $CD; - SH3032 = $CE; - SH3033 = $CF; - SH3100 = $D0; - SH3101 = $D1; - SH3102 = $D2; - SH3103 = $D3; - SH3110 = $D4; - SH3111 = $D5; - SH3112 = $D6; - SH3113 = $D7; - SH3120 = $D8; - SH3121 = $D9; - SH3122 = $DA; - SH3123 = $DB; - SH3130 = $DC; - SH3131 = $DD; - SH3132 = $DE; - SH3133 = $DF; - SH3200 = $E0; - SH3201 = $E1; - SH3202 = $E2; - SH3203 = $E3; - SH3210 = $E4; - SH3211 = $E5; - SH3212 = $E6; - SH3213 = $E7; - SH3220 = $E8; - SH3221 = $E9; - SH3222 = $EA; - SH3223 = $EB; - SH3230 = $EC; - SH3231 = $ED; - SH3232 = $EE; - SH3233 = $EF; - SH3300 = $F0; - SH3301 = $F1; - SH3302 = $F2; - SH3303 = $F3; - SH3310 = $F4; - SH3311 = $F5; - SH3312 = $F6; - SH3313 = $F7; - SH3320 = $F8; - SH3321 = $F9; - SH3322 = $FA; - SH3323 = $FB; - SH3330 = $FC; - SH3331 = $FD; - SH3332 = $FE; - SH3333 = $FF; - -implementation - -var cpu: TCpuCaps = [ ]; - -function GetCPUType: TCpuCaps; -var I, J: Integer; - Vend1: array[ 0..3 ] of Char; -begin - Result := cpu; // old 486 and earlier - if Result <> [] then Exit; - I := 0; - asm // check if bit 21 of EFLAGS can be set and reset - PUSHFD - POP EAX - OR EAX, 1 shl 21 - PUSH EAX - POPFD - PUSHFD - POP EAX - TEST EAX, 1 shl 21 - JZ @@1 - AND EAX, not( 1 shl 21 ) - PUSH EAX - POPFD - PUSHFD - POP EAX - TEST EAX, 1 shl 21 - JNZ @@1 - INC [ I ] - @@1: - end; - if I = 0 then Exit; // CPUID not supported - Include( Result, cpuNew486 ); // at least cpuNew486 - asm // get CPU features flags using CPUID command - PUSH EBX - MOV EAX, 0 - DB $0F, $A2 //CPUID : EAX, EBX, EDX and ECX are changed!!! - MOV [ Vend1 ], EBX - - MOV EAX, 1 - DB $0F, $A2 //CPUID : EAX, EBX, EDX and ECX are changed!!! - MOV [ I ], EDX // I := features information - POP EBX - end; - if (I and (1 shl 23)) = 0 then Exit; // MMX not supported at all - Include( Result, cpuMMX ); // MMX supported. - if Vend1 = 'Auth' then // AuthenticAMD ? - begin - asm - PUSH EBX - MOV EAX, $80000001 - DB $0F, $A2 //CPUID : EAX, EBX, EDX and ECX are changed!!! - MOV [ J ], EDX - POP EBX - end; - if (J and (1 shl 22)) <> 0 then - Include( Result, cpuMMX_Plus ); // MMX+ supported. - if (J and (1 shl 31)) <> 0 then - begin - Include( Result, cpu3DNow ); // 3DNow! supported. - if (J and (1 shl 30)) <> 0 then - Include( Result, cpu3DNow_Plus );// 3DNow!+ supported. - end; - end; - if (I and (1 shl 25)) <> 0 then - begin - Include( Result, cpuSSE ); // SSE supported. - if (I and (1 shl 26)) <> 0 then - Include( Result, cpuSSE2 ); // SSE2 supported. - end; - cpu := Result; -end; - -end. diff --git a/plugins/ImportTXT/kol/MsgDecode.pas b/plugins/ImportTXT/kol/MsgDecode.pas deleted file mode 100644 index 7f53615094..0000000000 --- a/plugins/ImportTXT/kol/MsgDecode.pas +++ /dev/null @@ -1,4957 +0,0 @@ -type - TMessageDecoded = ( - cWM_NULL, // = $0000; - cWM_CREATE, // = $0001; - cWM_DESTROY, // = $0002; - cWM_MOVE, // = $0003; - cWM_0004, - cWM_SIZE, // = $0005; - cWM_ACTIVATE, // = $0006; - cWM_SETFOCUS, // = $0007; - cWM_KILLFOCUS, // = $0008; - cWM_0009, - cWM_ENABLE, // = $000A; - cWM_SETREDRAW, // = $000B; - cWM_SETTEXT, // = $000C; - cWM_GETTEXT, // = $000D; - cWM_GETTEXTLENGTH,// = $000E; - cWM_PAINT, // = $000F; - cWM_CLOSE, // = $0010; - cWM_QUERYENDSESSION,// = $0011; - cWM_QUIT, // = $0012; - cWM_QUERYOPEN, // = $0013; - cWM_ERASEBKGND, // = $0014; - cWM_SYSCOLORCHANGE,// = $0015; - cWM_ENDSESSION, // = $0016; - cWM_SYSTEMERROR, // = $0017; - cWM_SHOWWINDOW, // = $0018; - cWM_CTLCOLOR, // = $0019; - cWM_WININICHANGE,// = $001A; - //WM_SETTINGCHANGE = WM_WININICHANGE; - cWM_DEVMODECHANGE,// = $001B; - cWM_ACTIVATEAPP, // = $001C; - cWM_FONTCHANGE, // = $001D; - cWM_TIMECHANGE, // = $001E; - cWM_CANCELMODE, // = $001F; - cWM_SETCURSOR, // = $0020; - cWM_MOUSEACTIVATE,// = $0021; - cWM_CHILDACTIVATE,// = $0022; - cWM_QUEUESYNC, // = $0023; - cWM_GETMINMAXINFO,// = $0024; - cWM_0025, - cWM_PAINTICON, // = $0026; - cWM_ICONERASEBKGND,// = $0027; - cWM_NEXTDLGCTL, // = $0028; - cWM_0029, - cWM_SPOOLERSTATUS,// = $002A; - cWM_DRAWITEM, // = $002B; - cWM_MEASUREITEM, // = $002C; - cWM_DELETEITEM, // = $002D; - cWM_VKEYTOITEM, // = $002E; - cWM_CHARTOITEM, // = $002F; - cWM_SETFONT, // = $0030; - cWM_GETFONT, // = $0031; - cWM_SETHOTKEY, // = $0032; - cWM_GETHOTKEY, // = $0033; - cWM_0034, - cWM_0035, - cWM_0036, - cWM_QUERYDRAGICON,// = $0037; - cWM_0038, - cWM_COMPAREITEM, // = $0039; - cWM_003A, - cWM_003B, - cWM_003C, - cWM_GETOBJECT, // = $003D; - cWM_003E, - cWM_003F, - cWM_0040, - cWM_COMPACTING, // = $0041; - cWM_0042, - cWM_0043, - cWM_COMMNOTIFY, // = $0044; { obsolete in Win32} - cWM_0045, - cWM_WINDOWPOSCHANGING,// = $0046; - cWM_WINDOWPOSCHANGED,// = $0047; - cWM_POWER, // = $0048; - cWM_0049, - cWM_COPYDATA, // = $004A; - cWM_CANCELJOURNAL,// = $004B; - cWM_004C, - cWM_004D, - cWM_NOTIFY, // = $004E; - cWM_004F, - cWM_INPUTLANGCHANGEREQUEST,// = $0050; - cWM_INPUTLANGCHANGE,// = $0051; - cWM_TCARD, // = $0052; - cWM_HELP, // = $0053; - cWM_USERCHANGED, // = $0054; - cWM_NOTIFYFORMAT, // = $0055; - cWM_0056, - cWM_0057, - cWM_0058, - cWM_0059, - cWM_005A, - cWM_005B, - cWM_005C, - cWM_005D, - cWM_005E, - cWM_005F, - cWM_0060, - cWM_0061, - cWM_0062, - cWM_0063, - cWM_0064, - cWM_0065, - cWM_0066, - cWM_0067, - cWM_0068, - cWM_0069, - cWM_006A, - cWM_006B, - cWM_006C, - cWM_006D, - cWM_006E, - cWM_006F, - cWM_0070, - cWM_0071, - cWM_0072, - cWM_0073, - cWM_0074, - cWM_0075, - cWM_0076, - cWM_0077, - cWM_0078, - cWM_0079, - cWM_007A, - cWM_CONTEXTMENU, // = $007B; - cWM_STYLECHANGING,// = $007C; - cWM_STYLECHANGED, // = $007D; - cWM_DISPLAYCHANGE,// = $007E; - cWM_GETICON, // = $007F; - cWM_SETICON, // = $0080; - cWM_NCCREATE, // = $0081; - cWM_NCDESTROY, // = $0082; - cWM_NCCALCSIZE, // = $0083; - cWM_NCHITTEST, // = $0084; - cWM_NCPAINT, // = $0085; - cWM_NCACTIVATE, // = $0086; - cWM_GETDLGCODE, // = $0087; - cWM_0088, - cWM_0089, - cWM_008A, - cWM_008B, - cWM_008C, - cWM_008D, - cWM_008E, - cWM_008F, - cWM_0090, - cWM_0091, - cWM_0092, - cWM_0093, - cWM_0094, - cWM_0095, - cWM_0096, - cWM_0097, - cWM_0098, - cWM_0099, - cWM_009A, - cWM_009B, - cWM_009C, - cWM_009D, - cWM_009E, - cWM_009F, - cWM_NCMOUSEMOVE, // = $00A0; - cWM_NCLBUTTONDOWN, // = $00A1; - cWM_NCLBUTTONUP, // = $00A2; - cWM_NCLBUTTONDBLCLK,// = $00A3; - cWM_NCRBUTTONDOWN, // = $00A4; - cWM_NCRBUTTONUP, // = $00A5; - cWM_NCRBUTTONDBLCLK,// = $00A6; - cWM_NCMBUTTONDOWN, // = $00A7; - cWM_NCMBUTTONUP, // = $00A8; - cWM_NCMBUTTONDBLCLK,// = $00A9; - cWM_00AA, - cWM_NCXBUTTONDOWN, // = $00AB; - cWM_NCXBUTTONUP, // = $00AC; - cWM_NCXBUTTONDBLCLK,// = $00AD; - cWM_00AE, - cWM_00AF, - cEM_GETSEL, // = $00B0; - cEM_SETSEL, // = $00B1; - cEM_GETRECT, // = $00B2; - cEM_SETRECT, // = $00B3; - cEM_SETRECTNP, // = $00B4; - cEM_SCROLL, // = $00B5; - cEM_LINESCROLL, // = $00B6; - cEM_SCROLLCARET, // = $00B7; - cEM_GETMODIFY, // = $00B8; - cEM_SETMODIFY, // = $00B9; - cEM_GETLINECOUNT, // = $00BA; - cEM_LINEINDEX, // = $00BB; - cEM_SETHANDLE, // = $00BC; - cEM_GETHANDLE, // = $00BD; - cEM_GETTHUMB, // = $00BE; - cWM_00BF, - cWM_00C0, - cEM_LINELENGTH, // = $00C1; - cEM_REPLACESEL, // = $00C2; - cWM_00C3, - cEM_GETLINE, // = $00C4; - cEM_LIMITTEXT, // = $00C5; - cEM_CANUNDO, // = $00C6; - cEM_UNDO, // = $00C7; - cEM_FMTLINES, // = $00C8; - cEM_LINEFROMCHAR, // = $00C9; - cWM_00CA, - cEM_SETTABSTOPS, // = $00CB; - cEM_SETPASSWORDCHAR,// = $00CC; - cEM_EMPTYUNDOBUFFER,// = $00CD; - cEM_GETFIRSTVISIBLELINE,// = $00CE; - cEM_SETREADONLY, // = $00CF; - cEM_SETWORDBREAKPROC,// = $00D0; - cEM_GETWORDBREAKPROC,// = $00D1; - cEM_GETPASSWORDCHAR,// = $00D2; - cEM_SETMARGINS, // = 211; - cEM_GETMARGINS, // = 212; - //EM_SETLIMITTEXT = EM_LIMITTEXT; //win40 Name change - cEM_GETLIMITTEXT, // = 213; - cEM_POSFROMCHAR, // = 214; - cEM_CHARFROMPOS, // = 215; - cEM_SETIMESTATUS, // = 216; - cEM_GETIMESTATUS, // = 217; = $D9; - cWM_00DA, - cWM_00DB, - cWM_00DC, - cWM_00DD, - cWM_00DE, - cWM_00DF, - cWM_00E0, - cWM_00E1, - cWM_00E2, - cWM_00E3, - cWM_00E4, - cWM_00E5, - cWM_00E6, - cWM_00E7, - cWM_00E8, - cWM_00E9, - cWM_00EA, - cWM_00EB, - cWM_00EC, - cWM_00ED, - cWM_00EE, - cWM_00EF, - cBM_GETCHECK, // = $00F0; - cBM_SETCHECK, // = $00F1; - cBM_GETSTATE, // = $00F2; - cBM_SETSTATE, // = $00F3; - cBM_SETSTYLE, // = $00F4; - cBM_CLICK, // = $00F5; - cBM_GETIMAGE, // = $00F6; - cBM_SETIMAGE, // = $00F7; - cWM_00F8, - cWM_00F9, - cWM_00FA, - cWM_00FB, - cWM_00FC, - cWM_00FD, - cWM_00FE, - cWM_INPUT, // = $00FF; - //WM_KEYFIRST = $0100; - cWM_KEYDOWN, // = $0100; - cWM_KEYUP, // = $0101; - cWM_CHAR, // = $0102; - cWM_DEADCHAR, // = $0103; - cWM_SYSKEYDOWN, // = $0104; - cWM_SYSKEYUP, // = $0105; - cWM_SYSCHAR, // = $0106; - cWM_SYSDEADCHAR, // = $0107; - cWM_KEYLAST, // = $0108; - cWM_0109, - cWM_010A, - cWM_010B, - cWM_010C, - cWM_IME_STARTCOMPOSITION, // = $010D; - cWM_IME_ENDCOMPOSITION, // = $010E; - cWM_IME_COMPOSITION, // = $010F; - cWM_INITDIALOG, // = $0110; - cWM_COMMAND, // = $0111; - cWM_SYSCOMMAND, // = $0112; - cWM_TIMER, // = $0113; - cWM_HSCROLL, // = $0114; - cWM_VSCROLL, // = $0115; - cWM_INITMENU, // = $0116; - cWM_INITMENUPOPUP, // = $0117; - cWM_0118, - cWM_0119, - cWM_011A, - cWM_011B, - cWM_011C, - cWM_011D, - cWM_011E, - cWM_MENUSELECT, // = $011F; - cWM_MENUCHAR, // = $0120; - cWM_ENTERIDLE, // = $0121; - cWM_MENURBUTTONUP, // = $0122; - cWM_MENUDRAG, // = $0123; - cWM_MENUGETOBJECT, // = $0124; - cWM_UNINITMENUPOPUP, // = $0125; - cWM_MENUCOMMAND, // = $0126; - cWM_CHANGEUISTATE, // = $0127; - cWM_UPDATEUISTATE, // = $0128; - cWM_QUERYUISTATE, // = $0129; - cWM_012A, - cWM_012B, - cWM_012C, - cWM_012D, - cWM_012E, - cWM_012F, - cWM_0130, - cWM_0131, - cWM_CTLCOLORMSGBOX, // = $0132; - cWM_CTLCOLOREDIT, // = $0133; - cWM_CTLCOLORLISTBOX, // = $0134; - cWM_CTLCOLORBTN, // = $0135; - cWM_CTLCOLORDLG, // = $0136; - cWM_CTLCOLORSCROLLBAR, // = $0137; - cWM_CTLCOLORSTATIC, // = $0138; - cWM_0139, - cWM_013A, - cWM_013B, - cWM_013C, - cWM_013D, - cWM_013E, - cWM_013F, - cCB_GETEDITSEL, // = $0140; - cCB_LIMITTEXT, // = $0141; - cCB_SETEDITSEL, // = $0142; - cCB_ADDSTRING, // = $0143; - cCB_DELETESTRING, // = $0144; - cCB_DIR, // = $0145; - cCB_GETCOUNT, // = $0146; - cCB_GETCURSEL, // = $0147; - cCB_GETLBTEXT, // = $0148; - cCB_GETLBTEXTLEN, // = $0149; - cCB_INSERTSTRING, // = $014A; - cCB_RESETCONTENT, // = $014B; - cCB_FINDSTRING, // = $014C; - cCB_SELECTSTRING, // = $014D; - cCB_SETCURSEL, // = $014E; - cCB_SHOWDROPDOWN, // = $014F; - cCB_GETITEMDATA, // = $0150; - cCB_SETITEMDATA, // = $0151; - cCB_GETDROPPEDCONTROLRECT,// = $0152; - cCB_SETITEMHEIGHT, // = $0153; - cCB_GETITEMHEIGHT, // = $0154; - cCB_SETEXTENDEDUI, // = $0155; - cCB_GETEXTENDEDUI, // = $0156; - cCB_GETDROPPEDSTATE, // = $0157; - cCB_FINDSTRINGEXACT, // = $0158; - cCB_SETLOCALE, // = 345; - cCB_GETLOCALE, // = 346; - cCB_GETTOPINDEX, // = 347; - cCB_SETTOPINDEX, // = 348; - cCB_GETHORIZONTALEXTENT, // = 349; - cCB_SETHORIZONTALEXTENT, // = 350; - cCB_GETDROPPEDWIDTH, // = 351; - cCB_SETDROPPEDWIDTH, // = 352; - cCB_INITSTORAGE, // = 353; - cCB_MSGMAX, // = 354; = $162 - cWM_0163, - cWM_0164, - cWM_0165, - cWM_0166, - cWM_0167, - cWM_0168, - cWM_0169, - cWM_016A, - cWM_016B, - cWM_016C, - cWM_016D, - cWM_016E, - cWM_016F, - cWM_0170, - cWM_0171, - cWM_0172, - cWM_0173, - cWM_0174, - cWM_0175, - cWM_0176, - cWM_0177, - cWM_0178, - cWM_0179, - cWM_017A, - cWM_017B, - cWM_017C, - cWM_017D, - cWM_017E, - cWM_017F, - cLB_ADDSTRING, // = $0180; - cLB_INSERTSTRING, // = $0181; - cLB_DELETESTRING, // = $0182; - cLB_SELITEMRANGEEX, // = $0183; - cLB_RESETCONTENT, // = $0184; - cLB_SETSEL, // = $0185; - cLB_SETCURSEL, // = $0186; - cLB_GETSEL, // = $0187; - cLB_GETCURSEL, // = $0188; - cLB_GETTEXT, // = $0189; - cLB_GETTEXTLEN, // = $018A; - cLB_GETCOUNT, // = $018B; - cLB_SELECTSTRING, // = $018C; - cLB_DIR, // = $018D; - cLB_GETTOPINDEX, // = $018E; - cLB_FINDSTRING, // = $018F; - cLB_GETSELCOUNT, // = $0190; - cLB_GETSELITEMS, // = $0191; - cLB_SETTABSTOPS, // = $0192; - cLB_GETHORIZONTALEXTENT,// = $0193; - cLB_SETHORIZONTALEXTENT,// = $0194; - cLB_SETCOLUMNWIDTH, // = $0195; - cLB_ADDFILE, // = $0196; - cLB_SETTOPINDEX, // = $0197; - cLB_GETITEMRECT, // = $0198; - cLB_GETITEMDATA, // = $0199; - cLB_SETITEMDATA, // = $019A; - cLB_SELITEMRANGE, // = $019B; - cLB_SETANCHORINDEX, // = $019C; - cLB_GETANCHORINDEX, // = $019D; - cLB_SETCARETINDEX, // = $019E; - cLB_GETCARETINDEX, // = $019F; - cLB_SETITEMHEIGHT, // = $01A0; - cLB_GETITEMHEIGHT, // = $01A1; - cLB_FINDSTRINGEXACT,// = $01A2; - cWM_01A3, - cWM_01A4, - cLB_SETLOCALE, // = $01A5; - cLB_GETLOCALE, // = $01A6; - cLB_SETCOUNT, // = $01A7; - cLB_INITSTORAGE, // = $01A8; - cLB_ITEMFROMPOINT, // = $01A9; - cWM_01AA, - cWM_01AB, - cWM_01AC, - cWM_01AD, - cWM_01AE, - cWM_01AF, - cWM_01B0, - cWM_01B1, - cWM_01B2, - cWM_01B3, - cWM_01B4, - cWM_01B5, - cWM_01B6, - cWM_01B7, - cWM_01B8, - cWM_01B9, - cWM_01BA, - cWM_01BB, - cWM_01BC, - cWM_01BD, - cWM_01BE, - cWM_01BF, - cWM_01C0, - cWM_01C1, - cWM_01C2, - cWM_01C3, - cWM_01C4, - cWM_01C5, - cWM_01C6, - cWM_01C7, - cWM_01C8, - cWM_01C9, - cWM_01CA, - cWM_01CB, - cWM_01CC, - cWM_01CD, - cWM_01CE, - cWM_01CF, - cWM_01D0, - cWM_01D1, - cWM_01D2, - cWM_01D3, - cWM_01D4, - cWM_01D5, - cWM_01D6, - cWM_01D7, - cWM_01D8, - cWM_01D9, - cWM_01DA, - cWM_01DB, - cWM_01DC, - cWM_01DD, - cWM_01DE, - cWM_01DF, - cWM_01E0, - cWM_01E1, - cWM_01E2, - cWM_01E3, - cWM_01E4, - cWM_01E5, - cWM_01E6, - cWM_01E7, - cWM_01E8, - cWM_01E9, - cWM_01EA, - cWM_01EB, - cWM_01EC, - cWM_01ED, - cWM_01EE, - cWM_01EF, - cWM_01F0, - cWM_01F1, - cWM_01F2, - cWM_01F3, - cWM_01F4, - cWM_01F5, - cWM_01F6, - cWM_01F7, - cWM_01F8, - cWM_01F9, - cWM_01FA, - cWM_01FB, - cWM_01FC, - cWM_01FD, - cWM_01FE, - cWM_01FF, - cWM_MOUSEMOVE, // = $0200; WM_MOUSEFIRST - cWM_LBUTTONDOWN, // = $0201; - cWM_LBUTTONUP, // = $0202; - cWM_LBUTTONDBLCLK, // = $0203; - cWM_RBUTTONDOWN, // = $0204; - cWM_RBUTTONUP, // = $0205; - cWM_RBUTTONDBLCLK, // = $0206; - cWM_MBUTTONDOWN, // = $0207; - cWM_MBUTTONUP, // = $0208; - cWM_MBUTTONDBLCLK, // = $0209; - cWM_MOUSEWHEEL, // = $020A; WM_MOUSELAST - cWM_020B, - cWM_020C, - cWM_020D, - cWM_020E, - cWM_020F, - cWM_PARENTNOTIFY, // = $0210; - cWM_ENTERMENULOOP, // = $0211; - cWM_EXITMENULOOP, // = $0212; - cWM_NEXTMENU, // = $0213; - cWM_SIZING, // = 532; = $214 - cWM_CAPTURECHANGED, // = 533; - cWM_MOVING, // = 534; - cWM_POWERBROADCAST, // = 536; - cWM_DEVICECHANGE, // = 537; = $218 - cWM_0219, - cWM_021A, - cWM_021B, - cWM_021C, - cWM_021D, - cWM_021E, - cWM_021F, - cWM_MDICREATE, // = $0220; - cWM_MDIDESTROY, // = $0221; - cWM_MDIACTIVATE, // = $0222; - cWM_MDIRESTORE, // = $0223; - cWM_MDINEXT, // = $0224; - cWM_MDIMAXIMIZE, // = $0225; - cWM_MDITILE, // = $0226; - cWM_MDICASCADE, // = $0227; - cWM_MDIICONARRANGE, // = $0228; - cWM_MDIGETACTIVE, // = $0229; - cWM_022A, - cWM_022B, - cWM_022C, - cWM_022D, - cWM_022E, - cWM_022F, - cWM_MDISETMENU, // = $0230; - cWM_ENTERSIZEMOVE, // = $0231; - cWM_EXITSIZEMOVE, // = $0232; - cWM_DROPFILES, // = $0233; - cWM_MDIREFRESHMENU, // = $0234; - cWM_0235, - cWM_0236, - cWM_0237, - cWM_0238, - cWM_0239, - cWM_023A, - cWM_023B, - cWM_023C, - cWM_023D, - cWM_023E, - cWM_023F, - cWM_0240, - cWM_0241, - cWM_0242, - cWM_0243, - cWM_0244, - cWM_0245, - cWM_0246, - cWM_0247, - cWM_0248, - cWM_0249, - cWM_024A, - cWM_024B, - cWM_024C, - cWM_024D, - cWM_024E, - cWM_024F, - cWM_0250, - cWM_0251, - cWM_0252, - cWM_0253, - cWM_0254, - cWM_0255, - cWM_0256, - cWM_0257, - cWM_0258, - cWM_0259, - cWM_025A, - cWM_025B, - cWM_025C, - cWM_025D, - cWM_025E, - cWM_025F, - cWM_0260, - cWM_0261, - cWM_0262, - cWM_0263, - cWM_0264, - cWM_0265, - cWM_0266, - cWM_0267, - cWM_0268, - cWM_0269, - cWM_026A, - cWM_026B, - cWM_026C, - cWM_026D, - cWM_026E, - cWM_026F, - cWM_0270, - cWM_0271, - cWM_0272, - cWM_0273, - cWM_0274, - cWM_0275, - cWM_0276, - cWM_0277, - cWM_0278, - cWM_0279, - cWM_027A, - cWM_027B, - cWM_027C, - cWM_027D, - cWM_027E, - cWM_027F, - cWM_0280, - cWM_IME_SETCONTEXT, // = $0281; - cWM_IME_NOTIFY, // = $0282; - cWM_IME_CONTROL, // = $0283; - cWM_IME_COMPOSITIONFULL,// = $0284; - cWM_IME_SELECT, // = $0285; - cWM_IME_CHAR, // = $0286; - cWM_0287, - cWM_IME_REQUEST, // = $0288; - cWM_0289, - cWM_028A, - cWM_028B, - cWM_028C, - cWM_028D, - cWM_028E, - cWM_028F, - cWM_IME_KEYDOWN, // = $0290; - cWM_IME_KEYUP, // = $0291; - cWM_0292, - cWM_0293, - cWM_0294, - cWM_0295, - cWM_0296, - cWM_0297, - cWM_0298, - cWM_0299, - cWM_029A, - cWM_029B, - cWM_029C, - cWM_029D, - cWM_029E, - cWM_029F, - cWM_NCMOUSEHOVER, // = $02A0; - cWM_MOUSEHOVER, // = $02A1; - cWM_NCMOUSELEAVE, // = $02A2; - cWM_MOUSELEAVE, // = $02A3; - cWM_02A4, - cWM_02A5, - cWM_02A6, - cWM_02A7, - cWM_02A8, - cWM_02A9, - cWM_02AA, - cWM_02AB, - cWM_02AC, - cWM_02AD, - cWM_02AE, - cWM_02AF, - cWM_02B0, - cWM_WTSSESSION_CHANGE, // = $02B1; - cWM_02B2, - cWM_02B3, - cWM_02B4, - cWM_02B5, - cWM_02B6, - cWM_02B7, - cWM_02B8, - cWM_02B9, - cWM_02BA, - cWM_02BB, - cWM_02BC, - cWM_02BD, - cWM_02BE, - cWM_02BF, - cWM_TABLET_FIRST, // = $02C0; - cWM_02C1, - cWM_02C2, - cWM_02C3, - cWM_02C4, - cWM_02C5, - cWM_02C6, - cWM_02C7, - cWM_02C8, - cWM_02C9, - cWM_02CA, - cWM_02CB, - cWM_02CC, - cWM_02CD, - cWM_02CE, - cWM_02CF, - cWM_02D0, - cWM_02D1, - cWM_02D2, - cWM_02D3, - cWM_02D4, - cWM_02D5, - cWM_02D6, - cWM_02D7, - cWM_02D8, - cWM_02D9, - cWM_02DA, - cWM_02DB, - cWM_02DC, - cWM_02DD, - cWM_02DE, - cWM_TABLET_LAST, // = $02DF; - cWM_02E0, - cWM_02E1, - cWM_02E2, - cWM_02E3, - cWM_02E4, - cWM_02E5, - cWM_02E6, - cWM_02E7, - cWM_02E8, - cWM_02E9, - cWM_02EA, - cWM_02EB, - cWM_02EC, - cWM_02ED, - cWM_02EE, - cWM_02EF, - cWM_02F0, - cWM_02F1, - cWM_02F2, - cWM_02F3, - cWM_02F4, - cWM_02F5, - cWM_02F6, - cWM_02F7, - cWM_02F8, - cWM_02F9, - cWM_02FA, - cWM_02FB, - cWM_02FC, - cWM_02FD, - cWM_02FE, - cWM_02FF, - cWM_CUT, // = $0300; - cWM_COPY, // = $0301; - cWM_PASTE, // = $0302; - cWM_CLEAR, // = $0303; - cWM_UNDO, // = $0304; - cWM_RENDERFORMAT, // = $0305; - cWM_RENDERALLFORMATS, // = $0306; - cWM_DESTROYCLIPBOARD, // = $0307; - cWM_DRAWCLIPBOARD, // = $0308; - cWM_PAINTCLIPBOARD, // = $0309; - cWM_VSCROLLCLIPBOARD, // = $030A; - cWM_SIZECLIPBOARD, // = $030B; - cWM_ASKCBFORMATNAME, // = $030C; - cWM_CHANGECBCHAIN, // = $030D; - cWM_HSCROLLCLIPBOARD, // = $030E; - cWM_QUERYNEWPALETTE, // = $030F; - cWM_PALETTEISCHANGING, // = $0310; - cWM_PALETTECHANGED, // = $0311; - cWM_HOTKEY, // = $0312; - cWM_0313, - cWM_0314, - cWM_0315, - cWM_0316, - cWM_0317, - cWM_0318, - cWM_APPCOMMAND, // = $0319; - cWM_THEMECHANGED, // = $031A; - cWM_031B, - cWM_031C, - cWM_031D, - cWM_031E, - cWM_031F, - cWM_0320, - cWM_0321, - cWM_0322, - cWM_0323, - cWM_0324, - cWM_0325, - cWM_0326, - cWM_0327, - cWM_0328, - cWM_0329, - cWM_032A, - cWM_032B, - cWM_032C, - cWM_032D, - cWM_032E, - cWM_032F, - cWM_0330, - cWM_0331, - cWM_0332, - cWM_0333, - cWM_0334, - cWM_0335, - cWM_0336, - cWM_0337, - cWM_0338, - cWM_0339, - cWM_033A, - cWM_033B, - cWM_033C, - cWM_033D, - cWM_033E, - cWM_033F, - cWM_0340, - cWM_0341, - cWM_0342, - cWM_0343, - cWM_0344, - cWM_0345, - cWM_0346, - cWM_0347, - cWM_0348, - cWM_0349, - cWM_034A, - cWM_034B, - cWM_034C, - cWM_034D, - cWM_034E, - cWM_034F, - cWM_0350, - cWM_0351, - cWM_0352, - cWM_0353, - cWM_0354, - cWM_0355, - cWM_0356, - cWM_0357, - cWM_0358, - cWM_0359, - cWM_035A, - cWM_035B, - cWM_035C, - cWM_035D, - cWM_035E, - cWM_035F, - cWM_0360, - cWM_0361, - cWM_0362, - cWM_0363, - cWM_0364, - cWM_0365, - cWM_0366, - cWM_0367, - cWM_0368, - cWM_0369, - cWM_036A, - cWM_036B, - cWM_036C, - cWM_036D, - cWM_036E, - cWM_036F, - cWM_0370, - cWM_0371, - cWM_0372, - cWM_0373, - cWM_0374, - cWM_0375, - cWM_0376, - cWM_0377, - cWM_0378, - cWM_0379, - cWM_037A, - cWM_037B, - cWM_037C, - cWM_037D, - cWM_037E, - cWM_037F, - cWM_PENWINFIRST, // = $0380; - cWM_0381, - cWM_0382, - cWM_0383, - cWM_0384, - cWM_0385, - cWM_0386, - cWM_0387, - cWM_0388, - cWM_0389, - cWM_038A, - cWM_038B, - cWM_038C, - cWM_038D, - cWM_038E, - cWM_PENWINLAST, // = $038F; - cWM_COALESCE_FIRST, // = $0390; - cWM_0391, - cWM_0392, - cWM_0393, - cWM_0394, - cWM_0395, - cWM_0396, - cWM_0397, - cWM_0398, - cWM_0399, - cWM_039A, - cWM_039B, - cWM_039C, - cWM_039D, - cWM_039E, - cWM_COALESCE_LAST, // = $039F; - cWM_03A0, - cWM_03A1, - cWM_03A2, - cWM_03A3, - cWM_03A4, - cWM_03A5, - cWM_03A6, - cWM_03A7, - cWM_03A8, - cWM_03A9, - cWM_03AA, - cWM_03AB, - cWM_03AC, - cWM_03AD, - cWM_03AE, - cWM_03AF, - cWM_03B0, - cWM_03B1, - cWM_03B2, - cWM_03B3, - cWM_03B4, - cWM_03B5, - cWM_03B6, - cWM_03B7, - cWM_03B8, - cWM_03B9, - cWM_03BA, - cWM_03BB, - cWM_03BC, - cWM_03BD, - cWM_03BE, - cWM_03BF, - cWM_03C0, - cWM_03C1, - cWM_03C2, - cWM_03C3, - cWM_03C4, - cWM_03C5, - cWM_03C6, - cWM_03C7, - cWM_03C8, - cWM_03C9, - cWM_03CA, - cWM_03CB, - cWM_03CC, - cWM_03CD, - cWM_03CE, - cWM_03CF, - cWM_03D0, - cWM_03D1, - cWM_03D2, - cWM_03D3, - cWM_03D4, - cWM_03D5, - cWM_03D6, - cWM_03D7, - cWM_03D8, - cWM_03D9, - cWM_03DA, - cWM_03DB, - cWM_03DC, - cWM_03DD, - cWM_03DE, - cWM_03DF, - cWM_DDE_INITIATE, // = WM_DDE_FIRST + 0; WM_DDE_FIRST = $03E0; - cWM_DDE_TERMINATE, // = WM_DDE_FIRST + 1; - cWM_DDE_ADVISE, // = WM_DDE_FIRST + 2; - cWM_DDE_UNADVISE, // = WM_DDE_FIRST + 3; - cWM_DDE_ACK, // = WM_DDE_FIRST + 4; - cWM_DDE_DATA, // = WM_DDE_FIRST + 5; - cWM_DDE_REQUEST, // = WM_DDE_FIRST + 6; - cWM_DDE_POKE, // = WM_DDE_FIRST + 7; - cWM_DDE_EXECUTE, // = WM_DDE_FIRST + 8; WM_DDE_LAST - cWM_03E9, - cWM_03EA, - cWM_03EB, - cWM_03EC, - cWM_03ED, - cWM_03EE, - cWM_03EF, - cWM_03F0, - cWM_03F1, - cWM_03F2, - cWM_03F3, - cWM_03F4, - cWM_03F5, - cWM_03F6, - cWM_03F7, - cWM_03F8, - cWM_03F9, - cWM_03FA, - cWM_03FB, - cWM_03FC, - cWM_03FD, - cWM_03FE, - cWM_03FF, - cWM_USER, // = $0400; - cWM_0401, - cWM_0402, - cWM_0403, - cWM_0404, - cWM_0405, - cWM_0406, - cWM_0407, - cWM_0408, - cWM_0409, - cWM_040A, - cWM_040B, - cWM_040C, - cWM_040D, - cWM_040E, - cWM_040F, - cWM_0410, - cWM_0411, - cWM_0412, - cWM_0413, - cWM_0414, - cWM_0415, - cWM_0416, - cWM_0417, - cWM_0418, - cWM_0419, - cWM_041A, - cWM_041B, - cWM_041C, - cWM_041D, - cWM_041E, - cWM_041F, - cWM_0420, - cWM_0421, - cWM_0422, - cWM_0423, - cWM_0424, - cWM_0425, - cWM_0426, - cWM_0427, - cWM_0428, - cWM_0429, - cWM_042A, - cWM_042B, - cWM_042C, - cWM_042D, - cWM_042E, - cWM_042F, - cWM_0430, - cWM_0431, - cWM_0432, - cWM_0433, - cWM_0434, - cWM_0435, - cWM_0436, - cWM_0437, - cWM_0438, - cWM_0439, - cWM_043A, - cWM_043B, - cWM_043C, - cWM_043D, - cWM_043E, - cWM_043F, - cWM_0440, - cWM_0441, - cWM_0442, - cWM_0443, - cWM_0444, - cWM_0445, - cWM_0446, - cWM_0447, - cWM_0448, - cWM_0449, - cWM_044A, - cWM_044B, - cWM_044C, - cWM_044D, - cWM_044E, - cWM_044F, - cWM_0450, - cWM_0451, - cWM_0452, - cWM_0453, - cWM_0454, - cWM_0455, - cWM_0456, - cWM_0457, - cWM_0458, - cWM_0459, - cWM_045A, - cWM_045B, - cWM_045C, - cWM_045D, - cWM_045E, - cWM_045F, - cWM_0460, - cWM_0461, - cWM_0462, - cWM_0463, - cWM_0464, - cWM_0465, - cWM_0466, - cWM_0467, - cWM_0468, - cWM_0469, - cWM_046A, - cWM_046B, - cWM_046C, - cWM_046D, - cWM_046E, - cWM_046F, - cWM_0470, - cWM_0471, - cWM_0472, - cWM_0473, - cWM_0474, - cWM_0475, - cWM_0476, - cWM_0477, - cWM_0478, - cWM_0479, - cWM_047A, - cWM_047B, - cWM_047C, - cWM_047D, - cWM_047E, - cWM_047F, - cWM_0480, - cWM_0481, - cWM_0482, - cWM_0483, - cWM_0484, - cWM_0485, - cWM_0486, - cWM_0487, - cWM_0488, - cWM_0489, - cWM_048A, - cWM_048B, - cWM_048C, - cWM_048D, - cWM_048E, - cWM_048F, - cWM_0490, - cWM_0491, - cWM_0492, - cWM_0493, - cWM_0494, - cWM_0495, - cWM_0496, - cWM_0497, - cWM_0498, - cWM_0499, - cWM_049A, - cWM_049B, - cWM_049C, - cWM_049D, - cWM_049E, - cWM_049F, - cWM_04A0, - cWM_04A1, - cWM_04A2, - cWM_04A3, - cWM_04A4, - cWM_04A5, - cWM_04A6, - cWM_04A7, - cWM_04A8, - cWM_04A9, - cWM_04AA, - cWM_04AB, - cWM_04AC, - cWM_04AD, - cWM_04AE, - cWM_04AF, - cWM_04B0, - cWM_04B1, - cWM_04B2, - cWM_04B3, - cWM_04B4, - cWM_04B5, - cWM_04B6, - cWM_04B7, - cWM_04B8, - cWM_04B9, - cWM_04BA, - cWM_04BB, - cWM_04BC, - cWM_04BD, - cWM_04BE, - cWM_04BF, - cWM_04C0, - cWM_04C1, - cWM_04C2, - cWM_04C3, - cWM_04C4, - cWM_04C5, - cWM_04C6, - cWM_04C7, - cWM_04C8, - cWM_04C9, - cWM_04CA, - cWM_04CB, - cWM_04CC, - cWM_04CD, - cWM_04CE, - cWM_04CF, - cWM_04D0, - cWM_04D1, - cWM_04D2, - cWM_04D3, - cWM_04D4, - cWM_04D5, - cWM_04D6, - cWM_04D7, - cWM_04D8, - cWM_04D9, - cWM_04DA, - cWM_04DB, - cWM_04DC, - cWM_04DD, - cWM_04DE, - cWM_04DF, - cWM_04E0, - cWM_04E1, - cWM_04E2, - cWM_04E3, - cWM_04E4, - cWM_04E5, - cWM_04E6, - cWM_04E7, - cWM_04E8, - cWM_04E9, - cWM_04EA, - cWM_04EB, - cWM_04EC, - cWM_04ED, - cWM_04EE, - cWM_04EF, - cWM_04F0, - cWM_04F1, - cWM_04F2, - cWM_04F3, - cWM_04F4, - cWM_04F5, - cWM_04F6, - cWM_04F7, - cWM_04F8, - cWM_04F9, - cWM_04FA, - cWM_04FB, - cWM_04FC, - cWM_04FD, - cWM_04FE, - cWM_04FF, - cWM_0500, - cWM_0501, - cWM_0502, - cWM_0503, - cWM_0504, - cWM_0505, - cWM_0506, - cWM_0507, - cWM_0508, - cWM_0509, - cWM_050A, - cWM_050B, - cWM_050C, - cWM_050D, - cWM_050E, - cWM_050F, - cWM_0510, - cWM_0511, - cWM_0512, - cWM_0513, - cWM_0514, - cWM_0515, - cWM_0516, - cWM_0517, - cWM_0518, - cWM_0519, - cWM_051A, - cWM_051B, - cWM_051C, - cWM_051D, - cWM_051E, - cWM_051F, - cWM_0520, - cWM_0521, - cWM_0522, - cWM_0523, - cWM_0524, - cWM_0525, - cWM_0526, - cWM_0527, - cWM_0528, - cWM_0529, - cWM_052A, - cWM_052B, - cWM_052C, - cWM_052D, - cWM_052E, - cWM_052F, - cWM_0530, - cWM_0531, - cWM_0532, - cWM_0533, - cWM_0534, - cWM_0535, - cWM_0536, - cWM_0537, - cWM_0538, - cWM_0539, - cWM_053A, - cWM_053B, - cWM_053C, - cWM_053D, - cWM_053E, - cWM_053F, - cWM_0540, - cWM_0541, - cWM_0542, - cWM_0543, - cWM_0544, - cWM_0545, - cWM_0546, - cWM_0547, - cWM_0548, - cWM_0549, - cWM_054A, - cWM_054B, - cWM_054C, - cWM_054D, - cWM_054E, - cWM_054F, - cWM_0550, - cWM_0551, - cWM_0552, - cWM_0553, - cWM_0554, - cWM_0555, - cWM_0556, - cWM_0557, - cWM_0558, - cWM_0559, - cWM_055A, - cWM_055B, - cWM_055C, - cWM_055D, - cWM_055E, - cWM_055F, - cWM_0560, - cWM_0561, - cWM_0562, - cWM_0563, - cWM_0564, - cWM_0565, - cWM_0566, - cWM_0567, - cWM_0568, - cWM_0569, - cWM_056A, - cWM_056B, - cWM_056C, - cWM_056D, - cWM_056E, - cWM_056F, - cWM_0570, - cWM_0571, - cWM_0572, - cWM_0573, - cWM_0574, - cWM_0575, - cWM_0576, - cWM_0577, - cWM_0578, - cWM_0579, - cWM_057A, - cWM_057B, - cWM_057C, - cWM_057D, - cWM_057E, - cWM_057F, - cWM_0580, - cWM_0581, - cWM_0582, - cWM_0583, - cWM_0584, - cWM_0585, - cWM_0586, - cWM_0587, - cWM_0588, - cWM_0589, - cWM_058A, - cWM_058B, - cWM_058C, - cWM_058D, - cWM_058E, - cWM_058F, - cWM_0590, - cWM_0591, - cWM_0592, - cWM_0593, - cWM_0594, - cWM_0595, - cWM_0596, - cWM_0597, - cWM_0598, - cWM_0599, - cWM_059A, - cWM_059B, - cWM_059C, - cWM_059D, - cWM_059E, - cWM_059F, - cWM_05A0, - cWM_05A1, - cWM_05A2, - cWM_05A3, - cWM_05A4, - cWM_05A5, - cWM_05A6, - cWM_05A7, - cWM_05A8, - cWM_05A9, - cWM_05AA, - cWM_05AB, - cWM_05AC, - cWM_05AD, - cWM_05AE, - cWM_05AF, - cWM_05B0, - cWM_05B1, - cWM_05B2, - cWM_05B3, - cWM_05B4, - cWM_05B5, - cWM_05B6, - cWM_05B7, - cWM_05B8, - cWM_05B9, - cWM_05BA, - cWM_05BB, - cWM_05BC, - cWM_05BD, - cWM_05BE, - cWM_05BF, - cWM_05C0, - cWM_05C1, - cWM_05C2, - cWM_05C3, - cWM_05C4, - cWM_05C5, - cWM_05C6, - cWM_05C7, - cWM_05C8, - cWM_05C9, - cWM_05CA, - cWM_05CB, - cWM_05CC, - cWM_05CD, - cWM_05CE, - cWM_05CF, - cWM_05D0, - cWM_05D1, - cWM_05D2, - cWM_05D3, - cWM_05D4, - cWM_05D5, - cWM_05D6, - cWM_05D7, - cWM_05D8, - cWM_05D9, - cWM_05DA, - cWM_05DB, - cWM_05DC, - cWM_05DD, - cWM_05DE, - cWM_05DF, - cWM_05E0, - cWM_05E1, - cWM_05E2, - cWM_05E3, - cWM_05E4, - cWM_05E5, - cWM_05E6, - cWM_05E7, - cWM_05E8, - cWM_05E9, - cWM_05EA, - cWM_05EB, - cWM_05EC, - cWM_05ED, - cWM_05EE, - cWM_05EF, - cWM_05F0, - cWM_05F1, - cWM_05F2, - cWM_05F3, - cWM_05F4, - cWM_05F5, - cWM_05F6, - cWM_05F7, - cWM_05F8, - cWM_05F9, - cWM_05FA, - cWM_05FB, - cWM_05FC, - cWM_05FD, - cWM_05FE, - cWM_05FF, - cWM_0600, - cWM_0601, - cWM_0602, - cWM_0603, - cWM_0604, - cWM_0605, - cWM_0606, - cWM_0607, - cWM_0608, - cWM_0609, - cWM_060A, - cWM_060B, - cWM_060C, - cWM_060D, - cWM_060E, - cWM_060F, - cWM_0610, - cWM_0611, - cWM_0612, - cWM_0613, - cWM_0614, - cWM_0615, - cWM_0616, - cWM_0617, - cWM_0618, - cWM_0619, - cWM_061A, - cWM_061B, - cWM_061C, - cWM_061D, - cWM_061E, - cWM_061F, - cWM_0620, - cWM_0621, - cWM_0622, - cWM_0623, - cWM_0624, - cWM_0625, - cWM_0626, - cWM_0627, - cWM_0628, - cWM_0629, - cWM_062A, - cWM_062B, - cWM_062C, - cWM_062D, - cWM_062E, - cWM_062F, - cWM_0630, - cWM_0631, - cWM_0632, - cWM_0633, - cWM_0634, - cWM_0635, - cWM_0636, - cWM_0637, - cWM_0638, - cWM_0639, - cWM_063A, - cWM_063B, - cWM_063C, - cWM_063D, - cWM_063E, - cWM_063F, - cWM_0640, - cWM_0641, - cWM_0642, - cWM_0643, - cWM_0644, - cWM_0645, - cWM_0646, - cWM_0647, - cWM_0648, - cWM_0649, - cWM_064A, - cWM_064B, - cWM_064C, - cWM_064D, - cWM_064E, - cWM_064F, - cWM_0650, - cWM_0651, - cWM_0652, - cWM_0653, - cWM_0654, - cWM_0655, - cWM_0656, - cWM_0657, - cWM_0658, - cWM_0659, - cWM_065A, - cWM_065B, - cWM_065C, - cWM_065D, - cWM_065E, - cWM_065F, - cWM_0660, - cWM_0661, - cWM_0662, - cWM_0663, - cWM_0664, - cWM_0665, - cWM_0666, - cWM_0667, - cWM_0668, - cWM_0669, - cWM_066A, - cWM_066B, - cWM_066C, - cWM_066D, - cWM_066E, - cWM_066F, - cWM_0670, - cWM_0671, - cWM_0672, - cWM_0673, - cWM_0674, - cWM_0675, - cWM_0676, - cWM_0677, - cWM_0678, - cWM_0679, - cWM_067A, - cWM_067B, - cWM_067C, - cWM_067D, - cWM_067E, - cWM_067F, - cWM_0680, - cWM_0681, - cWM_0682, - cWM_0683, - cWM_0684, - cWM_0685, - cWM_0686, - cWM_0687, - cWM_0688, - cWM_0689, - cWM_068A, - cWM_068B, - cWM_068C, - cWM_068D, - cWM_068E, - cWM_068F, - cWM_0690, - cWM_0691, - cWM_0692, - cWM_0693, - cWM_0694, - cWM_0695, - cWM_0696, - cWM_0697, - cWM_0698, - cWM_0699, - cWM_069A, - cWM_069B, - cWM_069C, - cWM_069D, - cWM_069E, - cWM_069F, - cWM_06A0, - cWM_06A1, - cWM_06A2, - cWM_06A3, - cWM_06A4, - cWM_06A5, - cWM_06A6, - cWM_06A7, - cWM_06A8, - cWM_06A9, - cWM_06AA, - cWM_06AB, - cWM_06AC, - cWM_06AD, - cWM_06AE, - cWM_06AF, - cWM_06B0, - cWM_06B1, - cWM_06B2, - cWM_06B3, - cWM_06B4, - cWM_06B5, - cWM_06B6, - cWM_06B7, - cWM_06B8, - cWM_06B9, - cWM_06BA, - cWM_06BB, - cWM_06BC, - cWM_06BD, - cWM_06BE, - cWM_06BF, - cWM_06C0, - cWM_06C1, - cWM_06C2, - cWM_06C3, - cWM_06C4, - cWM_06C5, - cWM_06C6, - cWM_06C7, - cWM_06C8, - cWM_06C9, - cWM_06CA, - cWM_06CB, - cWM_06CC, - cWM_06CD, - cWM_06CE, - cWM_06CF, - cWM_06D0, - cWM_06D1, - cWM_06D2, - cWM_06D3, - cWM_06D4, - cWM_06D5, - cWM_06D6, - cWM_06D7, - cWM_06D8, - cWM_06D9, - cWM_06DA, - cWM_06DB, - cWM_06DC, - cWM_06DD, - cWM_06DE, - cWM_06DF, - cWM_06E0, - cWM_06E1, - cWM_06E2, - cWM_06E3, - cWM_06E4, - cWM_06E5, - cWM_06E6, - cWM_06E7, - cWM_06E8, - cWM_06E9, - cWM_06EA, - cWM_06EB, - cWM_06EC, - cWM_06ED, - cWM_06EE, - cWM_06EF, - cWM_06F0, - cWM_06F1, - cWM_06F2, - cWM_06F3, - cWM_06F4, - cWM_06F5, - cWM_06F6, - cWM_06F7, - cWM_06F8, - cWM_06F9, - cWM_06FA, - cWM_06FB, - cWM_06FC, - cWM_06FD, - cWM_06FE, - cWM_06FF, - cWM_0700, - cWM_0701, - cWM_0702, - cWM_0703, - cWM_0704, - cWM_0705, - cWM_0706, - cWM_0707, - cWM_0708, - cWM_0709, - cWM_070A, - cWM_070B, - cWM_070C, - cWM_070D, - cWM_070E, - cWM_070F, - cWM_0710, - cWM_0711, - cWM_0712, - cWM_0713, - cWM_0714, - cWM_0715, - cWM_0716, - cWM_0717, - cWM_0718, - cWM_0719, - cWM_071A, - cWM_071B, - cWM_071C, - cWM_071D, - cWM_071E, - cWM_071F, - cWM_0720, - cWM_0721, - cWM_0722, - cWM_0723, - cWM_0724, - cWM_0725, - cWM_0726, - cWM_0727, - cWM_0728, - cWM_0729, - cWM_072A, - cWM_072B, - cWM_072C, - cWM_072D, - cWM_072E, - cWM_072F, - cWM_0730, - cWM_0731, - cWM_0732, - cWM_0733, - cWM_0734, - cWM_0735, - cWM_0736, - cWM_0737, - cWM_0738, - cWM_0739, - cWM_073A, - cWM_073B, - cWM_073C, - cWM_073D, - cWM_073E, - cWM_073F, - cWM_0740, - cWM_0741, - cWM_0742, - cWM_0743, - cWM_0744, - cWM_0745, - cWM_0746, - cWM_0747, - cWM_0748, - cWM_0749, - cWM_074A, - cWM_074B, - cWM_074C, - cWM_074D, - cWM_074E, - cWM_074F, - cWM_0750, - cWM_0751, - cWM_0752, - cWM_0753, - cWM_0754, - cWM_0755, - cWM_0756, - cWM_0757, - cWM_0758, - cWM_0759, - cWM_075A, - cWM_075B, - cWM_075C, - cWM_075D, - cWM_075E, - cWM_075F, - cWM_0760, - cWM_0761, - cWM_0762, - cWM_0763, - cWM_0764, - cWM_0765, - cWM_0766, - cWM_0767, - cWM_0768, - cWM_0769, - cWM_076A, - cWM_076B, - cWM_076C, - cWM_076D, - cWM_076E, - cWM_076F, - cWM_0770, - cWM_0771, - cWM_0772, - cWM_0773, - cWM_0774, - cWM_0775, - cWM_0776, - cWM_0777, - cWM_0778, - cWM_0779, - cWM_077A, - cWM_077B, - cWM_077C, - cWM_077D, - cWM_077E, - cWM_077F, - cWM_0780, - cWM_0781, - cWM_0782, - cWM_0783, - cWM_0784, - cWM_0785, - cWM_0786, - cWM_0787, - cWM_0788, - cWM_0789, - cWM_078A, - cWM_078B, - cWM_078C, - cWM_078D, - cWM_078E, - cWM_078F, - cWM_0790, - cWM_PRINT, // = 791; - cWM_PRINTCLIENT, // = 792; - cWM_0793, - cWM_0794, - cWM_0795, - cWM_0796, - cWM_0797, - cWM_0798, - cWM_0799, - cWM_079A, - cWM_079B, - cWM_079C, - cWM_079D, - cWM_079E, - cWM_079F, - cWM_07A0, - cWM_07A1, - cWM_07A2, - cWM_07A3, - cWM_07A4, - cWM_07A5, - cWM_07A6, - cWM_07A7, - cWM_07A8, - cWM_07A9, - cWM_07AA, - cWM_07AB, - cWM_07AC, - cWM_07AD, - cWM_07AE, - cWM_07AF, - cWM_07B0, - cWM_07B1, - cWM_07B2, - cWM_07B3, - cWM_07B4, - cWM_07B5, - cWM_07B6, - cWM_07B7, - cWM_07B8, - cWM_07B9, - cWM_07BA, - cWM_07BB, - cWM_07BC, - cWM_07BD, - cWM_07BE, - cWM_07BF, - cWM_07C0, - cWM_07C1, - cWM_07C2, - cWM_07C3, - cWM_07C4, - cWM_07C5, - cWM_07C6, - cWM_07C7, - cWM_07C8, - cWM_07C9, - cWM_07CA, - cWM_07CB, - cWM_07CC, - cWM_07CD, - cWM_07CE, - cWM_07CF, - cWM_07D0, - cWM_07D1, - cWM_07D2, - cWM_07D3, - cWM_07D4, - cWM_07D5, - cWM_07D6, - cWM_07D7, - cWM_07D8, - cWM_07D9, - cWM_07DA, - cWM_07DB, - cWM_07DC, - cWM_07DD, - cWM_07DE, - cWM_07DF, - cWM_07E0, - cWM_07E1, - cWM_07E2, - cWM_07E3, - cWM_07E4, - cWM_07E5, - cWM_07E6, - cWM_07E7, - cWM_07E8, - cWM_07E9, - cWM_07EA, - cWM_07EB, - cWM_07EC, - cWM_07ED, - cWM_07EE, - cWM_07EF, - cWM_07F0, - cWM_07F1, - cWM_07F2, - cWM_07F3, - cWM_07F4, - cWM_07F5, - cWM_07F6, - cWM_07F7, - cWM_07F8, - cWM_07F9, - cWM_07FA, - cWM_07FB, - cWM_07FC, - cWM_07FD, - cWM_07FE, - cWM_07FF, - cWM_0800, - cWM_0801, - cWM_0802, - cWM_0803, - cWM_0804, - cWM_0805, - cWM_0806, - cWM_0807, - cWM_0808, - cWM_0809, - cWM_080A, - cWM_080B, - cWM_080C, - cWM_080D, - cWM_080E, - cWM_080F, - cWM_0810, - cWM_0811, - cWM_0812, - cWM_0813, - cWM_0814, - cWM_0815, - cWM_0816, - cWM_0817, - cWM_0818, - cWM_0819, - cWM_081A, - cWM_081B, - cWM_081C, - cWM_081D, - cWM_081E, - cWM_081F, - cWM_0820, - cWM_0821, - cWM_0822, - cWM_0823, - cWM_0824, - cWM_0825, - cWM_0826, - cWM_0827, - cWM_0828, - cWM_0829, - cWM_082A, - cWM_082B, - cWM_082C, - cWM_082D, - cWM_082E, - cWM_082F, - cWM_0830, - cWM_0831, - cWM_0832, - cWM_0833, - cWM_0834, - cWM_0835, - cWM_0836, - cWM_0837, - cWM_0838, - cWM_0839, - cWM_083A, - cWM_083B, - cWM_083C, - cWM_083D, - cWM_083E, - cWM_083F, - cWM_0840, - cWM_0841, - cWM_0842, - cWM_0843, - cWM_0844, - cWM_0845, - cWM_0846, - cWM_0847, - cWM_0848, - cWM_0849, - cWM_084A, - cWM_084B, - cWM_084C, - cWM_084D, - cWM_084E, - cWM_084F, - cWM_0850, - cWM_0851, - cWM_0852, - cWM_0853, - cWM_0854, - cWM_0855, - cWM_HANDHELDFIRST, // = 856; - cWM_0857, - cWM_0858, - cWM_0859, - cWM_085A, - cWM_085B, - cWM_085C, - cWM_085D, - cWM_085E, - cWM_085F, - cWM_0860, - cWM_0861, - cWM_0862, - cWM_HANDHELDLAST, // = 863; - cWM_0864, - cWM_0865, - cWM_0866, - cWM_0867, - cWM_0868, - cWM_0869, - cWM_086A, - cWM_086B, - cWM_086C, - cWM_086D, - cWM_086E, - cWM_086F, - cWM_0870, - cWM_0871, - cWM_0872, - cWM_0873, - cWM_0874, - cWM_0875, - cWM_0876, - cWM_0877, - cWM_0878, - cWM_0879, - cWM_087A, - cWM_087B, - cWM_087C, - cWM_087D, - cWM_087E, - cWM_087F, - cWM_0880, - cWM_0881, - cWM_0882, - cWM_0883, - cWM_0884, - cWM_0885, - cWM_0886, - cWM_0887, - cWM_0888, - cWM_0889, - cWM_088A, - cWM_088B, - cWM_088C, - cWM_088D, - cWM_088E, - cWM_088F, - cWM_0890, - cWM_0891, - cWM_0892, - cWM_0893, - cWM_0894, - cWM_0895, - cWM_0896, - cWM_0897, - cWM_0898, - cWM_0899, - cWM_089A, - cWM_089B, - cWM_089C, - cWM_089D, - cWM_089E, - cWM_089F, - cWM_08A0, - cWM_08A1, - cWM_08A2, - cWM_08A3, - cWM_08A4, - cWM_08A5, - cWM_08A6, - cWM_08A7, - cWM_08A8, - cWM_08A9, - cWM_08AA, - cWM_08AB, - cWM_08AC, - cWM_08AD, - cWM_08AE, - cWM_08AF, - cWM_08B0, - cWM_08B1, - cWM_08B2, - cWM_08B3, - cWM_08B4, - cWM_08B5, - cWM_08B6, - cWM_08B7, - cWM_08B8, - cWM_08B9, - cWM_08BA, - cWM_08BB, - cWM_08BC, - cWM_08BD, - cWM_08BE, - cWM_08BF, - cWM_08C0, - cWM_08C1, - cWM_08C2, - cWM_08C3, - cWM_08C4, - cWM_08C5, - cWM_08C6, - cWM_08C7, - cWM_08C8, - cWM_08C9, - cWM_08CA, - cWM_08CB, - cWM_08CC, - cWM_08CD, - cWM_08CE, - cWM_08CF, - cWM_08D0, - cWM_08D1, - cWM_08D2, - cWM_08D3, - cWM_08D4, - cWM_08D5, - cWM_08D6, - cWM_08D7, - cWM_08D8, - cWM_08D9, - cWM_08DA, - cWM_08DB, - cWM_08DC, - cWM_08DD, - cWM_08DE, - cWM_08DF, - cWM_08E0, - cWM_08E1, - cWM_08E2, - cWM_08E3, - cWM_08E4, - cWM_08E5, - cWM_08E6, - cWM_08E7, - cWM_08E8, - cWM_08E9, - cWM_08EA, - cWM_08EB, - cWM_08EC, - cWM_08ED, - cWM_08EE, - cWM_08EF, - cWM_08F0, - cWM_08F1, - cWM_08F2, - cWM_08F3, - cWM_08F4, - cWM_08F5, - cWM_08F6, - cWM_08F7, - cWM_08F8, - cWM_08F9, - cWM_08FA, - cWM_08FB, - cWM_08FC, - cWM_08FD, - cWM_08FE, - cWM_08FF, - cWM_0900, - cWM_0901, - cWM_0902, - cWM_0903, - cWM_0904, - cWM_0905, - cWM_0906, - cWM_0907, - cWM_0908, - cWM_0909, - cWM_090A, - cWM_090B, - cWM_090C, - cWM_090D, - cWM_090E, - cWM_090F, - cWM_0910, - cWM_0911, - cWM_0912, - cWM_0913, - cWM_0914, - cWM_0915, - cWM_0916, - cWM_0917, - cWM_0918, - cWM_0919, - cWM_091A, - cWM_091B, - cWM_091C, - cWM_091D, - cWM_091E, - cWM_091F, - cWM_0920, - cWM_0921, - cWM_0922, - cWM_0923, - cWM_0924, - cWM_0925, - cWM_0926, - cWM_0927, - cWM_0928, - cWM_0929, - cWM_092A, - cWM_092B, - cWM_092C, - cWM_092D, - cWM_092E, - cWM_092F, - cWM_0930, - cWM_0931, - cWM_0932, - cWM_0933, - cWM_0934, - cWM_0935, - cWM_0936, - cWM_0937, - cWM_0938, - cWM_0939, - cWM_093A, - cWM_093B, - cWM_093C, - cWM_093D, - cWM_093E, - cWM_093F, - cWM_0940, - cWM_0941, - cWM_0942, - cWM_0943, - cWM_0944, - cWM_0945, - cWM_0946, - cWM_0947, - cWM_0948, - cWM_0949, - cWM_094A, - cWM_094B, - cWM_094C, - cWM_094D, - cWM_094E, - cWM_094F, - cWM_0950, - cWM_0951, - cWM_0952, - cWM_0953, - cWM_0954, - cWM_0955, - cWM_0956, - cWM_0957, - cWM_0958, - cWM_0959, - cWM_095A, - cWM_095B, - cWM_095C, - cWM_095D, - cWM_095E, - cWM_095F, - cWM_0960, - cWM_0961, - cWM_0962, - cWM_0963, - cWM_0964, - cWM_0965, - cWM_0966, - cWM_0967, - cWM_0968, - cWM_0969, - cWM_096A, - cWM_096B, - cWM_096C, - cWM_096D, - cWM_096E, - cWM_096F, - cWM_0970, - cWM_0971, - cWM_0972, - cWM_0973, - cWM_0974, - cWM_0975, - cWM_0976, - cWM_0977, - cWM_0978, - cWM_0979, - cWM_097A, - cWM_097B, - cWM_097C, - cWM_097D, - cWM_097E, - cWM_097F, - cWM_0980, - cWM_0981, - cWM_0982, - cWM_0983, - cWM_0984, - cWM_0985, - cWM_0986, - cWM_0987, - cWM_0988, - cWM_0989, - cWM_098A, - cWM_098B, - cWM_098C, - cWM_098D, - cWM_098E, - cWM_098F, - cWM_0990, - cWM_0991, - cWM_0992, - cWM_0993, - cWM_0994, - cWM_0995, - cWM_0996, - cWM_0997, - cWM_0998, - cWM_0999, - cWM_099A, - cWM_099B, - cWM_099C, - cWM_099D, - cWM_099E, - cWM_099F, - cWM_09A0, - cWM_09A1, - cWM_09A2, - cWM_09A3, - cWM_09A4, - cWM_09A5, - cWM_09A6, - cWM_09A7, - cWM_09A8, - cWM_09A9, - cWM_09AA, - cWM_09AB, - cWM_09AC, - cWM_09AD, - cWM_09AE, - cWM_09AF, - cWM_09B0, - cWM_09B1, - cWM_09B2, - cWM_09B3, - cWM_09B4, - cWM_09B5, - cWM_09B6, - cWM_09B7, - cWM_09B8, - cWM_09B9, - cWM_09BA, - cWM_09BB, - cWM_09BC, - cWM_09BD, - cWM_09BE, - cWM_09BF, - cWM_09C0, - cWM_09C1, - cWM_09C2, - cWM_09C3, - cWM_09C4, - cWM_09C5, - cWM_09C6, - cWM_09C7, - cWM_09C8, - cWM_09C9, - cWM_09CA, - cWM_09CB, - cWM_09CC, - cWM_09CD, - cWM_09CE, - cWM_09CF, - cWM_09D0, - cWM_09D1, - cWM_09D2, - cWM_09D3, - cWM_09D4, - cWM_09D5, - cWM_09D6, - cWM_09D7, - cWM_09D8, - cWM_09D9, - cWM_09DA, - cWM_09DB, - cWM_09DC, - cWM_09DD, - cWM_09DE, - cWM_09DF, - cWM_09E0, - cWM_09E1, - cWM_09E2, - cWM_09E3, - cWM_09E4, - cWM_09E5, - cWM_09E6, - cWM_09E7, - cWM_09E8, - cWM_09E9, - cWM_09EA, - cWM_09EB, - cWM_09EC, - cWM_09ED, - cWM_09EE, - cWM_09EF, - cWM_09F0, - cWM_09F1, - cWM_09F2, - cWM_09F3, - cWM_09F4, - cWM_09F5, - cWM_09F6, - cWM_09F7, - cWM_09F8, - cWM_09F9, - cWM_09FA, - cWM_09FB, - cWM_09FC, - cWM_09FD, - cWM_09FE, - cWM_09FF, - cWM_0A00, - cWM_0A01, - cWM_0A02, - cWM_0A03, - cWM_0A04, - cWM_0A05, - cWM_0A06, - cWM_0A07, - cWM_0A08, - cWM_0A09, - cWM_0A0A, - cWM_0A0B, - cWM_0A0C, - cWM_0A0D, - cWM_0A0E, - cWM_0A0F, - cWM_0A10, - cWM_0A11, - cWM_0A12, - cWM_0A13, - cWM_0A14, - cWM_0A15, - cWM_0A16, - cWM_0A17, - cWM_0A18, - cWM_0A19, - cWM_0A1A, - cWM_0A1B, - cWM_0A1C, - cWM_0A1D, - cWM_0A1E, - cWM_0A1F, - cWM_0A20, - cWM_0A21, - cWM_0A22, - cWM_0A23, - cWM_0A24, - cWM_0A25, - cWM_0A26, - cWM_0A27, - cWM_0A28, - cWM_0A29, - cWM_0A2A, - cWM_0A2B, - cWM_0A2C, - cWM_0A2D, - cWM_0A2E, - cWM_0A2F, - cWM_0A30, - cWM_0A31, - cWM_0A32, - cWM_0A33, - cWM_0A34, - cWM_0A35, - cWM_0A36, - cWM_0A37, - cWM_0A38, - cWM_0A39, - cWM_0A3A, - cWM_0A3B, - cWM_0A3C, - cWM_0A3D, - cWM_0A3E, - cWM_0A3F, - cWM_0A40, - cWM_0A41, - cWM_0A42, - cWM_0A43, - cWM_0A44, - cWM_0A45, - cWM_0A46, - cWM_0A47, - cWM_0A48, - cWM_0A49, - cWM_0A4A, - cWM_0A4B, - cWM_0A4C, - cWM_0A4D, - cWM_0A4E, - cWM_0A4F, - cWM_0A50, - cWM_0A51, - cWM_0A52, - cWM_0A53, - cWM_0A54, - cWM_0A55, - cWM_0A56, - cWM_0A57, - cWM_0A58, - cWM_0A59, - cWM_0A5A, - cWM_0A5B, - cWM_0A5C, - cWM_0A5D, - cWM_0A5E, - cWM_0A5F, - cWM_0A60, - cWM_0A61, - cWM_0A62, - cWM_0A63, - cWM_0A64, - cWM_0A65, - cWM_0A66, - cWM_0A67, - cWM_0A68, - cWM_0A69, - cWM_0A6A, - cWM_0A6B, - cWM_0A6C, - cWM_0A6D, - cWM_0A6E, - cWM_0A6F, - cWM_0A70, - cWM_0A71, - cWM_0A72, - cWM_0A73, - cWM_0A74, - cWM_0A75, - cWM_0A76, - cWM_0A77, - cWM_0A78, - cWM_0A79, - cWM_0A7A, - cWM_0A7B, - cWM_0A7C, - cWM_0A7D, - cWM_0A7E, - cWM_0A7F, - cWM_0A80, - cWM_0A81, - cWM_0A82, - cWM_0A83, - cWM_0A84, - cWM_0A85, - cWM_0A86, - cWM_0A87, - cWM_0A88, - cWM_0A89, - cWM_0A8A, - cWM_0A8B, - cWM_0A8C, - cWM_0A8D, - cWM_0A8E, - cWM_0A8F, - cWM_0A90, - cWM_0A91, - cWM_0A92, - cWM_0A93, - cWM_0A94, - cWM_0A95, - cWM_0A96, - cWM_0A97, - cWM_0A98, - cWM_0A99, - cWM_0A9A, - cWM_0A9B, - cWM_0A9C, - cWM_0A9D, - cWM_0A9E, - cWM_0A9F, - cWM_0AA0, - cWM_0AA1, - cWM_0AA2, - cWM_0AA3, - cWM_0AA4, - cWM_0AA5, - cWM_0AA6, - cWM_0AA7, - cWM_0AA8, - cWM_0AA9, - cWM_0AAA, - cWM_0AAB, - cWM_0AAC, - cWM_0AAD, - cWM_0AAE, - cWM_0AAF, - cWM_0AB0, - cWM_0AB1, - cWM_0AB2, - cWM_0AB3, - cWM_0AB4, - cWM_0AB5, - cWM_0AB6, - cWM_0AB7, - cWM_0AB8, - cWM_0AB9, - cWM_0ABA, - cWM_0ABB, - cWM_0ABC, - cWM_0ABD, - cWM_0ABE, - cWM_0ABF, - cWM_0AC0, - cWM_0AC1, - cWM_0AC2, - cWM_0AC3, - cWM_0AC4, - cWM_0AC5, - cWM_0AC6, - cWM_0AC7, - cWM_0AC8, - cWM_0AC9, - cWM_0ACA, - cWM_0ACB, - cWM_0ACC, - cWM_0ACD, - cWM_0ACE, - cWM_0ACF, - cWM_0AD0, - cWM_0AD1, - cWM_0AD2, - cWM_0AD3, - cWM_0AD4, - cWM_0AD5, - cWM_0AD6, - cWM_0AD7, - cWM_0AD8, - cWM_0AD9, - cWM_0ADA, - cWM_0ADB, - cWM_0ADC, - cWM_0ADD, - cWM_0ADE, - cWM_0ADF, - cWM_0AE0, - cWM_0AE1, - cWM_0AE2, - cWM_0AE3, - cWM_0AE4, - cWM_0AE5, - cWM_0AE6, - cWM_0AE7, - cWM_0AE8, - cWM_0AE9, - cWM_0AEA, - cWM_0AEB, - cWM_0AEC, - cWM_0AED, - cWM_0AEE, - cWM_0AEF, - cWM_0AF0, - cWM_0AF1, - cWM_0AF2, - cWM_0AF3, - cWM_0AF4, - cWM_0AF5, - cWM_0AF6, - cWM_0AF7, - cWM_0AF8, - cWM_0AF9, - cWM_0AFA, - cWM_0AFB, - cWM_0AFC, - cWM_0AFD, - cWM_0AFE, - cWM_0AFF, - cWM_0B00, - cWM_0B01, - cWM_0B02, - cWM_0B03, - cWM_0B04, - cWM_0B05, - cWM_0B06, - cWM_0B07, - cWM_0B08, - cWM_0B09, - cWM_0B0A, - cWM_0B0B, - cWM_0B0C, - cWM_0B0D, - cWM_0B0E, - cWM_0B0F, - cWM_0B10, - cWM_0B11, - cWM_0B12, - cWM_0B13, - cWM_0B14, - cWM_0B15, - cWM_0B16, - cWM_0B17, - cWM_0B18, - cWM_0B19, - cWM_0B1A, - cWM_0B1B, - cWM_0B1C, - cWM_0B1D, - cWM_0B1E, - cWM_0B1F, - cWM_0B20, - cWM_0B21, - cWM_0B22, - cWM_0B23, - cWM_0B24, - cWM_0B25, - cWM_0B26, - cWM_0B27, - cWM_0B28, - cWM_0B29, - cWM_0B2A, - cWM_0B2B, - cWM_0B2C, - cWM_0B2D, - cWM_0B2E, - cWM_0B2F, - cWM_0B30, - cWM_0B31, - cWM_0B32, - cWM_0B33, - cWM_0B34, - cWM_0B35, - cWM_0B36, - cWM_0B37, - cWM_0B38, - cWM_0B39, - cWM_0B3A, - cWM_0B3B, - cWM_0B3C, - cWM_0B3D, - cWM_0B3E, - cWM_0B3F, - cWM_0B40, - cWM_0B41, - cWM_0B42, - cWM_0B43, - cWM_0B44, - cWM_0B45, - cWM_0B46, - cWM_0B47, - cWM_0B48, - cWM_0B49, - cWM_0B4A, - cWM_0B4B, - cWM_0B4C, - cWM_0B4D, - cWM_0B4E, - cWM_0B4F, - cWM_0B50, - cWM_0B51, - cWM_0B52, - cWM_0B53, - cWM_0B54, - cWM_0B55, - cWM_0B56, - cWM_0B57, - cWM_0B58, - cWM_0B59, - cWM_0B5A, - cWM_0B5B, - cWM_0B5C, - cWM_0B5D, - cWM_0B5E, - cWM_0B5F, - cWM_0B60, - cWM_0B61, - cWM_0B62, - cWM_0B63, - cWM_0B64, - cWM_0B65, - cWM_0B66, - cWM_0B67, - cWM_0B68, - cWM_0B69, - cWM_0B6A, - cWM_0B6B, - cWM_0B6C, - cWM_0B6D, - cWM_0B6E, - cWM_0B6F, - cWM_0B70, - cWM_0B71, - cWM_0B72, - cWM_0B73, - cWM_0B74, - cWM_0B75, - cWM_0B76, - cWM_0B77, - cWM_0B78, - cWM_0B79, - cWM_0B7A, - cWM_0B7B, - cWM_0B7C, - cWM_0B7D, - cWM_0B7E, - cWM_0B7F, - cWM_0B80, - cWM_0B81, - cWM_0B82, - cWM_0B83, - cWM_0B84, - cWM_0B85, - cWM_0B86, - cWM_0B87, - cWM_0B88, - cWM_0B89, - cWM_0B8A, - cWM_0B8B, - cWM_0B8C, - cWM_0B8D, - cWM_0B8E, - cWM_0B8F, - cWM_0B90, - cWM_0B91, - cWM_0B92, - cWM_0B93, - cWM_0B94, - cWM_0B95, - cWM_0B96, - cWM_0B97, - cWM_0B98, - cWM_0B99, - cWM_0B9A, - cWM_0B9B, - cWM_0B9C, - cWM_0B9D, - cWM_0B9E, - cWM_0B9F, - cWM_0BA0, - cWM_0BA1, - cWM_0BA2, - cWM_0BA3, - cWM_0BA4, - cWM_0BA5, - cWM_0BA6, - cWM_0BA7, - cWM_0BA8, - cWM_0BA9, - cWM_0BAA, - cWM_0BAB, - cWM_0BAC, - cWM_0BAD, - cWM_0BAE, - cWM_0BAF, - cWM_0BB0, - cWM_0BB1, - cWM_0BB2, - cWM_0BB3, - cWM_0BB4, - cWM_0BB5, - cWM_0BB6, - cWM_0BB7, - cWM_0BB8, - cWM_0BB9, - cWM_0BBA, - cWM_0BBB, - cWM_0BBC, - cWM_0BBD, - cWM_0BBE, - cWM_0BBF, - cWM_0BC0, - cWM_0BC1, - cWM_0BC2, - cWM_0BC3, - cWM_0BC4, - cWM_0BC5, - cWM_0BC6, - cWM_0BC7, - cWM_0BC8, - cWM_0BC9, - cWM_0BCA, - cWM_0BCB, - cWM_0BCC, - cWM_0BCD, - cWM_0BCE, - cWM_0BCF, - cWM_0BD0, - cWM_0BD1, - cWM_0BD2, - cWM_0BD3, - cWM_0BD4, - cWM_0BD5, - cWM_0BD6, - cWM_0BD7, - cWM_0BD8, - cWM_0BD9, - cWM_0BDA, - cWM_0BDB, - cWM_0BDC, - cWM_0BDD, - cWM_0BDE, - cWM_0BDF, - cWM_0BE0, - cWM_0BE1, - cWM_0BE2, - cWM_0BE3, - cWM_0BE4, - cWM_0BE5, - cWM_0BE6, - cWM_0BE7, - cWM_0BE8, - cWM_0BE9, - cWM_0BEA, - cWM_0BEB, - cWM_0BEC, - cWM_0BED, - cWM_0BEE, - cWM_0BEF, - cWM_0BF0, - cWM_0BF1, - cWM_0BF2, - cWM_0BF3, - cWM_0BF4, - cWM_0BF5, - cWM_0BF6, - cWM_0BF7, - cWM_0BF8, - cWM_0BF9, - cWM_0BFA, - cWM_0BFB, - cWM_0BFC, - cWM_0BFD, - cWM_0BFE, - cWM_0BFF, - cWM_0C00, - cWM_0C01, - cWM_0C02, - cWM_0C03, - cWM_0C04, - cWM_0C05, - cWM_0C06, - cWM_0C07, - cWM_0C08, - cWM_0C09, - cWM_0C0A, - cWM_0C0B, - cWM_0C0C, - cWM_0C0D, - cWM_0C0E, - cWM_0C0F, - cWM_0C10, - cWM_0C11, - cWM_0C12, - cWM_0C13, - cWM_0C14, - cWM_0C15, - cWM_0C16, - cWM_0C17, - cWM_0C18, - cWM_0C19, - cWM_0C1A, - cWM_0C1B, - cWM_0C1C, - cWM_0C1D, - cWM_0C1E, - cWM_0C1F, - cWM_0C20, - cWM_0C21, - cWM_0C22, - cWM_0C23, - cWM_0C24, - cWM_0C25, - cWM_0C26, - cWM_0C27, - cWM_0C28, - cWM_0C29, - cWM_0C2A, - cWM_0C2B, - cWM_0C2C, - cWM_0C2D, - cWM_0C2E, - cWM_0C2F, - cWM_0C30, - cWM_0C31, - cWM_0C32, - cWM_0C33, - cWM_0C34, - cWM_0C35, - cWM_0C36, - cWM_0C37, - cWM_0C38, - cWM_0C39, - cWM_0C3A, - cWM_0C3B, - cWM_0C3C, - cWM_0C3D, - cWM_0C3E, - cWM_0C3F, - cWM_0C40, - cWM_0C41, - cWM_0C42, - cWM_0C43, - cWM_0C44, - cWM_0C45, - cWM_0C46, - cWM_0C47, - cWM_0C48, - cWM_0C49, - cWM_0C4A, - cWM_0C4B, - cWM_0C4C, - cWM_0C4D, - cWM_0C4E, - cWM_0C4F, - cWM_0C50, - cWM_0C51, - cWM_0C52, - cWM_0C53, - cWM_0C54, - cWM_0C55, - cWM_0C56, - cWM_0C57, - cWM_0C58, - cWM_0C59, - cWM_0C5A, - cWM_0C5B, - cWM_0C5C, - cWM_0C5D, - cWM_0C5E, - cWM_0C5F, - cWM_0C60, - cWM_0C61, - cWM_0C62, - cWM_0C63, - cWM_0C64, - cWM_0C65, - cWM_0C66, - cWM_0C67, - cWM_0C68, - cWM_0C69, - cWM_0C6A, - cWM_0C6B, - cWM_0C6C, - cWM_0C6D, - cWM_0C6E, - cWM_0C6F, - cWM_0C70, - cWM_0C71, - cWM_0C72, - cWM_0C73, - cWM_0C74, - cWM_0C75, - cWM_0C76, - cWM_0C77, - cWM_0C78, - cWM_0C79, - cWM_0C7A, - cWM_0C7B, - cWM_0C7C, - cWM_0C7D, - cWM_0C7E, - cWM_0C7F, - cWM_0C80, - cWM_0C81, - cWM_0C82, - cWM_0C83, - cWM_0C84, - cWM_0C85, - cWM_0C86, - cWM_0C87, - cWM_0C88, - cWM_0C89, - cWM_0C8A, - cWM_0C8B, - cWM_0C8C, - cWM_0C8D, - cWM_0C8E, - cWM_0C8F, - cWM_0C90, - cWM_0C91, - cWM_0C92, - cWM_0C93, - cWM_0C94, - cWM_0C95, - cWM_0C96, - cWM_0C97, - cWM_0C98, - cWM_0C99, - cWM_0C9A, - cWM_0C9B, - cWM_0C9C, - cWM_0C9D, - cWM_0C9E, - cWM_0C9F, - cWM_0CA0, - cWM_0CA1, - cWM_0CA2, - cWM_0CA3, - cWM_0CA4, - cWM_0CA5, - cWM_0CA6, - cWM_0CA7, - cWM_0CA8, - cWM_0CA9, - cWM_0CAA, - cWM_0CAB, - cWM_0CAC, - cWM_0CAD, - cWM_0CAE, - cWM_0CAF, - cWM_0CB0, - cWM_0CB1, - cWM_0CB2, - cWM_0CB3, - cWM_0CB4, - cWM_0CB5, - cWM_0CB6, - cWM_0CB7, - cWM_0CB8, - cWM_0CB9, - cWM_0CBA, - cWM_0CBB, - cWM_0CBC, - cWM_0CBD, - cWM_0CBE, - cWM_0CBF, - cWM_0CC0, - cWM_0CC1, - cWM_0CC2, - cWM_0CC3, - cWM_0CC4, - cWM_0CC5, - cWM_0CC6, - cWM_0CC7, - cWM_0CC8, - cWM_0CC9, - cWM_0CCA, - cWM_0CCB, - cWM_0CCC, - cWM_0CCD, - cWM_0CCE, - cWM_0CCF, - cWM_0CD0, - cWM_0CD1, - cWM_0CD2, - cWM_0CD3, - cWM_0CD4, - cWM_0CD5, - cWM_0CD6, - cWM_0CD7, - cWM_0CD8, - cWM_0CD9, - cWM_0CDA, - cWM_0CDB, - cWM_0CDC, - cWM_0CDD, - cWM_0CDE, - cWM_0CDF, - cWM_0CE0, - cWM_0CE1, - cWM_0CE2, - cWM_0CE3, - cWM_0CE4, - cWM_0CE5, - cWM_0CE6, - cWM_0CE7, - cWM_0CE8, - cWM_0CE9, - cWM_0CEA, - cWM_0CEB, - cWM_0CEC, - cWM_0CED, - cWM_0CEE, - cWM_0CEF, - cWM_0CF0, - cWM_0CF1, - cWM_0CF2, - cWM_0CF3, - cWM_0CF4, - cWM_0CF5, - cWM_0CF6, - cWM_0CF7, - cWM_0CF8, - cWM_0CF9, - cWM_0CFA, - cWM_0CFB, - cWM_0CFC, - cWM_0CFD, - cWM_0CFE, - cWM_0CFF, - cWM_0D00, - cWM_0D01, - cWM_0D02, - cWM_0D03, - cWM_0D04, - cWM_0D05, - cWM_0D06, - cWM_0D07, - cWM_0D08, - cWM_0D09, - cWM_0D0A, - cWM_0D0B, - cWM_0D0C, - cWM_0D0D, - cWM_0D0E, - cWM_0D0F, - cWM_0D10, - cWM_0D11, - cWM_0D12, - cWM_0D13, - cWM_0D14, - cWM_0D15, - cWM_0D16, - cWM_0D17, - cWM_0D18, - cWM_0D19, - cWM_0D1A, - cWM_0D1B, - cWM_0D1C, - cWM_0D1D, - cWM_0D1E, - cWM_0D1F, - cWM_0D20, - cWM_0D21, - cWM_0D22, - cWM_0D23, - cWM_0D24, - cWM_0D25, - cWM_0D26, - cWM_0D27, - cWM_0D28, - cWM_0D29, - cWM_0D2A, - cWM_0D2B, - cWM_0D2C, - cWM_0D2D, - cWM_0D2E, - cWM_0D2F, - cWM_0D30, - cWM_0D31, - cWM_0D32, - cWM_0D33, - cWM_0D34, - cWM_0D35, - cWM_0D36, - cWM_0D37, - cWM_0D38, - cWM_0D39, - cWM_0D3A, - cWM_0D3B, - cWM_0D3C, - cWM_0D3D, - cWM_0D3E, - cWM_0D3F, - cWM_0D40, - cWM_0D41, - cWM_0D42, - cWM_0D43, - cWM_0D44, - cWM_0D45, - cWM_0D46, - cWM_0D47, - cWM_0D48, - cWM_0D49, - cWM_0D4A, - cWM_0D4B, - cWM_0D4C, - cWM_0D4D, - cWM_0D4E, - cWM_0D4F, - cWM_0D50, - cWM_0D51, - cWM_0D52, - cWM_0D53, - cWM_0D54, - cWM_0D55, - cWM_0D56, - cWM_0D57, - cWM_0D58, - cWM_0D59, - cWM_0D5A, - cWM_0D5B, - cWM_0D5C, - cWM_0D5D, - cWM_0D5E, - cWM_0D5F, - cWM_0D60, - cWM_0D61, - cWM_0D62, - cWM_0D63, - cWM_0D64, - cWM_0D65, - cWM_0D66, - cWM_0D67, - cWM_0D68, - cWM_0D69, - cWM_0D6A, - cWM_0D6B, - cWM_0D6C, - cWM_0D6D, - cWM_0D6E, - cWM_0D6F, - cWM_0D70, - cWM_0D71, - cWM_0D72, - cWM_0D73, - cWM_0D74, - cWM_0D75, - cWM_0D76, - cWM_0D77, - cWM_0D78, - cWM_0D79, - cWM_0D7A, - cWM_0D7B, - cWM_0D7C, - cWM_0D7D, - cWM_0D7E, - cWM_0D7F, - cWM_0D80, - cWM_0D81, - cWM_0D82, - cWM_0D83, - cWM_0D84, - cWM_0D85, - cWM_0D86, - cWM_0D87, - cWM_0D88, - cWM_0D89, - cWM_0D8A, - cWM_0D8B, - cWM_0D8C, - cWM_0D8D, - cWM_0D8E, - cWM_0D8F, - cWM_0D90, - cWM_0D91, - cWM_0D92, - cWM_0D93, - cWM_0D94, - cWM_0D95, - cWM_0D96, - cWM_0D97, - cWM_0D98, - cWM_0D99, - cWM_0D9A, - cWM_0D9B, - cWM_0D9C, - cWM_0D9D, - cWM_0D9E, - cWM_0D9F, - cWM_0DA0, - cWM_0DA1, - cWM_0DA2, - cWM_0DA3, - cWM_0DA4, - cWM_0DA5, - cWM_0DA6, - cWM_0DA7, - cWM_0DA8, - cWM_0DA9, - cWM_0DAA, - cWM_0DAB, - cWM_0DAC, - cWM_0DAD, - cWM_0DAE, - cWM_0DAF, - cWM_0DB0, - cWM_0DB1, - cWM_0DB2, - cWM_0DB3, - cWM_0DB4, - cWM_0DB5, - cWM_0DB6, - cWM_0DB7, - cWM_0DB8, - cWM_0DB9, - cWM_0DBA, - cWM_0DBB, - cWM_0DBC, - cWM_0DBD, - cWM_0DBE, - cWM_0DBF, - cWM_0DC0, - cWM_0DC1, - cWM_0DC2, - cWM_0DC3, - cWM_0DC4, - cWM_0DC5, - cWM_0DC6, - cWM_0DC7, - cWM_0DC8, - cWM_0DC9, - cWM_0DCA, - cWM_0DCB, - cWM_0DCC, - cWM_0DCD, - cWM_0DCE, - cWM_0DCF, - cWM_0DD0, - cWM_0DD1, - cWM_0DD2, - cWM_0DD3, - cWM_0DD4, - cWM_0DD5, - cWM_0DD6, - cWM_0DD7, - cWM_0DD8, - cWM_0DD9, - cWM_0DDA, - cWM_0DDB, - cWM_0DDC, - cWM_0DDD, - cWM_0DDE, - cWM_0DDF, - cWM_0DE0, - cWM_0DE1, - cWM_0DE2, - cWM_0DE3, - cWM_0DE4, - cWM_0DE5, - cWM_0DE6, - cWM_0DE7, - cWM_0DE8, - cWM_0DE9, - cWM_0DEA, - cWM_0DEB, - cWM_0DEC, - cWM_0DED, - cWM_0DEE, - cWM_0DEF, - cWM_0DF0, - cWM_0DF1, - cWM_0DF2, - cWM_0DF3, - cWM_0DF4, - cWM_0DF5, - cWM_0DF6, - cWM_0DF7, - cWM_0DF8, - cWM_0DF9, - cWM_0DFA, - cWM_0DFB, - cWM_0DFC, - cWM_0DFD, - cWM_0DFE, - cWM_0DFF, - cWM_0E00, - cWM_0E01, - cWM_0E02, - cWM_0E03, - cWM_0E04, - cWM_0E05, - cWM_0E06, - cWM_0E07, - cWM_0E08, - cWM_0E09, - cWM_0E0A, - cWM_0E0B, - cWM_0E0C, - cWM_0E0D, - cWM_0E0E, - cWM_0E0F, - cWM_0E10, - cWM_0E11, - cWM_0E12, - cWM_0E13, - cWM_0E14, - cWM_0E15, - cWM_0E16, - cWM_0E17, - cWM_0E18, - cWM_0E19, - cWM_0E1A, - cWM_0E1B, - cWM_0E1C, - cWM_0E1D, - cWM_0E1E, - cWM_0E1F, - cWM_0E20, - cWM_0E21, - cWM_0E22, - cWM_0E23, - cWM_0E24, - cWM_0E25, - cWM_0E26, - cWM_0E27, - cWM_0E28, - cWM_0E29, - cWM_0E2A, - cWM_0E2B, - cWM_0E2C, - cWM_0E2D, - cWM_0E2E, - cWM_0E2F, - cWM_0E30, - cWM_0E31, - cWM_0E32, - cWM_0E33, - cWM_0E34, - cWM_0E35, - cWM_0E36, - cWM_0E37, - cWM_0E38, - cWM_0E39, - cWM_0E3A, - cWM_0E3B, - cWM_0E3C, - cWM_0E3D, - cWM_0E3E, - cWM_0E3F, - cWM_0E40, - cWM_0E41, - cWM_0E42, - cWM_0E43, - cWM_0E44, - cWM_0E45, - cWM_0E46, - cWM_0E47, - cWM_0E48, - cWM_0E49, - cWM_0E4A, - cWM_0E4B, - cWM_0E4C, - cWM_0E4D, - cWM_0E4E, - cWM_0E4F, - cWM_0E50, - cWM_0E51, - cWM_0E52, - cWM_0E53, - cWM_0E54, - cWM_0E55, - cWM_0E56, - cWM_0E57, - cWM_0E58, - cWM_0E59, - cWM_0E5A, - cWM_0E5B, - cWM_0E5C, - cWM_0E5D, - cWM_0E5E, - cWM_0E5F, - cWM_0E60, - cWM_0E61, - cWM_0E62, - cWM_0E63, - cWM_0E64, - cWM_0E65, - cWM_0E66, - cWM_0E67, - cWM_0E68, - cWM_0E69, - cWM_0E6A, - cWM_0E6B, - cWM_0E6C, - cWM_0E6D, - cWM_0E6E, - cWM_0E6F, - cWM_0E70, - cWM_0E71, - cWM_0E72, - cWM_0E73, - cWM_0E74, - cWM_0E75, - cWM_0E76, - cWM_0E77, - cWM_0E78, - cWM_0E79, - cWM_0E7A, - cWM_0E7B, - cWM_0E7C, - cWM_0E7D, - cWM_0E7E, - cWM_0E7F, - cWM_0E80, - cWM_0E81, - cWM_0E82, - cWM_0E83, - cWM_0E84, - cWM_0E85, - cWM_0E86, - cWM_0E87, - cWM_0E88, - cWM_0E89, - cWM_0E8A, - cWM_0E8B, - cWM_0E8C, - cWM_0E8D, - cWM_0E8E, - cWM_0E8F, - cWM_0E90, - cWM_0E91, - cWM_0E92, - cWM_0E93, - cWM_0E94, - cWM_0E95, - cWM_0E96, - cWM_0E97, - cWM_0E98, - cWM_0E99, - cWM_0E9A, - cWM_0E9B, - cWM_0E9C, - cWM_0E9D, - cWM_0E9E, - cWM_0E9F, - cWM_0EA0, - cWM_0EA1, - cWM_0EA2, - cWM_0EA3, - cWM_0EA4, - cWM_0EA5, - cWM_0EA6, - cWM_0EA7, - cWM_0EA8, - cWM_0EA9, - cWM_0EAA, - cWM_0EAB, - cWM_0EAC, - cWM_0EAD, - cWM_0EAE, - cWM_0EAF, - cWM_0EB0, - cWM_0EB1, - cWM_0EB2, - cWM_0EB3, - cWM_0EB4, - cWM_0EB5, - cWM_0EB6, - cWM_0EB7, - cWM_0EB8, - cWM_0EB9, - cWM_0EBA, - cWM_0EBB, - cWM_0EBC, - cWM_0EBD, - cWM_0EBE, - cWM_0EBF, - cWM_0EC0, - cWM_0EC1, - cWM_0EC2, - cWM_0EC3, - cWM_0EC4, - cWM_0EC5, - cWM_0EC6, - cWM_0EC7, - cWM_0EC8, - cWM_0EC9, - cWM_0ECA, - cWM_0ECB, - cWM_0ECC, - cWM_0ECD, - cWM_0ECE, - cWM_0ECF, - cWM_0ED0, - cWM_0ED1, - cWM_0ED2, - cWM_0ED3, - cWM_0ED4, - cWM_0ED5, - cWM_0ED6, - cWM_0ED7, - cWM_0ED8, - cWM_0ED9, - cWM_0EDA, - cWM_0EDB, - cWM_0EDC, - cWM_0EDD, - cWM_0EDE, - cWM_0EDF, - cWM_0EE0, - cWM_0EE1, - cWM_0EE2, - cWM_0EE3, - cWM_0EE4, - cWM_0EE5, - cWM_0EE6, - cWM_0EE7, - cWM_0EE8, - cWM_0EE9, - cWM_0EEA, - cWM_0EEB, - cWM_0EEC, - cWM_0EED, - cWM_0EEE, - cWM_0EEF, - cWM_0EF0, - cWM_0EF1, - cWM_0EF2, - cWM_0EF3, - cWM_0EF4, - cWM_0EF5, - cWM_0EF6, - cWM_0EF7, - cWM_0EF8, - cWM_0EF9, - cWM_0EFA, - cWM_0EFB, - cWM_0EFC, - cWM_0EFD, - cWM_0EFE, - cWM_0EFF, - cWM_0F00, - cWM_0F01, - cWM_0F02, - cWM_0F03, - cWM_0F04, - cWM_0F05, - cWM_0F06, - cWM_0F07, - cWM_0F08, - cWM_0F09, - cWM_0F0A, - cWM_0F0B, - cWM_0F0C, - cWM_0F0D, - cWM_0F0E, - cWM_0F0F, - cWM_0F10, - cWM_0F11, - cWM_0F12, - cWM_0F13, - cWM_0F14, - cWM_0F15, - cWM_0F16, - cWM_0F17, - cWM_0F18, - cWM_0F19, - cWM_0F1A, - cWM_0F1B, - cWM_0F1C, - cWM_0F1D, - cWM_0F1E, - cWM_0F1F, - cWM_0F20, - cWM_0F21, - cWM_0F22, - cWM_0F23, - cWM_0F24, - cWM_0F25, - cWM_0F26, - cWM_0F27, - cWM_0F28, - cWM_0F29, - cWM_0F2A, - cWM_0F2B, - cWM_0F2C, - cWM_0F2D, - cWM_0F2E, - cWM_0F2F, - cWM_0F30, - cWM_0F31, - cWM_0F32, - cWM_0F33, - cWM_0F34, - cWM_0F35, - cWM_0F36, - cWM_0F37, - cWM_0F38, - cWM_0F39, - cWM_0F3A, - cWM_0F3B, - cWM_0F3C, - cWM_0F3D, - cWM_0F3E, - cWM_0F3F, - cWM_0F40, - cWM_0F41, - cWM_0F42, - cWM_0F43, - cWM_0F44, - cWM_0F45, - cWM_0F46, - cWM_0F47, - cWM_0F48, - cWM_0F49, - cWM_0F4A, - cWM_0F4B, - cWM_0F4C, - cWM_0F4D, - cWM_0F4E, - cWM_0F4F, - cWM_0F50, - cWM_0F51, - cWM_0F52, - cWM_0F53, - cWM_0F54, - cWM_0F55, - cWM_0F56, - cWM_0F57, - cWM_0F58, - cWM_0F59, - cWM_0F5A, - cWM_0F5B, - cWM_0F5C, - cWM_0F5D, - cWM_0F5E, - cWM_0F5F, - cWM_0F60, - cWM_0F61, - cWM_0F62, - cWM_0F63, - cWM_0F64, - cWM_0F65, - cWM_0F66, - cWM_0F67, - cWM_0F68, - cWM_0F69, - cWM_0F6A, - cWM_0F6B, - cWM_0F6C, - cWM_0F6D, - cWM_0F6E, - cWM_0F6F, - cWM_0F70, - cWM_0F71, - cWM_0F72, - cWM_0F73, - cWM_0F74, - cWM_0F75, - cWM_0F76, - cWM_0F77, - cWM_0F78, - cWM_0F79, - cWM_0F7A, - cWM_0F7B, - cWM_0F7C, - cWM_0F7D, - cWM_0F7E, - cWM_0F7F, - cWM_0F80, - cWM_0F81, - cWM_0F82, - cWM_0F83, - cWM_0F84, - cWM_0F85, - cWM_0F86, - cWM_0F87, - cWM_0F88, - cWM_0F89, - cWM_0F8A, - cWM_0F8B, - cWM_0F8C, - cWM_0F8D, - cWM_0F8E, - cWM_0F8F, - cWM_0F90, - cWM_0F91, - cWM_0F92, - cWM_0F93, - cWM_0F94, - cWM_0F95, - cWM_0F96, - cWM_0F97, - cWM_0F98, - cWM_0F99, - cWM_0F9A, - cWM_0F9B, - cWM_0F9C, - cWM_0F9D, - cWM_0F9E, - cWM_0F9F, - cWM_0FA0, - cWM_0FA1, - cWM_0FA2, - cWM_0FA3, - cWM_0FA4, - cWM_0FA5, - cWM_0FA6, - cWM_0FA7, - cWM_0FA8, - cWM_0FA9, - cWM_0FAA, - cWM_0FAB, - cWM_0FAC, - cWM_0FAD, - cWM_0FAE, - cWM_0FAF, - cWM_0FB0, - cWM_0FB1, - cWM_0FB2, - cWM_0FB3, - cWM_0FB4, - cWM_0FB5, - cWM_0FB6, - cWM_0FB7, - cWM_0FB8, - cWM_0FB9, - cWM_0FBA, - cWM_0FBB, - cWM_0FBC, - cWM_0FBD, - cWM_0FBE, - cWM_0FBF, - cWM_0FC0, - cWM_0FC1, - cWM_0FC2, - cWM_0FC3, - cWM_0FC4, - cWM_0FC5, - cWM_0FC6, - cWM_0FC7, - cWM_0FC8, - cWM_0FC9, - cWM_0FCA, - cWM_0FCB, - cWM_0FCC, - cWM_0FCD, - cWM_0FCE, - cWM_0FCF, - cWM_0FD0, - cWM_0FD1, - cWM_0FD2, - cWM_0FD3, - cWM_0FD4, - cWM_0FD5, - cWM_0FD6, - cWM_0FD7, - cWM_0FD8, - cWM_0FD9, - cWM_0FDA, - cWM_0FDB, - cWM_0FDC, - cWM_0FDD, - cWM_0FDE, - cWM_0FDF, - cWM_0FE0, - cWM_0FE1, - cWM_0FE2, - cWM_0FE3, - cWM_0FE4, - cWM_0FE5, - cWM_0FE6, - cWM_0FE7, - cWM_0FE8, - cWM_0FE9, - cWM_0FEA, - cWM_0FEB, - cWM_0FEC, - cWM_0FED, - cWM_0FEE, - cWM_0FEF, - cWM_0FF0, - cWM_0FF1, - cWM_0FF2, - cWM_0FF3, - cWM_0FF4, - cWM_0FF5, - cWM_0FF6, - cWM_0FF7, - cWM_0FF8, - cWM_0FF9, - cWM_0FFA, - cWM_0FFB, - cWM_0FFC, - cWM_0FFD, - cWM_0FFE, - cWM_0FFF, - //LVM_FIRST = $1000; { ListView messages } - cLVM_GETBKCOLOR, // = LVM_FIRST + 0; - cLVM_SETBKCOLOR, // = LVM_FIRST + 1; - cLVM_GETIMAGELIST, // = LVM_FIRST + 2; - cLVM_SETIMAGELIST, // = LVM_FIRST + 3; - cLVM_GETITEMCOUNT, // = LVM_FIRST + 4; - cLVM_GETITEMA, // = LVM_FIRST + 5; - cLVM_SETITEMA, // = LVM_FIRST + 6; - cLVM_INSERTITEMA, // = LVM_FIRST + 7; - cLVM_DELETEITEM, // = LVM_FIRST + 8; - cLVM_DELETEALLITEMS, // = LVM_FIRST + 9; - cLVM_GETCALLBACKMASK,// = LVM_FIRST + 10; - cLVM_SETCALLBACKMASK,// = LVM_FIRST + 11; - cLVM_GETNEXTITEM, // = LVM_FIRST + 12; - cLVM_FINDITEMA, // = LVM_FIRST + 13; - cLVM_GETITEMRECT, // = LVM_FIRST + 14; - cLVM_SETITEMPOSITION,// = LVM_FIRST + 15; - cLVM_GETITEMPOSITION,// = LVM_FIRST + 16; - cLVM_GETSTRINGWIDTHA,// = LVM_FIRST + 17; - cLVM_HITTEST, // = LVM_FIRST + 18; - cLVM_ENSUREVISIBLE, // = LVM_FIRST + 19; - cLVM_SCROLL, // = LVM_FIRST + 20; - cLVM_REDRAWITEMS, // = LVM_FIRST + 21; - cLVM_ARRANGE, // = LVM_FIRST + 22; - cLVM_EDITLABELA, // = LVM_FIRST + 23; - cWM_1018, - cLVM_GETCOLUMNA, // = LVM_FIRST + 25; - cLVM_SETCOLUMNA, // = LVM_FIRST + 26; - cLVM_INSERTCOLUMNA, // = LVM_FIRST + 27; - cLVM_DELETECOLUMN, // = LVM_FIRST + 28; - cLVM_GETCOLUMNWIDTH, // = LVM_FIRST + 29; - cLVM_SETCOLUMNWIDTH, // = LVM_FIRST + 30; - cLVM_GETHEADER, // = LVM_FIRST + 31; - cWM_1020, - cLVM_CREATEDRAGIMAGE,// = LVM_FIRST + 33; - cLVM_GETVIEWRECT, // = LVM_FIRST + 34; - cLVM_GETTEXTCOLOR, // = LVM_FIRST + 35; - cLVM_SETTEXTCOLOR, // = LVM_FIRST + 36; - cLVM_GETTEXTBKCOLOR, // = LVM_FIRST + 37; - cLVM_SETTEXTBKCOLOR, // = LVM_FIRST + 38; - cLVM_GETTOPINDEX, // = LVM_FIRST + 39; - cLVM_GETCOUNTPERPAGE,// = LVM_FIRST + 40; - cLVM_GETORIGIN, // = LVM_FIRST + 41; - cLVM_UPDATE, // = LVM_FIRST + 42; - cLVM_SETITEMSTATE, // = LVM_FIRST + 43; - cLVM_GETITEMSTATE, // = LVM_FIRST + 44; - cLVM_GETITEMTEXTA, // = LVM_FIRST + 45; - cLVM_SETITEMTEXTA, // = LVM_FIRST + 46; - cLVM_SETITEMCOUNT, // = LVM_FIRST + 47; - cLVM_SORTITEMS, // = LVM_FIRST + 48; - cLVM_SETITEMPOSITION32, // = LVM_FIRST + 49; - cLVM_GETSELECTEDCOUNT, // = LVM_FIRST + 50; - cLVM_GETITEMSPACING, // = LVM_FIRST + 51; - cLVM_GETISEARCHSTRINGA, // = LVM_FIRST + 52; - cLVM_SETICONSPACING, // = LVM_FIRST + 53; - cLVM_SETEXTENDEDLISTVIEWSTYLE, // = LVM_FIRST + 54; - cLVM_GETEXTENDEDLISTVIEWSTYLE, // = LVM_FIRST + 55; - cLVM_GETSUBITEMRECT, // = LVM_FIRST + 56; - cLVM_SUBITEMHITTEST, // = LVM_FIRST + 57; - cLVM_SETCOLUMNORDERARRAY, // = LVM_FIRST + 58; - cLVM_GETCOLUMNORDERARRAY, // = LVM_FIRST + 59; - cLVM_SETHOTITEM, // = LVM_FIRST + 60; - cLVM_GETHOTITEM, // = LVM_FIRST + 61; - cLVM_SETHOTCURSOR, // = LVM_FIRST + 62; - cLVM_GETHOTCURSOR, // = LVM_FIRST + 63; - cLVM_APPROXIMATEVIEWRECT, // = LVM_FIRST + 64; - cLVM_SETWORKAREA, // = LVM_FIRST + 65; - cLVM_GETSELECTIONMARK, // = LVM_FIRST + 66; - cLVM_SETSELECTIONMARK, // = LVM_FIRST + 67; - cLVM_SETBKIMAGEA, // = LVM_FIRST + 68; - cLVM_GETBKIMAGEA, // = LVM_FIRST + 69; - cLVM_GETWORKAREAS, // = LVM_FIRST + 70; - cLVM_SETHOVERTIME, // = LVM_FIRST + 71; - cLVM_GETHOVERTIME, // = LVM_FIRST + 72; - cLVM_GETNUMBEROFWORKAREAS, // = LVM_FIRST + 73; - cLVM_SETTOOLTIPS, // = LVM_FIRST + 74; - cLVM_GETITEMW, // = LVM_FIRST + 75; - cLVM_SETITEMW, // = LVM_FIRST + 76; - cLVM_INSERTITEMW, // = LVM_FIRST + 77; - cLVM_GETTOOLTIPS, // = LVM_FIRST + 78; - cWM_104F, - cWM_1050, - cLVM_SORTITEMSEX, // = LVM_FIRST + 81; - cWM_1052, - cLVM_FINDITEMW, // = LVM_FIRST + 83; - cWM_1054, - cWM_1055, - cWM_1056, - cLVM_GETSTRINGWIDTHW, // = LVM_FIRST + 87; - cWM_1058, - cWM_1059, - cWM_105A, - cWM_105B, - cWM_105C, - cWM_105D, - cWM_105E, - cLVM_GETCOLUMNW, // = LVM_FIRST + 95; - cLVM_SETCOLUMNW, // = LVM_FIRST + 96; - cLVM_INSERTCOLUMNW, // = LVM_FIRST + 97; - cWM_1062, - cWM_1063, - cWM_1064, - cWM_1065, - cWM_1066, - cWM_1067, - cWM_1068, - cWM_1069, - cWM_106A, - cWM_106B, - cWM_106C, - cWM_106D, - cWM_106E, - cWM_106F, - cWM_1070, - cWM_1071, - cWM_1072, - cLVM_GETITEMTEXTW, // = LVM_FIRST + 115; - cLVM_SETITEMTEXTW, // = LVM_FIRST + 116; - cLVM_GETISEARCHSTRINGW,// = LVM_FIRST + 117; - cLVM_EDITLABELW, // = LVM_FIRST + 118; - cWM_1077, - cWM_1078, - cWM_1079, - cWM_107A, - cWM_107B, - cWM_107C, - cWM_107D, - cWM_107E, - cWM_107F, - cWM_1080, - cWM_1081, - cWM_1082, - cWM_1083, - cWM_1084, - cWM_1085, - cWM_1086, - cWM_1087, - cWM_1088, - cWM_1089, - cLVM_SETBKIMAGEW, // = LVM_FIRST + 138; - cLVM_GETBKIMAGEW, // = LVM_FIRST + 139; - cWM_108C, - cWM_108D, - cWM_108E, - cWM_108F, - cWM_1090, - cWM_1091, - cWM_1092, - cWM_1093, - cWM_1094, - cWM_1095, - cWM_1096, - cWM_1097, - cWM_1098, - cWM_1099, - cWM_109A, - cWM_109B, - cWM_109C, - cWM_109D, - cWM_109E, - cWM_109F, - cWM_10A0, - cWM_10A1, - cWM_10A2, - cWM_10A3, - cWM_10A4, - cWM_10A5, - cWM_10A6, - cWM_10A7, - cWM_10A8, - cWM_10A9, - cWM_10AA, - cWM_10AB, - cWM_10AC, - cWM_10AD, - cWM_10AE, - cWM_10AF, - cWM_10B0, - cWM_10B1, - cWM_10B2, - cWM_10B3, - cWM_10B4, - cWM_10B5, - cWM_10B6, - cWM_10B7, - cWM_10B8, - cWM_10B9, - cWM_10BA, - cWM_10BB, - cWM_10BC, - cWM_10BD, - cWM_10BE, - cWM_10BF, - cWM_10C0, - cWM_10C1, - cWM_10C2, - cWM_10C3, - cWM_10C4, - cWM_10C5, - cWM_10C6, - cWM_10C7, - cWM_10C8, - cWM_10C9, - cWM_10CA, - cWM_10CB, - cWM_10CC, - cWM_10CD, - cWM_10CE, - cWM_10CF, - cWM_10D0, - cWM_10D1, - cWM_10D2, - cWM_10D3, - cWM_10D4, - cWM_10D5, - cWM_10D6, - cWM_10D7, - cWM_10D8, - cWM_10D9, - cWM_10DA, - cWM_10DB, - cWM_10DC, - cWM_10DD, - cWM_10DE, - cWM_10DF, - cWM_10E0, - cWM_10E1, - cWM_10E2, - cWM_10E3, - cWM_10E4, - cWM_10E5, - cWM_10E6, - cWM_10E7, - cWM_10E8, - cWM_10E9, - cWM_10EA, - cWM_10EB, - cWM_10EC, - cWM_10ED, - cWM_10EE, - cWM_10EF, - cWM_10F0, - cWM_10F1, - cWM_10F2, - cWM_10F3, - cWM_10F4, - cWM_10F5, - cWM_10F6, - cWM_10F7, - cWM_10F8, - cWM_10F9, - cWM_10FA, - cWM_10FB, - cWM_10FC, - cWM_10FD, - cWM_10FE, - cWM_10FF, - //TV_FIRST = $1100; { TreeView messages } - cTVM_INSERTITEMA, // = TV_FIRST + 0; - cTVM_DELETEITEM, // = TV_FIRST + 1; - cTVM_EXPAND, // = TV_FIRST + 2; - cWM_1103, - cTVM_GETITEMRECT, // = TV_FIRST + 4; - cTVM_GETCOUNT, // = TV_FIRST + 5; - cTVM_GETINDENT, // = TV_FIRST + 6; - cTVM_SETINDENT, // = TV_FIRST + 7; - cTVM_GETIMAGELIST, // = TV_FIRST + 8; - cTVM_SETIMAGELIST, // = TV_FIRST + 9; - cTVM_GETNEXTITEM, // = TV_FIRST + 10; - cTVM_SELECTITEM, // = TV_FIRST + 11; - cTVM_GETITEMA, // = TV_FIRST + 12; - cTVM_SETITEMA, // = TV_FIRST + 13; - cTVM_EDITLABELA, // = TV_FIRST + 14; - cTVM_GETEDITCONTROL, // = TV_FIRST + 15; - cTVM_GETVISIBLECOUNT,// = TV_FIRST + 16; - cTVM_HITTEST, // = TV_FIRST + 17; - cTVM_CREATEDRAGIMAGE,// = TV_FIRST + 18; - cTVM_SORTCHILDREN, // = TV_FIRST + 19; - cTVM_ENSUREVISIBLE, // = TV_FIRST + 20; - cTVM_SORTCHILDRENCB, // = TV_FIRST + 21; - cTVM_ENDEDITLABELNOW,// = TV_FIRST + 22; - cTVM_GETISEARCHSTRINGA, // = TV_FIRST + 23; - cTVM_SETTOOLTIPS, // = TV_FIRST + 24; - cTVM_GETTOOLTIPS, // = TV_FIRST + 25; - cTVM_SETINSERTMARK, // = TV_FIRST + 26; - cTVM_SETITEMHEIGHT, // = TV_FIRST + 27; - cTVM_GETITEMHEIGHT, // = TV_FIRST + 28; - cTVM_SETBKCOLOR, // = TV_FIRST + 29; - cTVM_SETTEXTCOLOR, // = TV_FIRST + 30; - cTVM_GETBKCOLOR, // = TV_FIRST + 31; - cTVM_GETTEXTCOLOR, // = TV_FIRST + 32; - cTVM_SETSCROLLTIME, // = TV_FIRST + 33; - cTVM_GETSCROLLTIME, // = TV_FIRST + 34; - cWM_1123, - cWM_1124, - cTVM_SETINSERTMARKCOLOR, // = TV_FIRST + 37; - cTVM_GETINSERTMARKCOLOR, // = TV_FIRST + 38; - cWM_1127, - cTVM_SETLINECOLOR, // = TV_FIRST + 40; - cWM_1129, - cWM_112A, - cWM_112B, - cWM_112C, - cWM_112D, - cWM_112E, - cWM_112F, - cWM_1130, - cWM_1131, - cTVM_INSERTITEMW, // = TV_FIRST + 50; - cWM_1133, - cWM_1134, - cWM_1135, - cWM_1136, - cWM_1137, - cWM_1138, - cWM_1139, - cWM_113A, - cWM_113B, - cWM_113C, - cWM_113D, - cTVM_GETITEMW, // = TV_FIRST + 62; - cTVM_SETITEMW, // = TV_FIRST + 63; - cTVM_GETISEARCHSTRINGW, // = TV_FIRST + 64; - cTVM_EDITLABELW, // = TV_FIRST + 65; - cWM_1142, - cWM_1143, - cWM_1144, - cWM_1145, - cWM_1146, - cWM_1147, - cWM_1148, - cWM_1149, - cWM_114A, - cWM_114B, - cWM_114C, - cWM_114D, - cWM_114E, - cWM_114F, - cWM_1150, - cWM_1151, - cWM_1152, - cWM_1153, - cWM_1154, - cWM_1155, - cWM_1156, - cWM_1157, - cWM_1158, - cWM_1159, - cWM_115A, - cWM_115B, - cWM_115C, - cWM_115D, - cWM_115E, - cWM_115F, - cWM_1160, - cWM_1161, - cWM_1162, - cWM_1163, - cWM_1164, - cWM_1165, - cWM_1166, - cWM_1167, - cWM_1168, - cWM_1169, - cWM_116A, - cWM_116B, - cWM_116C, - cWM_116D, - cWM_116E, - cWM_116F, - cWM_1170, - cWM_1171, - cWM_1172, - cWM_1173, - cWM_1174, - cWM_1175, - cWM_1176, - cWM_1177, - cWM_1178, - cWM_1179, - cWM_117A, - cWM_117B, - cWM_117C, - cWM_117D, - cWM_117E, - cWM_117F, - cWM_1180, - cWM_1181, - cWM_1182, - cWM_1183, - cWM_1184, - cWM_1185, - cWM_1186, - cWM_1187, - cWM_1188, - cWM_1189, - cWM_118A, - cWM_118B, - cWM_118C, - cWM_118D, - cWM_118E, - cWM_118F, - cWM_1190, - cWM_1191, - cWM_1192, - cWM_1193, - cWM_1194, - cWM_1195, - cWM_1196, - cWM_1197, - cWM_1198, - cWM_1199, - cWM_119A, - cWM_119B, - cWM_119C, - cWM_119D, - cWM_119E, - cWM_119F, - cWM_11A0, - cWM_11A1, - cWM_11A2, - cWM_11A3, - cWM_11A4, - cWM_11A5, - cWM_11A6, - cWM_11A7, - cWM_11A8, - cWM_11A9, - cWM_11AA, - cWM_11AB, - cWM_11AC, - cWM_11AD, - cWM_11AE, - cWM_11AF, - cWM_11B0, - cWM_11B1, - cWM_11B2, - cWM_11B3, - cWM_11B4, - cWM_11B5, - cWM_11B6, - cWM_11B7, - cWM_11B8, - cWM_11B9, - cWM_11BA, - cWM_11BB, - cWM_11BC, - cWM_11BD, - cWM_11BE, - cWM_11BF, - cWM_11C0, - cWM_11C1, - cWM_11C2, - cWM_11C3, - cWM_11C4, - cWM_11C5, - cWM_11C6, - cWM_11C7, - cWM_11C8, - cWM_11C9, - cWM_11CA, - cWM_11CB, - cWM_11CC, - cWM_11CD, - cWM_11CE, - cWM_11CF, - cWM_11D0, - cWM_11D1, - cWM_11D2, - cWM_11D3, - cWM_11D4, - cWM_11D5, - cWM_11D6, - cWM_11D7, - cWM_11D8, - cWM_11D9, - cWM_11DA, - cWM_11DB, - cWM_11DC, - cWM_11DD, - cWM_11DE, - cWM_11DF, - cWM_11E0, - cWM_11E1, - cWM_11E2, - cWM_11E3, - cWM_11E4, - cWM_11E5, - cWM_11E6, - cWM_11E7, - cWM_11E8, - cWM_11E9, - cWM_11EA, - cWM_11EB, - cWM_11EC, - cWM_11ED, - cWM_11EE, - cWM_11EF, - cWM_11F0, - cWM_11F1, - cWM_11F2, - cWM_11F3, - cWM_11F4, - cWM_11F5, - cWM_11F6, - cWM_11F7, - cWM_11F8, - cWM_11F9, - cWM_11FA, - cWM_11FB, - cWM_11FC, - cWM_11FD, - cWM_11FE, - cWM_11FF, - cHDM_FIRST, // = $1200; { Header messages } - cWM_1201, - cWM_1202, - cHDM_GETITEMA, // = HDM_FIRST + 3; - cWM_1204, - cWM_1205, - cHDM_HITTEST, // = HDM_FIRST + 6; - cHDM_GETITEMRECT, // = HDM_FIRST + 7; - cHDM_SETIMAGELIST, // = HDM_FIRST + 8; - cHDM_GETIMAGELIST, // = HDM_FIRST + 9; - cWM_120A, - cHDM_GETITEMW, // = HDM_FIRST + 11; - cWM_120C, - cWM_120D, - cWM_120E, - cHDM_ORDERTOINDEX, // = HDM_FIRST + 15; - cHDM_CREATEDRAGIMAGE, // = HDM_FIRST + 16; // wparam = which item = by index; - cHDM_GETORDERARRAY, // = HDM_FIRST + 17; - cHDM_SETORDERARRAY, // = HDM_FIRST + 18; - cHDM_SETHOTDIVIDER, // = HDM_FIRST + 19; - cWM_1214, - cWM_1215, - cWM_1216, - cWM_1217, - cWM_1218, - cWM_1219, - cWM_121A, - cWM_121B, - cWM_121C, - cWM_121D, - cWM_121E, - cWM_121F, - cWM_1220, - cWM_1221, - cWM_1222, - cWM_1223, - cWM_1224, - cWM_1225, - cWM_1226, - cWM_1227, - cWM_1228, - cWM_1229, - cWM_122A, - cWM_122B, - cWM_122C, - cWM_122D, - cWM_122E, - cWM_122F, - cWM_1230, - cWM_1231, - cWM_1232, - cWM_1233, - cWM_1234, - cWM_1235, - cWM_1236, - cWM_1237, - cWM_1238, - cWM_1239, - cWM_123A, - cWM_123B, - cWM_123C, - cWM_123D, - cWM_123E, - cWM_123F, - cWM_1240, - cWM_1241, - cWM_1242, - cWM_1243, - cWM_1244, - cWM_1245, - cWM_1246, - cWM_1247, - cWM_1248, - cWM_1249, - cWM_124A, - cWM_124B, - cWM_124C, - cWM_124D, - cWM_124E, - cWM_124F, - cWM_1250, - cWM_1251, - cWM_1252, - cWM_1253, - cWM_1254, - cWM_1255, - cWM_1256, - cWM_1257, - cWM_1258, - cWM_1259, - cWM_125A, - cWM_125B, - cWM_125C, - cWM_125D, - cWM_125E, - cWM_125F, - cWM_1260, - cWM_1261, - cWM_1262, - cWM_1263, - cWM_1264, - cWM_1265, - cWM_1266, - cWM_1267, - cWM_1268, - cWM_1269, - cWM_126A, - cWM_126B, - cWM_126C, - cWM_126D, - cWM_126E, - cWM_126F, - cWM_1270, - cWM_1271, - cWM_1272, - cWM_1273, - cWM_1274, - cWM_1275, - cWM_1276, - cWM_1277, - cWM_1278, - cWM_1279, - cWM_127A, - cWM_127B, - cWM_127C, - cWM_127D, - cWM_127E, - cWM_127F, - cWM_1280, - cWM_1281, - cWM_1282, - cWM_1283, - cWM_1284, - cWM_1285, - cWM_1286, - cWM_1287, - cWM_1288, - cWM_1289, - cWM_128A, - cWM_128B, - cWM_128C, - cWM_128D, - cWM_128E, - cWM_128F, - cWM_1290, - cWM_1291, - cWM_1292, - cWM_1293, - cWM_1294, - cWM_1295, - cWM_1296, - cWM_1297, - cWM_1298, - cWM_1299, - cWM_129A, - cWM_129B, - cWM_129C, - cWM_129D, - cWM_129E, - cWM_129F, - cWM_12A0, - cWM_12A1, - cWM_12A2, - cWM_12A3, - cWM_12A4, - cWM_12A5, - cWM_12A6, - cWM_12A7, - cWM_12A8, - cWM_12A9, - cWM_12AA, - cWM_12AB, - cWM_12AC, - cWM_12AD, - cWM_12AE, - cWM_12AF, - cWM_12B0, - cWM_12B1, - cWM_12B2, - cWM_12B3, - cWM_12B4, - cWM_12B5, - cWM_12B6, - cWM_12B7, - cWM_12B8, - cWM_12B9, - cWM_12BA, - cWM_12BB, - cWM_12BC, - cWM_12BD, - cWM_12BE, - cWM_12BF, - cWM_12C0, - cWM_12C1, - cWM_12C2, - cWM_12C3, - cWM_12C4, - cWM_12C5, - cWM_12C6, - cWM_12C7, - cWM_12C8, - cWM_12C9, - cWM_12CA, - cWM_12CB, - cWM_12CC, - cWM_12CD, - cWM_12CE, - cWM_12CF, - cWM_12D0, - cWM_12D1, - cWM_12D2, - cWM_12D3, - cWM_12D4, - cWM_12D5, - cWM_12D6, - cWM_12D7, - cWM_12D8, - cWM_12D9, - cWM_12DA, - cWM_12DB, - cWM_12DC, - cWM_12DD, - cWM_12DE, - cWM_12DF, - cWM_12E0, - cWM_12E1, - cWM_12E2, - cWM_12E3, - cWM_12E4, - cWM_12E5, - cWM_12E6, - cWM_12E7, - cWM_12E8, - cWM_12E9, - cWM_12EA, - cWM_12EB, - cWM_12EC, - cWM_12ED, - cWM_12EE, - cWM_12EF, - cWM_12F0, - cWM_12F1, - cWM_12F2, - cWM_12F3, - cWM_12F4, - cWM_12F5, - cWM_12F6, - cWM_12F7, - cWM_12F8, - cWM_12F9, - cWM_12FA, - cWM_12FB, - cWM_12FC, - cWM_12FD, - cWM_12FE, - cWM_12FF, - cTCM_FIRST, // = $1300; { Tab control messages } - cWM_1301, - cTCM_GETIMAGELIST, // = TCM_FIRST + 2; - cTCM_SETIMAGELIST, // = TCM_FIRST + 3; - cTCM_GETITEMCOUNT, // = TCM_FIRST + 4; - cTCM_GETITEMA, // = TCM_FIRST + 5; - cTCM_SETITEMA, // = TCM_FIRST + 6; - cTCM_INSERTITEMA, // = TCM_FIRST + 7; - cTCM_DELETEITEM, // = TCM_FIRST + 8; - cTCM_DELETEALLITEMS, // = TCM_FIRST + 9; - cTCM_GETITEMRECT, // = TCM_FIRST + 10; - cTCM_GETCURSEL, // = TCM_FIRST + 11; - cTCM_SETCURSEL, // = TCM_FIRST + 12; - cTCM_HITTEST, // = TCM_FIRST + 13; - cTCM_SETITEMEXTRA, // = TCM_FIRST + 14; - cWM_130F, - cWM_1310, - cWM_1311, - cWM_1312, - cWM_1313, - cWM_1314, - cWM_1315, - cWM_1316, - cWM_1317, - cWM_1318, - cWM_1319, - cWM_131A, - cWM_131B, - cWM_131C, - cWM_131D, - cWM_131E, - cWM_131F, - cWM_1320, - cWM_1321, - cWM_1322, - cWM_1323, - cWM_1324, - cWM_1325, - cWM_1326, - cWM_1327, - cTCM_ADJUSTRECT, // = TCM_FIRST + 40; - cTCM_SETITEMSIZE, // = TCM_FIRST + 41; - cTCM_REMOVEIMAGE, // = TCM_FIRST + 42; - cTCM_SETPADDING, // = TCM_FIRST + 43; - cTCM_GETROWCOUNT, // = TCM_FIRST + 44; - cTCM_GETTOOLTIPS, // = TCM_FIRST + 45; - cTCM_SETTOOLTIPS, // = TCM_FIRST + 46; - cTCM_GETCURFOCUS, // = TCM_FIRST + 47; - cTCM_SETCURFOCUS, // = TCM_FIRST + 48; - cTCM_SETMINTABWIDTH, // = TCM_FIRST + 49; - cTCM_DESELECTALL, // = TCM_FIRST + 50; - cTCM_HIGHLIGHTITEM, // = TCM_FIRST + 51; - cTCM_SETEXTENDEDSTYLE, // = TCM_FIRST + 52; // optional wParam == mask - cTCM_GETEXTENDEDSTYLE, // = TCM_FIRST + 53; - cWM_1336, - cWM_1337, - cWM_1338, - cWM_1339, - cWM_133A, - cWM_133B, - cTCM_GETITEMW, // = TCM_FIRST + 60; - cTCM_SETITEMW, // = TCM_FIRST + 61; - cTCM_INSERTITEMW // = TCM_FIRST + 62; - (* - cCCM_FIRST = $2000; { Common control shared messages } - cCCM_SETBKCOLOR = CCM_FIRST + 1; // lParam is bkColor - cCCM_SETCOLORSCHEME = CCM_FIRST + 2; // lParam is color scheme - cCCM_GETCOLORSCHEME = CCM_FIRST + 3; // fills in COLORSCHEME pointed to by lParam - cCCM_GETDROPTARGET = CCM_FIRST + 4; - cCCM_SETUNICODEFORMAT = CCM_FIRST + 5; - cCCM_GETUNICODEFORMAT = CCM_FIRST + 6; - //WM_APP = $8000; - *) - ); - - PMsgDecoded = ^TMsgDecoded; - TMsgDecoded = packed record - hwnd: HWND; - Cmessage: TMessageDecoded; - _filler: Word; - wParam: WPARAM; - lParam: LPARAM; - time: DWORD; - pt: TPoint; - end; - diff --git a/plugins/ImportTXT/kol/delphicommctrl.inc b/plugins/ImportTXT/kol/delphicommctrl.inc deleted file mode 100644 index c7fa1bc628..0000000000 --- a/plugins/ImportTXT/kol/delphicommctrl.inc +++ /dev/null @@ -1,1594 +0,0 @@ -{******************************************************************************* - delpicommctrl.inc - -- included in KOL.pas -- -*******************************************************************************} - -{$IFNDEF FPC} -{$IFNDEF TMSG_WINDOWS} - {$DEFINE TMSG_DECODED} -{$ENDIF} -{$ENDIF} -{$IFDEF TMSG_DECODED} -{$I MsgDecode.pas} -type - TMsg = packed record - CASE Integer OF - 0: ( - hwnd: HWND; - message: UINT; - wParam: WPARAM; - lParam: LPARAM; - time: DWORD; - pt: TPoint; - ); - //1: ( Bmsg: Windows.TMsg; ); - 2: ( Cmsg: TMsgDecoded; ); - end; - - tagMSG = TMsg; -{$ENDIF TMSG_DECODED} - - -//////////////////////////////////////////////////////////////////////////// -// this part of unit contains definitions moved here from CommCtrl.pas -// (using of CommCtrl.pas in Delphi3 leads to increase size of executable -// onto 30K) - -type - PTCItemA = ^TTCItemA; - PTCItemW = ^TTCItemW; - PTCItem = {$IFDEF UNICODE_CTRLS} PTCItemW {$ELSE} PTCItemA {$ENDIF}; - tagTCITEMA = packed record - mask: UINT; - dwState: UINT; - dwStateMask: UINT; - pszText: PAnsiChar; - cchTextMax: Integer; - iImage: Integer; - lParam: LPARAM; - end; - tagTCITEMW = packed record - mask: UINT; - dwState: UINT; - dwStateMask: UINT; - pszText: PWideChar; - cchTextMax: Integer; - iImage: Integer; - lParam: LPARAM; - end; - - PTCKeyDown = ^TTCKeyDown; - TTCKEYDOWN = packed record - hdr: TNMHDR; - wVKey: Word; - flags: UINT; - end; - - tagTCITEM = {$IFDEF UNICODE_CTRLS} tagTCITEMW {$ELSE} tagTCITEMA {$ENDIF}; - _TC_ITEMA = tagTCITEMA; - _TC_ITEMW = tagTCITEMW; - _TC_ITEM = {$IFDEF UNICODE_CTRLS} _TC_ITEMW {$ELSE} _TC_ITEMA {$ENDIF}; - TTCItemA = tagTCITEMA; - TTCItemW = tagTCITEMW; - TTCItem = {$IFDEF UNICODE_CTRLS} TTCItemW {$ELSE} TTCItemA {$ENDIF}; - TC_ITEMA = tagTCITEMA; - TC_ITEMW = tagTCITEMW; - TC_ITEM = {$IFDEF UNICODE_CTRLS} TC_ITEMW {$ELSE} TC_ITEMA {$ENDIF}; - - -const - CCM_FIRST = $2000; { Common control shared messages } - CCM_SETBKCOLOR = CCM_FIRST + 1; // lParam is bkColor - CCM_SETCOLORSCHEME = CCM_FIRST + 2; // lParam is color scheme - CCM_GETCOLORSCHEME = CCM_FIRST + 3; // fills in COLORSCHEME pointed to by lParam - CCM_GETDROPTARGET = CCM_FIRST + 4; - CCM_SETUNICODEFORMAT = CCM_FIRST + 5; - CCM_GETUNICODEFORMAT = CCM_FIRST + 6; - - TCS_SCROLLOPPOSITE = $0001; // assumes multiline tab - TCS_BOTTOM = $0002; - TCS_RIGHT = $0002; - TCS_MULTISELECT = $0004; // allow multi-select in button mode - TCS_FLATBUTTONS = $0008; - TCS_FORCEICONLEFT = $0010; - TCS_FORCELABELLEFT = $0020; - TCS_HOTTRACK = $0040; - TCS_VERTICAL = $0080; - TCS_TABS = $0000; - TCS_BUTTONS = $0100; - TCS_SINGLELINE = $0000; - TCS_MULTILINE = $0200; - TCS_RIGHTJUSTIFY = $0000; - TCS_FIXEDWIDTH = $0400; - TCS_RAGGEDRIGHT = $0800; - TCS_FOCUSONBUTTONDOWN = $1000; - TCS_OWNERDRAWFIXED = $2000; - TCS_TOOLTIPS = $4000; - TCS_FOCUSNEVER = $8000; - - TCS_EX_FLATSEPARATORS = $00000001; - TCS_EX_REGISTERDROP = $00000002; - - TCM_FIRST = $1300; { Tab control messages } - TCM_GETIMAGELIST = TCM_FIRST + 2; - TCM_SETIMAGELIST = TCM_FIRST + 3; - TCM_GETITEMCOUNT = TCM_FIRST + 4; - TCM_GETITEMA = TCM_FIRST + 5; - TCM_SETITEMA = TCM_FIRST + 6; - TCM_INSERTITEMA = TCM_FIRST + 7; - TCM_DELETEITEM = TCM_FIRST + 8; - TCM_DELETEALLITEMS = TCM_FIRST + 9; - TCM_GETITEMRECT = TCM_FIRST + 10; - TCM_GETCURSEL = TCM_FIRST + 11; - TCM_SETCURSEL = TCM_FIRST + 12; - TCM_HITTEST = TCM_FIRST + 13; - TCM_SETITEMEXTRA = TCM_FIRST + 14; - TCM_ADJUSTRECT = TCM_FIRST + 40; - TCM_SETITEMSIZE = TCM_FIRST + 41; - TCM_REMOVEIMAGE = TCM_FIRST + 42; - TCM_SETPADDING = TCM_FIRST + 43; - TCM_GETROWCOUNT = TCM_FIRST + 44; - TCM_GETTOOLTIPS = TCM_FIRST + 45; - TCM_SETTOOLTIPS = TCM_FIRST + 46; - TCM_GETCURFOCUS = TCM_FIRST + 47; - TCM_SETCURFOCUS = TCM_FIRST + 48; - TCM_SETMINTABWIDTH = TCM_FIRST + 49; - TCM_DESELECTALL = TCM_FIRST + 50; - TCM_HIGHLIGHTITEM = TCM_FIRST + 51; - TCM_SETEXTENDEDSTYLE = TCM_FIRST + 52; // optional wParam == mask - TCM_GETEXTENDEDSTYLE = TCM_FIRST + 53; - TCM_GETITEMW = TCM_FIRST + 60; - TCM_SETITEMW = TCM_FIRST + 61; - TCM_INSERTITEMW = TCM_FIRST + 62; - TCM_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT; - TCM_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT; - TCM_GETITEM = {$IFDEF UNICODE_CTRLS} TCM_GETITEMW - {$ELSE} TCM_GETITEMA {$ENDIF}; - TCM_SETITEM = {$IFDEF UNICODE_CTRLS} TCM_SETITEMW - {$ELSE} TCM_SETITEMA {$ENDIF}; - TCM_INSERTITEM = {$IFDEF UNICODE_CTRLS} TCM_INSERTITEMW - {$ELSE} TCM_INSERTITEMA {$ENDIF}; - - TCN_FIRST = 0-550; { tab control } - TCN_LAST = 0-580; - TCN_KEYDOWN = TCN_FIRST - 0; - TCN_SELCHANGE = TCN_FIRST - 1; - TCN_SELCHANGING = TCN_FIRST - 2; - TCN_GETOBJECT = TCN_FIRST - 3; - - TCIF_TEXT = $0001; - TCIF_IMAGE = $0002; - TCIF_RTLREADING = $0004; - TCIF_PARAM = $0008; - TCIF_STATE = $0010; - - PBS_SMOOTH = 01; - PBS_VERTICAL = 04; - - PBM_SETRANGE = WM_USER+1; - PBM_SETPOS = WM_USER+2; - PBM_DELTAPOS = WM_USER+3; - PBM_SETSTEP = WM_USER+4; - PBM_STEPIT = WM_USER+5; - PBM_SETRANGE32 = WM_USER+6; // lParam = high, wParam = low - PBM_GETRANGE = WM_USER+7; // lParam = PPBRange or Nil - // wParam = False: Result = high - // wParam = True: Result = low - PBM_GETPOS = WM_USER+8; - PBM_SETBARCOLOR = WM_USER+9; // lParam = bar color - PBM_SETBKCOLOR = CCM_SETBKCOLOR; // lParam = bkColor - - SB_SETTEXTA = WM_USER+1; - SB_GETTEXTA = WM_USER+2; - SB_GETTEXTLENGTHA = WM_USER+3; - SB_SETTIPTEXTA = WM_USER+16; - SB_GETTIPTEXTA = WM_USER+18; - - SB_SETTEXTW = WM_USER+11; - SB_GETTEXTW = WM_USER+13; - SB_GETTEXTLENGTHW = WM_USER+12; - SB_SETTIPTEXTW = WM_USER+17; - SB_GETTIPTEXTW = WM_USER+19; - - SB_SETTEXT = {$IFDEF UNICODE_CTRLS} SB_SETTEXTW {$ELSE} SB_SETTEXTA {$ENDIF}; - SB_GETTEXT = {$IFDEF UNICODE_CTRLS} SB_GETTEXTW {$ELSE} SB_GETTEXTA {$ENDIF}; - SB_GETTEXTLENGTH = {$IFDEF UNICODE_CTRLS} SB_GETTEXTLENGTHW {$ELSE} SB_GETTEXTLENGTHA {$ENDIF}; - SB_SETTIPTEXT = {$IFDEF UNICODE_CTRLS} SB_SETTIPTEXTW {$ELSE} SB_SETTIPTEXTA {$ENDIF}; - SB_GETTIPTEXT = {$IFDEF UNICODE_CTRLS} SB_GETTIPTEXTW {$ELSE} SB_GETTIPTEXTA {$ENDIF}; - - SB_SETPARTS = WM_USER+4; - SB_GETPARTS = WM_USER+6; - SB_GETBORDERS = WM_USER+7; - SB_SETMINHEIGHT = WM_USER+8; - SB_SIMPLE = WM_USER+9; - SB_GETRECT = WM_USER + 10; - SB_ISSIMPLE = WM_USER+14; - SB_SETICON = WM_USER+15; - SB_GETICON = WM_USER+20; - SB_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT; - SB_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT; - - SBT_OWNERDRAW = $1000; - SBT_NOBORDERS = $0100; - SBT_POPOUT = $0200; - SBT_RTLREADING = $0400; - SBT_TOOLTIPS = $0800; - - SB_SETBKCOLOR = CCM_SETBKCOLOR; // lParam = bkColor - - SBARS_SIZEGRIP = $0100; - - { List View Styles } - LVS_ICON = $0000; - LVS_REPORT = $0001; - LVS_SMALLICON = $0002; - LVS_LIST = $0003; - - LVS_TYPEMASK = $0003; - LVS_SINGLESEL = $0004; - LVS_SHOWSELALWAYS = $0008; - LVS_SORTASCENDING = $0010; - LVS_SORTDESCENDING = $0020; - LVS_SHAREIMAGELISTS = $0040; - LVS_NOLABELWRAP = $0080; - LVS_AUTOARRANGE = $0100; - LVS_EDITLABELS = $0200; - LVS_OWNERDATA = $1000; - LVS_NOSCROLL = $2000; - - LVS_TYPESTYLEMASK = $FC00; - - LVS_ALIGNTOP = $0000; - LVS_ALIGNLEFT = $0800; - LVS_ALIGNMASK = $0c00; - - LVS_OWNERDRAWFIXED = $0400; - LVS_NOCOLUMNHEADER = $4000; - LVS_NOSORTHEADER = $8000; - - { List View Extended Styles } - LVS_EX_GRIDLINES = $00000001; - LVS_EX_SUBITEMIMAGES = $00000002; - LVS_EX_CHECKBOXES = $00000004; - LVS_EX_TRACKSELECT = $00000008; - LVS_EX_HEADERDRAGDROP = $00000010; - LVS_EX_FULLROWSELECT = $00000020; // applies to report mode only - LVS_EX_ONECLICKACTIVATE = $00000040; - LVS_EX_TWOCLICKACTIVATE = $00000080; - LVS_EX_FLATSB = $00000100; - LVS_EX_REGIONAL = $00000200; - LVS_EX_INFOTIP = $00000400; // listview does InfoTips for you - LVS_EX_LABELTIP = $00004000; - LVS_EX_UNDERLINEHOT = $00000800; - LVS_EX_UNDERLINECOLD = $00001000; - LVS_EX_MULTIWORKAREAS = $00002000; - - I_IMAGECALLBACK = -1; - I_SKIP = -2; - LVSIL_NORMAL = 0; - LVSIL_SMALL = 1; - LVSIL_STATE = 2; - - { List View column styles } - LVCF_FMT = $0001; - LVCF_WIDTH = $0002; - LVCF_TEXT = $0004; - LVCF_SUBITEM = $0008; - LVCF_IMAGE = $0010; - LVCF_ORDER = $0020; - LVSCW_AUTOSIZE = -1; - LVSCW_AUTOSIZE_USEHEADER = -2; - - LVCFMT_LEFT = $0000; - LVCFMT_RIGHT = $0001; - LVCFMT_CENTER = $0002; - LVCFMT_JUSTIFYMASK = $0003; - - LVCFMT_IMAGE = $0800; - LVCFMT_BITMAP_ON_RIGHT = $1000; - LVCFMT_COL_HAS_IMAGES = $8000; - - LVIF_TEXT = $0001; - LVIF_IMAGE = $0002; - LVIF_PARAM = $0004; - LVIF_STATE = $0008; - LVIF_INDENT = $0010; - //LVIF_NORECOMPUTE = $0800; - LVIF_DI_SETITEM = $1000; - - LVIS_FOCUSED = $0001; - LVIS_SELECTED = $0002; - LVIS_CUT = $0004; - LVIS_DROPHILITED = $0008; - //LVIS_ACTIVATING = $0020; - - LVIS_OVERLAYMASK = $0F00; - LVIS_STATEIMAGEMASK = $F000; - - { List View messages } - LVM_FIRST = $1000; { ListView messages } - LVM_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT; - LVM_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT; - LVM_GETBKCOLOR = LVM_FIRST + 0; - LVM_SETBKCOLOR = LVM_FIRST + 1; - LVM_GETIMAGELIST = LVM_FIRST + 2; - LVM_SETIMAGELIST = LVM_FIRST + 3; - LVM_GETITEMCOUNT = LVM_FIRST + 4; - LVM_GETITEMA = LVM_FIRST + 5; - LVM_SETITEMA = LVM_FIRST + 6; - LVM_INSERTITEMA = LVM_FIRST + 7; - LVM_DELETEITEM = LVM_FIRST + 8; - LVM_DELETEALLITEMS = LVM_FIRST + 9; - LVM_GETCALLBACKMASK = LVM_FIRST + 10; - LVM_SETCALLBACKMASK = LVM_FIRST + 11; - LVM_GETNEXTITEM = LVM_FIRST + 12; - LVM_FINDITEMA = LVM_FIRST + 13; - LVM_GETITEMRECT = LVM_FIRST + 14; - LVM_SETITEMPOSITION = LVM_FIRST + 15; - LVM_GETITEMPOSITION = LVM_FIRST + 16; - LVM_GETSTRINGWIDTHA = LVM_FIRST + 17; - LVM_HITTEST = LVM_FIRST + 18; - LVM_ENSUREVISIBLE = LVM_FIRST + 19; - LVM_SCROLL = LVM_FIRST + 20; - LVM_REDRAWITEMS = LVM_FIRST + 21; - LVM_ARRANGE = LVM_FIRST + 22; - LVM_EDITLABELA = LVM_FIRST + 23; - LVM_GETCOLUMNA = LVM_FIRST + 25; - LVM_SETCOLUMNA = LVM_FIRST + 26; - LVM_INSERTCOLUMNA = LVM_FIRST + 27; - LVM_DELETECOLUMN = LVM_FIRST + 28; - LVM_GETCOLUMNWIDTH = LVM_FIRST + 29; - LVM_SETCOLUMNWIDTH = LVM_FIRST + 30; - LVM_GETHEADER = LVM_FIRST + 31; - - LVM_CREATEDRAGIMAGE = LVM_FIRST + 33; - LVM_GETVIEWRECT = LVM_FIRST + 34; - LVM_GETTEXTCOLOR = LVM_FIRST + 35; - LVM_SETTEXTCOLOR = LVM_FIRST + 36; - LVM_GETTEXTBKCOLOR = LVM_FIRST + 37; - LVM_SETTEXTBKCOLOR = LVM_FIRST + 38; - LVM_GETTOPINDEX = LVM_FIRST + 39; - LVM_GETCOUNTPERPAGE = LVM_FIRST + 40; - LVM_GETORIGIN = LVM_FIRST + 41; - LVM_UPDATE = LVM_FIRST + 42; - LVM_SETITEMSTATE = LVM_FIRST + 43; - LVM_GETITEMSTATE = LVM_FIRST + 44; - LVM_GETITEMTEXTA = LVM_FIRST + 45; - LVM_SETITEMTEXTA = LVM_FIRST + 46; - LVM_SETITEMCOUNT = LVM_FIRST + 47; - LVM_SORTITEMS = LVM_FIRST + 48; - LVM_SETITEMPOSITION32 = LVM_FIRST + 49; - LVM_GETSELECTEDCOUNT = LVM_FIRST + 50; - LVM_GETITEMSPACING = LVM_FIRST + 51; - LVM_GETISEARCHSTRINGA = LVM_FIRST + 52; - LVM_SETICONSPACING = LVM_FIRST + 53; - LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 54; - LVM_GETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 55; - LVM_GETSUBITEMRECT = LVM_FIRST + 56; - LVM_SUBITEMHITTEST = LVM_FIRST + 57; - LVM_SETCOLUMNORDERARRAY = LVM_FIRST + 58; - LVM_GETCOLUMNORDERARRAY = LVM_FIRST + 59; - LVM_SETHOTITEM = LVM_FIRST + 60; - LVM_GETHOTITEM = LVM_FIRST + 61; - LVM_SETHOTCURSOR = LVM_FIRST + 62; - LVM_GETHOTCURSOR = LVM_FIRST + 63; - LVM_APPROXIMATEVIEWRECT = LVM_FIRST + 64; - LVM_SETWORKAREA = LVM_FIRST + 65; - LVM_GETSELECTIONMARK = LVM_FIRST + 66; - LVM_SETSELECTIONMARK = LVM_FIRST + 67; - LVM_SETBKIMAGEA = LVM_FIRST + 68; - LVM_GETBKIMAGEA = LVM_FIRST + 69; - LVM_GETWORKAREAS = LVM_FIRST + 70; - LVM_SETHOVERTIME = LVM_FIRST + 71; - LVM_GETHOVERTIME = LVM_FIRST + 72; - LVM_GETNUMBEROFWORKAREAS = LVM_FIRST + 73; - LVM_SETTOOLTIPS = LVM_FIRST + 74; - LVM_GETITEMW = LVM_FIRST + 75; - LVM_SETITEMW = LVM_FIRST + 76; - LVM_INSERTITEMW = LVM_FIRST + 77; - LVM_GETTOOLTIPS = LVM_FIRST + 78; - - LVM_SORTITEMSEX = LVM_FIRST + 81; - - LVM_FINDITEMW = LVM_FIRST + 83; - LVM_GETSTRINGWIDTHW = LVM_FIRST + 87; - - LVM_GETCOLUMNW = LVM_FIRST + 95; - LVM_SETCOLUMNW = LVM_FIRST + 96; - LVM_INSERTCOLUMNW = LVM_FIRST + 97; - - LVM_GETITEMTEXTW = LVM_FIRST + 115; - LVM_SETITEMTEXTW = LVM_FIRST + 116; - LVM_GETISEARCHSTRINGW = LVM_FIRST + 117; - LVM_EDITLABELW = LVM_FIRST + 118; - - LVM_SETBKIMAGEW = LVM_FIRST + 138; - LVM_GETBKIMAGEW = LVM_FIRST + 139; - - LVM_GETITEM = {$IFDEF UNICODE_CTRLS} LVM_GETITEMW {$ELSE} LVM_GETITEMA {$ENDIF}; - LVM_SETITEM = {$IFDEF UNICODE_CTRLS} LVM_SETITEMW {$ELSE} LVM_SETITEMA {$ENDIF}; - LVM_INSERTITEM = {$IFDEF UNICODE_CTRLS} LVM_INSERTITEMW {$ELSE} LVM_INSERTITEMA {$ENDIF}; - LVM_GETCOLUMN = {$IFDEF UNICODE_CTRLS} LVM_GETCOLUMNW {$ELSE} LVM_GETCOLUMNA {$ENDIF}; - LVM_SETCOLUMN = {$IFDEF UNICODE_CTRLS} LVM_SETCOLUMNW {$ELSE} LVM_SETCOLUMNA {$ENDIF}; - LVM_INSERTCOLUMN = {$IFDEF UNICODE_CTRLS} LVM_INSERTCOLUMNW {$ELSE} LVM_INSERTCOLUMNA {$ENDIF}; - LVM_GETITEMTEXT = {$IFDEF UNICODE_CTRLS} LVM_GETITEMTEXTW {$ELSE} LVM_GETITEMTEXTA {$ENDIF}; - LVM_SETITEMTEXT = {$IFDEF UNICODE_CTRLS} LVM_SETITEMTEXTW {$ELSE} LVM_SETITEMTEXTA {$ENDIF}; - LVM_EDITLABEL = {$IFDEF UNICODE_CTRLS} LVM_EDITLABELW {$ELSE} LVM_EDITLABELA {$ENDIF}; - LVM_FINDITEM = {$IFDEF UNICODE_CTRLS} LVM_FINDITEMW {$ELSE} LVM_FINDITEMA {$ENDIF}; - LVM_GETISEARCHSTRING = {$IFDEF UNICODE_CTRLS} LVM_GETISEARCHSTRINGW {$ELSE} LVM_GETISEARCHSTRINGA {$ENDIF}; - LVM_GETSTRINGWIDTH = {$IFDEF UNICODE_CTRLS} LVM_GETSTRINGWIDTHW {$ELSE} LVM_GETSTRINGWIDTHA {$ENDIF}; - - LVM_SETBKIMAGE = {$IFDEF UNICODE_CTRLS} LVM_SETBKIMAGEW {$ELSE} LVM_SETBKIMAGEA {$ENDIF}; - LVM_GETBKIMAGE = {$IFDEF UNICODE_CTRLS} LVM_GETBKIMAGEW {$ELSE} LVM_GETBKIMAGEA {$ENDIF}; - - LV_MAX_WORKAREAS = 16; - - LVIR_BOUNDS = 0; - LVIR_ICON = 1; - LVIR_LABEL = 2; - LVIR_SELECTBOUNDS = 3; - - LVHT_NOWHERE = $0001; - LVHT_ONITEMICON = $0002; - LVHT_ONITEMLABEL = $0004; - LVHT_ONITEMSTATEICON = $0008; - LVHT_ONITEM = LVHT_ONITEMICON or LVHT_ONITEMLABEL or - LVHT_ONITEMSTATEICON; - LVHT_ABOVE = $0008; - LVHT_BELOW = $0010; - LVHT_TORIGHT = $0020; - LVHT_TOLEFT = $0040; - - LVNI_ALL = $0000; - LVNI_FOCUSED = $0001; - LVNI_SELECTED = $0002; - LVNI_CUT = $0004; - LVNI_DROPHILITED = $0008; - - LVNI_ABOVE = $0100; - LVNI_BELOW = $0200; - LVNI_TOLEFT = $0400; - LVNI_TORIGHT = $0800; - - { WM_NOTIFY codes } - NM_FIRST = 0- 0; { generic to all controls } - NM_LAST = 0- 99; - NM_OUTOFMEMORY = NM_FIRST-1; - NM_CLICK = NM_FIRST-2; - NM_DBLCLK = NM_FIRST-3; - NM_RETURN = NM_FIRST-4; - NM_RCLICK = NM_FIRST-5; - NM_RDBLCLK = NM_FIRST-6; - NM_SETFOCUS = NM_FIRST-7; - NM_KILLFOCUS = NM_FIRST-8; - NM_CUSTOMDRAW = NM_FIRST-12; - NM_HOVER = NM_FIRST-13; - NM_NCHITTEST = NM_FIRST-14; // uses NMMOUSE struct - NM_KEYDOWN = NM_FIRST-15; // uses NMKEY struct - NM_RELEASEDCAPTURE = NM_FIRST-16; - NM_SETCURSOR = NM_FIRST-17; // uses NMMOUSE struct - NM_CHAR = NM_FIRST-18; // uses NMCHAR struct - - LVN_FIRST = 0-100; { listview } - LVN_LAST = 0-199; - LVN_ITEMCHANGING = LVN_FIRST-0; - LVN_ITEMCHANGED = LVN_FIRST-1; - LVN_INSERTITEM = LVN_FIRST-2; - LVN_DELETEITEM = LVN_FIRST-3; - LVN_DELETEALLITEMS = LVN_FIRST-4; - LVN_COLUMNCLICK = LVN_FIRST-8; - LVN_BEGINDRAG = LVN_FIRST-9; - LVN_BEGINRDRAG = LVN_FIRST-11; - LVN_ODCACHEHINT = LVN_FIRST-13; - LVN_ODFINDITEMA = LVN_FIRST-52; - LVN_ODFINDITEMW = LVN_FIRST-79; - LVN_ITEMACTIVATE = LVN_FIRST-14; - LVN_ODSTATECHANGED = LVN_FIRST-15; - LVN_ODFINDITEM = {$IFDEF UNICODE_CTRLS} LVN_ODFINDITEMW {$ELSE} LVN_ODFINDITEMA {$ENDIF}; - LVN_BEGINLABELEDITA = LVN_FIRST-5; - LVN_ENDLABELEDITA = LVN_FIRST-6; - LVN_BEGINLABELEDITW = LVN_FIRST-75; - LVN_ENDLABELEDITW = LVN_FIRST-76; - LVN_BEGINLABELEDIT = {$IFDEF UNICODE_CTRLS} LVN_BEGINLABELEDITW {$ELSE} LVN_BEGINLABELEDITA {$ENDIF}; - LVN_ENDLABELEDIT = {$IFDEF UNICODE_CTRLS} LVN_ENDLABELEDITW {$ELSE} LVN_ENDLABELEDITA {$ENDIF}; - LVN_HOTTRACK = LVN_FIRST-21; - LVN_GETDISPINFOA = LVN_FIRST-50; - LVN_SETDISPINFOA = LVN_FIRST-51; - LVN_GETDISPINFOW = LVN_FIRST-77; - LVN_SETDISPINFOW = LVN_FIRST-78; - LVN_GETDISPINFO = {$IFDEF UNICODE_CTRLS} LVN_GETDISPINFOW {$ELSE} LVN_GETDISPINFOA {$ENDIF}; - LVN_SETDISPINFO = {$IFDEF UNICODE_CTRLS} LVN_SETDISPINFOW {$ELSE} LVN_SETDISPINFOA {$ENDIF}; - -type - tagNMLVODSTATECHANGE = packed record - hdr: TNMHdr; - iFrom: Integer; - iTo: Integer; - uNewState: UINT; - uOldState: UINT; - end; - PNMLVODStateChange = ^TNMLVODStateChange; - TNMLVODStateChange = tagNMLVODSTATECHANGE; - -type - PLVColumn = ^TLVColumn; - TLVColumn = packed record - mask: DWORD; - fmt: DWORD; - cx: Integer; - pszText: PKOL_Char; - cchTextMax: Integer; - iSubItem: Integer; - // only IE4+ : - iImage: Integer; - iOrder: Integer; - end; - - PLVItem = ^TLVItem; - TLVItem = packed record - mask: DWORD; - iItem: Integer; - iSubItem: Integer; - state: Integer; - stateMask: DWORD; - pszText: PKOL_Char; - cchTextMax: Integer; - iImage: Integer; - lParam: LParam; - iIndent: Integer; // only for IE3.0 and higher - end; - - PLVDispInfo = ^TLVDispInfo; - TLVDispInfo = packed record - hdr: TNMHDR; - item: TLVItem; - end; - - PLVFindInfoA = ^TLVFindInfo; - TLVFindInfo = packed record - flags: UINT; - psz: PKOLChar; - lParam: LPARAM; - pt: TPoint; - vkDirection: UINT; - end; - PLVFindInfoW = ^TLVFindInfoW; - TLVFindInfoW = packed record - flags: UINT; - psz: PWideChar; - lParam: LPARAM; - pt: TPoint; - vkDirection: UINT; - end; - - TLVHitTestInfo = packed record - pt: TPoint; - flags: DWORD; - iItem: Integer; - iSubItem: Integer; - end; - -const - LVFI_PARAM = $0001; - LVFI_STRING = $0002; - LVFI_PARTIAL = $0008; - LVFI_WRAP = $0020; - LVFI_NEARESTXY = $0040; - -const - HDM_FIRST = $1200; { Header messages } - HDM_GETITEMW = HDM_FIRST + 11; - HDM_GETITEMA = HDM_FIRST + 3; - HDM_GETITEM = {$IFDEF UNICODE_CTRLS} HDM_GETITEMW {$ELSE} HDM_GETITEMA {$ENDIF}; - - HDI_WIDTH = $0001; - -type - PHDItemA = ^THDItemA; - PHDItemW = ^THDItemW; - PHDItem = {$IFDEF UNICODE_CTRLS} PHDItemW {$ELSE} PHDItemA {$ENDIF}; - _HD_ITEMA = packed record - Mask: Cardinal; - cxy: Integer; - pszText: PAnsiChar; - hbm: HBITMAP; - cchTextMax: Integer; - fmt: Integer; - lParam: LPARAM; - iImage: Integer; // index of bitmap in ImageList - iOrder: Integer; // where to draw this item - end; - _HD_ITEMW = packed record - Mask: Cardinal; - cxy: Integer; - pszText: PWideChar; - hbm: HBITMAP; - cchTextMax: Integer; - fmt: Integer; - lParam: LPARAM; - iImage: Integer; // index of bitmap in ImageList - iOrder: Integer; // where to draw this item - end; - THDItemA = _HD_ITEMA; - THDItemW = _HD_ITEMW; - THDItem = {$IFDEF UNICODE_CTRLS} _HD_ITEMW {$ELSE} _HD_ITEMA {$ENDIF}; - -const - TVS_HASBUTTONS = $0001; - TVS_HASLINES = $0002; - TVS_LINESATROOT = $0004; - TVS_EDITLABELS = $0008; - TVS_DISABLEDRAGDROP = $0010; - TVS_SHOWSELALWAYS = $0020; - TVS_RTLREADING = $0040; - TVS_NOTOOLTIPS = $0080; - TVS_CHECKBOXES = $0100; - TVS_TRACKSELECT = $0200; - TVS_SINGLEEXPAND = $0400; - TVS_INFOTIP = $0800; - TVS_FULLROWSELECT = $1000; - TVS_NOSCROLL = $2000; - TVS_NONEVENHEIGHT = $4000; - - TVIF_TEXT = $0001; - TVIF_IMAGE = $0002; - TVIF_PARAM = $0004; - TVIF_STATE = $0008; - TVIF_HANDLE = $0010; - TVIF_SELECTEDIMAGE = $0020; - TVIF_CHILDREN = $0040; - TVIF_INTEGRAL = $0080; - TVIF_DI_SETITEM = $1000; - - TVIS_FOCUSED = $0001; - TVIS_SELECTED = $0002; - TVIS_CUT = $0004; - TVIS_DROPHILITED = $0008; - TVIS_BOLD = $0010; - TVIS_EXPANDED = $0020; - TVIS_EXPANDEDONCE = $0040; - TVIS_EXPANDPARTIAL = $0080; - - TVIS_OVERLAYMASK = $0F00; - TVIS_STATEIMAGEMASK = $F000; - TVIS_USERMASK = $F000; - - TV_FIRST = $1100; { TreeView messages } - TVM_INSERTITEMA = TV_FIRST + 0; - TVM_INSERTITEMW = TV_FIRST + 50; - TVM_INSERTITEM = {$IFDEF UNICODE_CTRLS} TVM_INSERTITEMW - {$ELSE} TVM_INSERTITEMA {$ENDIF}; - TVM_DELETEITEM = TV_FIRST + 1; - TVM_EXPAND = TV_FIRST + 2; - - TVE_COLLAPSE = $0001; - TVE_EXPAND = $0002; - TVE_TOGGLE = $0003; - TVE_EXPANDPARTIAL = $4000; - TVE_COLLAPSERESET = $8000; - - TVM_GETITEMRECT = TV_FIRST + 4; - TVM_GETCOUNT = TV_FIRST + 5; - TVM_GETINDENT = TV_FIRST + 6; - TVM_SETINDENT = TV_FIRST + 7; - TVM_GETIMAGELIST = TV_FIRST + 8; - - TVSIL_NORMAL = 0; - TVSIL_STATE = 2; - - TVM_SETIMAGELIST = TV_FIRST + 9; - TVM_GETNEXTITEM = TV_FIRST + 10; - - TVGN_ROOT = $0000; - TVGN_NEXT = $0001; - TVGN_PREVIOUS = $0002; - TVGN_PARENT = $0003; - TVGN_CHILD = $0004; - TVGN_FIRSTVISIBLE = $0005; - TVGN_NEXTVISIBLE = $0006; - TVGN_PREVIOUSVISIBLE = $0007; - TVGN_DROPHILITE = $0008; - TVGN_CARET = $0009; - TVGN_LASTVISIBLE = $000A; - - TVM_SELECTITEM = TV_FIRST + 11; - TVM_GETITEMA = TV_FIRST + 12; - TVM_GETITEMW = TV_FIRST + 62; - TVM_GETITEM = {$IFDEF UNICODE_CTRLS} TVM_GETITEMW {$ELSE} TVM_GETITEMA {$ENDIF}; - TVM_SETITEMA = TV_FIRST + 13; - TVM_SETITEMW = TV_FIRST + 63; - TVM_SETITEM = {$IFDEF UNICODE_CTRLS} TVM_SETITEMW {$ELSE} TVM_SETITEMA {$ENDIF}; - TVM_EDITLABELA = TV_FIRST + 14; - TVM_EDITLABELW = TV_FIRST + 65; - TVM_EDITLABEL = {$IFDEF UNICODE_CTRLS} TVM_EDITLABELW {$ELSE} TVM_EDITLABELA {$ENDIF}; - TVM_GETEDITCONTROL = TV_FIRST + 15; - TVM_GETVISIBLECOUNT = TV_FIRST + 16; - TVM_HITTEST = TV_FIRST + 17; - - TVHT_NOWHERE = $0001; - TVHT_ONITEMICON = $0002; - TVHT_ONITEMLABEL = $0004; - TVHT_ONITEMINDENT = $0008; - TVHT_ONITEMBUTTON = $0010; - TVHT_ONITEMRIGHT = $0020; - TVHT_ONITEMSTATEICON = $0040; - TVHT_ONITEM = TVHT_ONITEMICON or TVHT_ONITEMLABEL or - TVHT_ONITEMSTATEICON; - - TVHT_ABOVE = $0100; - TVHT_BELOW = $0200; - TVHT_TORIGHT = $0400; - TVHT_TOLEFT = $0800; - - TVM_CREATEDRAGIMAGE = TV_FIRST + 18; - TVM_SORTCHILDREN = TV_FIRST + 19; - TVM_ENSUREVISIBLE = TV_FIRST + 20; - TVM_SORTCHILDRENCB = TV_FIRST + 21; - TVM_ENDEDITLABELNOW = TV_FIRST + 22; - TVM_GETISEARCHSTRINGA = TV_FIRST + 23; - TVM_GETISEARCHSTRINGW = TV_FIRST + 64; - TVM_GETISEARCHSTRING = {$IFDEF UNICODE_CTRLS} TVM_GETISEARCHSTRINGW {$ELSE} TVM_GETISEARCHSTRINGA {$ENDIF}; - TVM_SETTOOLTIPS = TV_FIRST + 24; - TVM_GETTOOLTIPS = TV_FIRST + 25; - TVM_SETINSERTMARK = TV_FIRST + 26; - TVM_SETITEMHEIGHT = TV_FIRST + 27; - TVM_GETITEMHEIGHT = TV_FIRST + 28; - TVM_SETBKCOLOR = TV_FIRST + 29; - TVM_SETTEXTCOLOR = TV_FIRST + 30; - TVM_GETBKCOLOR = TV_FIRST + 31; - TVM_GETTEXTCOLOR = TV_FIRST + 32; - TVM_SETSCROLLTIME = TV_FIRST + 33; - TVM_GETSCROLLTIME = TV_FIRST + 34; - TVM_SETINSERTMARKCOLOR = TV_FIRST + 37; - TVM_GETINSERTMARKCOLOR = TV_FIRST + 38; - TVM_SETLINECOLOR = TV_FIRST + 40; - - TVM_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT; - TVM_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT; - - TVN_FIRST = 0-400; { treeview } - TVN_LAST = 0-499; - TVN_SELCHANGINGA = TVN_FIRST-1; - TVN_SELCHANGEDA = TVN_FIRST-2; - TVN_SELCHANGINGW = TVN_FIRST-50; - TVN_SELCHANGEDW = TVN_FIRST-51; - TVN_SELCHANGING = {$IFDEF UNICODE_CTRLS} TVN_SELCHANGINGW {$ELSE} TVN_SELCHANGINGA {$ENDIF}; - TVN_SELCHANGED = {$IFDEF UNICODE_CTRLS} TVN_SELCHANGEDW {$ELSE} TVN_SELCHANGEDA {$ENDIF}; - - TVC_UNKNOWN = $0000; - TVC_BYMOUSE = $0001; - TVC_BYKEYBOARD = $0002; - - TVN_GETDISPINFOA = TVN_FIRST-3; - TVN_SETDISPINFOA = TVN_FIRST-4; - TVN_GETDISPINFOW = TVN_FIRST-52; - TVN_SETDISPINFOW = TVN_FIRST-53; - TVN_GETDISPINFO = {$IFDEF UNICODE_CTRLS} TVN_GETDISPINFOW {$ELSE} TVN_GETDISPINFOA {$ENDIF}; - TVN_SETDISPINFO = {$IFDEF UNICODE_CTRLS} TVN_SETDISPINFOW {$ELSE} TVN_SETDISPINFOA {$ENDIF}; - - TVN_ITEMEXPANDINGA = TVN_FIRST-5; - TVN_ITEMEXPANDEDA = TVN_FIRST-6; - TVN_BEGINDRAGA = TVN_FIRST-7; - TVN_BEGINRDRAGA = TVN_FIRST-8; - TVN_DELETEITEMA = TVN_FIRST-9; - TVN_BEGINLABELEDITA = TVN_FIRST-10; - TVN_ENDLABELEDITA = TVN_FIRST-11; - TVN_GETINFOTIPA = TVN_FIRST-13; - TVN_ITEMEXPANDINGW = TVN_FIRST-54; - TVN_ITEMEXPANDEDW = TVN_FIRST-55; - TVN_BEGINDRAGW = TVN_FIRST-56; - TVN_BEGINRDRAGW = TVN_FIRST-57; - TVN_DELETEITEMW = TVN_FIRST-58; - TVN_BEGINLABELEDITW = TVN_FIRST-59; - TVN_ENDLABELEDITW = TVN_FIRST-60; - TVN_GETINFOTIPW = TVN_FIRST-14; - TVN_ITEMEXPANDING = {$IFDEF UNICODE_CTRLS} TVN_ITEMEXPANDINGW {$ELSE} TVN_ITEMEXPANDINGA {$ENDIF}; - TVN_ITEMEXPANDED = {$IFDEF UNICODE_CTRLS} TVN_ITEMEXPANDEDW {$ELSE} TVN_ITEMEXPANDEDA {$ENDIF}; - TVN_BEGINDRAG = {$IFDEF UNICODE_CTRLS} TVN_BEGINDRAGW {$ELSE} TVN_BEGINDRAGA {$ENDIF}; - TVN_BEGINRDRAG = {$IFDEF UNICODE_CTRLS} TVN_BEGINRDRAGW {$ELSE} TVN_BEGINRDRAGA {$ENDIF}; - TVN_DELETEITEM = {$IFDEF UNICODE_CTRLS} TVN_DELETEITEMW {$ELSE} TVN_DELETEITEMA {$ENDIF}; - TVN_BEGINLABELEDIT = {$IFDEF UNICODE_CTRLS} TVN_BEGINLABELEDITW {$ELSE} TVN_BEGINLABELEDITA {$ENDIF}; - TVN_ENDLABELEDIT = {$IFDEF UNICODE_CTRLS} TVN_ENDLABELEDITW {$ELSE} TVN_ENDLABELEDITA {$ENDIF}; - TVN_GETINFOTIP = {$IFDEF UNICODE_CTRLS} TVN_GETINFOTIPW {$ELSE} TVN_GETINFOTIPA {$ENDIF}; - TVN_KEYDOWN = TVN_FIRST-12; - TVN_SINGLEEXPAND = TVN_FIRST-15; - - TVI_ROOT = $FFFF0000; - TVI_FIRST = $FFFF0001; - TVI_LAST = $FFFF0002; - TVI_SORT = $FFFF0003; - -type - PTVItemA = ^TTVItemA; - PTVItemW = ^TTVItemW; - PTVItem = {$IFDEF UNICODE_CTRLS} PTVItemW {$ELSE} PTVItemA {$ENDIF}; - tagTVITEMA = packed record - mask: UINT; - hItem: THandle; - state: UINT; - stateMask: UINT; - pszText: PAnsiChar; - cchTextMax: Integer; - iImage: Integer; - iSelectedImage: Integer; - cChildren: Integer; - lParam: LPARAM; - end; - tagTVITEMW = packed record - mask: UINT; - hItem: THandle; - state: UINT; - stateMask: UINT; - pszText: PWideChar; - cchTextMax: Integer; - iImage: Integer; - iSelectedImage: Integer; - cChildren: Integer; - lParam: LPARAM; - end; - tagTVITEM = {$IFDEF UNICODE_CTRLS} tagTVITEMW {$ELSE} tagTVITEMA {$ENDIF}; - _TV_ITEMA = tagTVITEMA; - _TV_ITEMW = tagTVITEMW; - _TV_ITEM = {$IFDEF UNICODE_CTRLS} _TV_ITEMW {$ELSE} _TV_ITEMA {$ENDIF}; - TTVItemA = tagTVITEMA; - TTVItemW = tagTVITEMW; - TTVItem = {$IFDEF UNICODE_CTRLS} TTVItemW {$ELSE} TTVItemA {$ENDIF}; - TV_ITEMA = tagTVITEMA; - TV_ITEMW = tagTVITEMW; - TV_ITEM = {$IFDEF UNICODE_CTRLS} TV_ITEMW {$ELSE} TV_ITEMA {$ENDIF}; - - // only used for Get and Set messages. no notifies - tagTVITEMEXA = packed record - mask: UINT; - hItem: THandle; - state: UINT; - stateMask: UINT; - pszText: PAnsiChar; - cchTextMax: Integer; - iImage: Integer; - iSelectedImage: Integer; - cChildren: Integer; - lParam: LPARAM; - iIntegral: Integer; - end; - tagTVITEMEXW = packed record - mask: UINT; - hItem: THandle; - state: UINT; - stateMask: UINT; - pszText: PWideChar; - cchTextMax: Integer; - iImage: Integer; - iSelectedImage: Integer; - cChildren: Integer; - lParam: LPARAM; - iIntegral: Integer; - end; - tagTVITEMEX = {$IFDEF UNICODE_CTRLS} tagTVITEMEXW {$ELSE} tagTVITEMEXA {$ENDIF}; - PTVItemExA = ^TTVItemExA; - PTVItemExW = ^TTVItemExW; - PTVItemEx = {$IFDEF UNICODE_CTRLS} PTVItemExW {$ELSE} PTVItemExA {$ENDIF}; - TTVItemExA = tagTVITEMEXA; - TTVItemExW = tagTVITEMEXW; - TTVItemEx = {$IFDEF UNICODE_CTRLS} TTVItemExW {$ELSE} TTVItemExA {$ENDIF}; - - PNMTreeViewA = ^TNMTreeViewA; - PNMTreeViewW = ^TNMTreeViewW; - PNMTreeView = {$IFDEF UNICODE_CTRLS} PNMTreeViewW {$ELSE} PNMTreeViewA {$ENDIF}; - tagNMTREEVIEWA = packed record - hdr: TNMHDR; - action: Integer; - itemOld: TTVItemA; - itemNew: TTVItemA; - ptDrag: TPoint; - end; - tagNMTREEVIEWW = packed record - hdr: TNMHDR; - action: Integer; - itemOld: TTVItemW; - itemNew: TTVItemW; - ptDrag: TPoint; - end; - tagNMTREEVIEW = {$IFDEF UNICODE_CTRLS} tagNMTREEVIEWW {$ELSE} tagNMTREEVIEWA {$ENDIF}; - _NM_TREEVIEWA = tagNMTREEVIEWA; - _NM_TREEVIEWW = tagNMTREEVIEWW; - _NM_TREEVIEW = {$IFDEF UNICODE_CTRLS} _NM_TREEVIEWW {$ELSE} _NM_TREEVIEWA {$ENDIF}; - TNMTreeViewA = tagNMTREEVIEWA; - TNMTreeViewW = tagNMTREEVIEWW; - TNMTreeView = {$IFDEF UNICODE_CTRLS} TNMTreeViewW {$ELSE} TNMTreeViewA {$ENDIF}; - NM_TREEVIEWA = tagNMTREEVIEWA; - NM_TREEVIEWW = tagNMTREEVIEWW; - NM_TREEVIEW = {$IFDEF UNICODE_CTRLS} NM_TREEVIEWW {$ELSE} NM_TREEVIEWA {$ENDIF}; - - tagNMCUSTOMDRAWINFO = packed record - hdr: TNMHdr; - dwDrawStage: DWORD; - hdc: HDC; - rc: TRect; - dwItemSpec: DWORD; // this is control specific, but it's how to specify an item. valid only with CDDS_ITEM bit set - uItemState: UINT; - lItemlParam: LPARAM; - end; - PNMCustomDraw = ^TNMCustomDraw; - TNMCustomDraw = tagNMCUSTOMDRAWINFO; - -const - // custom draw return flags - // values under 0x00010000 are reserved for global custom draw values. - // above that are for specific controls - CDRF_DODEFAULT = $00000000; - CDRF_NEWFONT = $00000002; - CDRF_SKIPDEFAULT = $00000004; - CDRF_NOTIFYPOSTPAINT = $00000010; - CDRF_NOTIFYITEMDRAW = $00000020; - CDRF_NOTIFYSUBITEMDRAW = $00000020; // flags are the same, we can distinguish by context - CDRF_NOTIFYPOSTERASE = $00000040; - - // drawstage flags - // values under = $00010000 are reserved for global custom draw values. - // above that are for specific controls - CDDS_PREPAINT = $00000001; - CDDS_POSTPAINT = $00000002; - CDDS_PREERASE = $00000003; - CDDS_POSTERASE = $00000004; - // the = $000010000 bit means it's individual item specific - CDDS_ITEM = $00010000; - CDDS_ITEMPREPAINT = CDDS_ITEM or CDDS_PREPAINT; - CDDS_ITEMPOSTPAINT = CDDS_ITEM or CDDS_POSTPAINT; - CDDS_ITEMPREERASE = CDDS_ITEM or CDDS_PREERASE; - CDDS_ITEMPOSTERASE = CDDS_ITEM or CDDS_POSTERASE; - CDDS_SUBITEM = $00020000; - - // itemState flags - CDIS_SELECTED = $0001; - CDIS_GRAYED = $0002; - CDIS_DISABLED = $0004; - CDIS_CHECKED = $0008; - CDIS_FOCUS = $0010; - CDIS_DEFAULT = $0020; - CDIS_HOT = $0040; - CDIS_MARKED = $0080; - CDIS_INDETERMINATE = $0100; - -type - tagNMLVCUSTOMDRAW = packed record - nmcd: TNMCustomDraw; - clrText: COLORREF; - clrTextBk: COLORREF; - iSubItem: Integer; // IE 4.0 and higher - end; - PNMLVCustomDraw = ^TNMLVCustomDraw; - TNMLVCustomDraw = tagNMLVCUSTOMDRAW; - - - - - PTVDispInfoA = ^TTVDispInfoA; - PTVDispInfoW = ^TTVDispInfoW; - PTVDispInfo = {$IFDEF UNICODE_CTRLS} PTVDispInfoW {$ELSE} PTVDispInfoA {$ENDIF}; - tagTVDISPINFOA = packed record - hdr: TNMHDR; - item: TTVItemA; - end; - tagTVDISPINFOW = packed record - hdr: TNMHDR; - item: TTVItemW; - end; - tagTVDISPINFO = {$IFDEF UNICODE_CTRLS} tagTVDISPINFOW {$ELSE} tagTVDISPINFOA {$ENDIF}; - _TV_DISPINFOA = tagTVDISPINFOA; - _TV_DISPINFOW = tagTVDISPINFOW; - _TV_DISPINFO = {$IFDEF UNICODE_CTRLS} _TV_DISPINFOW {$ELSE} _TV_DISPINFOA {$ENDIF}; - TTVDispInfoA = tagTVDISPINFOA; - TTVDispInfoW = tagTVDISPINFOW; - TTVDispInfo = {$IFDEF UNICODE_CTRLS} TTVDispInfoW {$ELSE} TTVDispInfoA {$ENDIF}; - TV_DISPINFOA = tagTVDISPINFOA; - TV_DISPINFOW = tagTVDISPINFOW; - TV_DISPINFO = {$IFDEF UNICODE_CTRLS} TV_DISPINFOW {$ELSE} TV_DISPINFOA {$ENDIF}; - - tagNMMOUSE = packed record - hdr: TNMHdr; - dwItemSpec: DWORD; - dwItemData: DWORD; - pt: TPoint; - dwHitInfo: DWORD; // any specifics about where on the item or control the mouse is - end; - PNMMouse = ^TNMMouse; - TNMMouse = tagNMMOUSE; - -type - PTVHitTestInfo = ^TTVHitTestInfo; - TTVHitTestInfo = packed Record - pt: TPoint; - fl: DWORD; - hItem: THandle; - end; - - - -const - - cctrl = 'comctl32.dll'; - - HINST_COMMCTRL = THandle(-1); - - CCS_TOP = $00000001; - CCS_NOMOVEY = $00000002; - CCS_BOTTOM = $00000003; - CCS_NORESIZE = $00000004; - CCS_NOPARENTALIGN = $00000008; - CCS_ADJUSTABLE = $00000020; - CCS_NODIVIDER = $00000040; - CCS_VERT = $00000080; - CCS_LEFT = (CCS_VERT or CCS_TOP); - CCS_RIGHT = (CCS_VERT or CCS_BOTTOM); - CCS_NOMOVEX = (CCS_VERT or CCS_NOMOVEY); - - PROGRESS_CLASS: array[ 0..17 ] of KOLChar = ('m','s','c','t','l','s','_', - 'p','r','o','g','r','e','s','s','3','2',#0); - STATUSCLASSNAME: array[ 0..18 ] of KOLChar = ('m','s','c','t','l','s','_', - 's','t','a','t','u','s','b','a','r','3','2',#0); - WC_LISTVIEW: array[0..13] of KOLChar = ('S','y','s','L','i','s','t', - 'V','i','e','w','3','2',#0); - TOOLBARCLASSNAME: array[0..15] of KOLChar = ('T','o','o','l','b','a','r', - 'W','i','n','d','o','w','3','2',#0 ); - TOOLTIPS_CLASS: array[0..16] of KOLChar = ('t','o','o','l','t','i','p','s','_', - 'c','l','a','s','s','3','2',#0); - WC_TREEVIEW: array[0..13] of KOLChar = ('S','y','s','T','r','e','e', - 'V','i','e','w','3','2',#0); - WC_TABCONTROL: array[0..15] of KOLChar = ('S','y','s','T','a','b','C','o','n','t', - 'r','o','l','3','2',#0); - DATETIMEPICK_CLASS: array[ 0..17 ] of KOLChar = ( - 'S','y','s','D','a','t','e','T','i','m','e','P','i','c','k','3','2',#0 ); - - TBN_FIRST = 0-700; { toolbar } - TBN_LAST = 0-720; - - TBCDRF_NOEDGES = $00010000; // Don't draw button edges - TBCDRF_HILITEHOTTRACK = $00020000; // Use color of the button bk when hottracked - TBCDRF_NOOFFSET = $00040000; // Don't offset button if pressed - TBCDRF_NOMARK = $00080000; // Don't draw default highlight of image/text for TBSTATE_MARKED - TBCDRF_NOETCHEDEFFECT = $00100000; // Don't draw etched effect for disabled items - - TB_ENABLEBUTTON = WM_USER + 1; - TB_CHECKBUTTON = WM_USER + 2; - TB_PRESSBUTTON = WM_USER + 3; - TB_HIDEBUTTON = WM_USER + 4; - TB_INDETERMINATE = WM_USER + 5; - TB_MARKBUTTON = WM_USER + 6; - TB_ISBUTTONENABLED = WM_USER + 9; - TB_ISBUTTONCHECKED = WM_USER + 10; - TB_ISBUTTONPRESSED = WM_USER + 11; - TB_ISBUTTONHIDDEN = WM_USER + 12; - TB_ISBUTTONINDETERMINATE = WM_USER + 13; - TB_ISBUTTONHIGHLIGHTED = WM_USER + 14; - TB_SETSTATE = WM_USER + 17; - TB_GETSTATE = WM_USER + 18; - TB_ADDBITMAP = WM_USER + 19; - TB_ADDBUTTONSA = WM_USER + 20; - TB_ADDBUTTONSW = WM_USER + 68; - TB_INSERTBUTTONA = WM_USER + 21; - TB_INSERTBUTTONW = WM_USER + 67; - TB_DELETEBUTTON = WM_USER + 22; - TB_GETBUTTON = WM_USER + 23; - TB_BUTTONCOUNT = WM_USER + 24; - TB_COMMANDTOINDEX = WM_USER + 25; - - TB_SAVERESTOREA = WM_USER + 26; - TB_ADDSTRINGA = WM_USER + 28; - TB_GETBUTTONTEXTA = WM_USER + 45; - TBN_GETBUTTONINFOA = TBN_FIRST-0; - - TB_GETBUTTONINFOW = WM_USER + 63; - TB_SETBUTTONINFOW = WM_USER + 64; - TB_GETBUTTONINFOA = WM_USER + 65; - TB_SETBUTTONINFOA = WM_USER + 66; - TB_GETBUTTONINFO = {$IFDEF UNICODE_CTRLS} TB_GETBUTTONINFOW {$ELSE} TB_GETBUTTONINFOA {$ENDIF}; - TB_SETBUTTONINFO = {$IFDEF UNICODE_CTRLS} TB_SETBUTTONINFOW {$ELSE} TB_SETBUTTONINFOA {$ENDIF}; - - TB_SAVERESTOREW = WM_USER + 76; - TB_ADDSTRINGW = WM_USER + 77; - TB_GETBUTTONTEXTW = WM_USER + 75; - TBN_GETBUTTONINFOW = TBN_FIRST-20; - TB_SAVERESTORE = {$IFDEF UNICODE_CTRLS} TB_SAVERESTOREW {$ELSE} TB_SAVERESTOREA {$ENDIF}; - TB_ADDSTRING = {$IFDEF UNICODE_CTRLS} TB_ADDSTRINGW {$ELSE} TB_ADDSTRINGA {$ENDIF}; - TB_GETBUTTONTEXT = {$IFDEF UNICODE_CTRLS} TB_GETBUTTONTEXTW {$ELSE} TB_GETBUTTONTEXTA {$ENDIF}; - TBN_GETBUTTONINFO = {$IFDEF UNICODE_CTRLS} TBN_GETBUTTONINFOW {$ELSE} TBN_GETBUTTONINFOA {$ENDIF}; - - TBN_DROPDOWN = TBN_FIRST-10; - TBN_CLOSEUP = TBN_FIRST-11; - - TB_CUSTOMIZE = WM_USER + 27; - TB_GETITEMRECT = WM_USER + 29; - TB_BUTTONSTRUCTSIZE = WM_USER + 30; - TB_SETBUTTONSIZE = WM_USER + 31; - TB_SETBITMAPSIZE = WM_USER + 32; - TB_AUTOSIZE = WM_USER + 33; - TB_GETTOOLTIPS = WM_USER + 35; - TB_SETTOOLTIPS = WM_USER + 36; - TB_SETPARENT = WM_USER + 37; - TB_SETROWS = WM_USER + 39; - TB_GETROWS = WM_USER + 40; - TB_SETCMDID = WM_USER + 42; - TB_CHANGEBITMAP = WM_USER + 43; - TB_GETBITMAP = WM_USER + 44; - TB_REPLACEBITMAP = WM_USER + 46; - TB_SETINDENT = WM_USER + 47; - TB_SETIMAGELIST = WM_USER + 48; - TB_GETIMAGELIST = WM_USER + 49; - TB_LOADIMAGES = WM_USER + 50; - TB_GETRECT = WM_USER + 51; { wParam is the Cmd instead of index } - TB_SETHOTIMAGELIST = WM_USER + 52; - TB_GETHOTIMAGELIST = WM_USER + 53; - TB_SETDISABLEDIMAGELIST = WM_USER + 54; - TB_GETDISABLEDIMAGELIST = WM_USER + 55; - TB_SETSTYLE = WM_USER + 56; - TB_GETSTYLE = WM_USER + 57; - TB_GETBUTTONSIZE = WM_USER + 58; - TB_SETBUTTONWIDTH = WM_USER + 59; - TB_SETMAXTEXTROWS = WM_USER + 60; - TB_GETTEXTROWS = WM_USER + 61; - - TB_GETOBJECT = WM_USER + 62; // wParam == IID, lParam void **ppv - TB_GETHOTITEM = WM_USER + 71; - TB_SETHOTITEM = WM_USER + 72; // wParam == iHotItem - TB_SETANCHORHIGHLIGHT = WM_USER + 73; // wParam == TRUE/FALSE - TB_GETANCHORHIGHLIGHT = WM_USER + 74; - TB_MAPACCELERATORA = WM_USER + 78; // wParam == ch, lParam int * pidBtn - - TB_SETEXTENDEDSTYLE = WM_USER + 84; // For TBSTYLE_EX_* - TB_GETEXTENDEDSTYLE = WM_USER + 85; // For TBSTYLE_EX_* - TB_INSERTBUTTON = {$IFDEF UNICODE_CTRLS} TB_INSERTBUTTONW {$ELSE} TB_INSERTBUTTONA {$ENDIF}; - TB_ADDBUTTONS = {$IFDEF UNICODE_CTRLS} TB_ADDBUTTONSW {$ELSE} TB_ADDBUTTONSA {$ENDIF}; - - IDB_STD_SMALL_COLOR = 0; - IDB_STD_LARGE_COLOR = 1; - IDB_VIEW_SMALL_COLOR = 4; - IDB_VIEW_LARGE_COLOR = 5; - IDB_HIST_SMALL_COLOR = 8; - IDB_HIST_LARGE_COLOR = 9; - - STD_CUT = 0; - STD_COPY = 1; - STD_PASTE = 2; - STD_UNDO = 3; - STD_REDO = 4; - STD_DELETE = 5; - STD_FILENEW = 6; - STD_FILEOPEN = 7; - STD_FILESAVE = 8; - STD_PRINTPRE = 9; - STD_PROPERTIES = 10; - STD_HELP = 11; - STD_FIND = 12; - STD_REPLACE = 13; - STD_PRINT = 14; - -{ icon indexes for standard view bitmap } - - VIEW_LARGEICONS = 0; - VIEW_SMALLICONS = 1; - VIEW_LIST = 2; - VIEW_DETAILS = 3; - VIEW_SORTNAME = 4; - VIEW_SORTSIZE = 5; - VIEW_SORTDATE = 6; - VIEW_SORTTYPE = 7; - VIEW_PARENTFOLDER = 8; - VIEW_NETCONNECT = 9; - VIEW_NETDISCONNECT = 10; - VIEW_NEWFOLDER = 11; - VIEW_VIEWMENU = 12; - -{ icon indexes for standard history bitmap } - - HIST_BACK = 0; - HIST_FORWARD = 1; - HIST_FAVORITES = 2; - HIST_ADDTOFAVORITES = 3; - HIST_VIEWTREE = 4; - - TBSTATE_CHECKED = $01; - TBSTATE_PRESSED = $02; - TBSTATE_ENABLED = $04; - TBSTATE_HIDDEN = $08; - TBSTATE_INDETERMINATE = $10; - TBSTATE_WRAP = $20; - TBSTATE_ELLIPSES = $40; - TBSTATE_MARKED = $80; - - TBSTYLE_BUTTON = $00; - TBSTYLE_SEP = $01; - TBSTYLE_CHECK = $02; - TBSTYLE_GROUP = $04; - TBSTYLE_CHECKGROUP = TBSTYLE_GROUP or TBSTYLE_CHECK; - TBSTYLE_DROPDOWN = $08; - TBSTYLE_AUTOSIZE = $0010; // automatically calculate the cx of the button - TBSTYLE_NOPREFIX = $0020; // if this button should not have accel prefix - - TBSTYLE_TOOLTIPS = $0100; - TBSTYLE_WRAPABLE = $0200; - TBSTYLE_ALTDRAG = $0400; - TBSTYLE_FLAT = $0800; - TBSTYLE_LIST = $1000; - TBSTYLE_CUSTOMERASE = $2000; - TBSTYLE_REGISTERDROP = $4000; - TBSTYLE_TRANSPARENT = $8000; - TBSTYLE_EX_DRAWDDARROWS = $00000001; - - TBIF_IMAGE = $00000001; - TBIF_TEXT = $00000002; - TBIF_STATE = $00000004; - TBIF_STYLE = $00000008; - TBIF_LPARAM = $00000010; - TBIF_COMMAND = $00000020; - TBIF_SIZE = $00000040; - TBIF_BYINDEX = $80000000; - - TTN_FIRST = 0-520; { tooltips } - TTN_LAST = 0-549; - TTN_NEEDTEXTA = TTN_FIRST - 0; - TTN_NEEDTEXT = TTN_FIRST - 0; - TTN_NEEDTEXTW = TTN_FIRST - 10; - - TTS_ALWAYSTIP = $01; - TTS_NOPREFIX = $02; - - TTM_ACTIVATE = WM_USER + 1; - TTM_SETDELAYTIME = WM_USER + 3; - - TTM_ADDTOOLA = WM_USER + 4; - TTM_DELTOOLA = WM_USER + 5; - TTM_NEWTOOLRECTA = WM_USER + 6; - TTM_GETTOOLINFOA = WM_USER + 8; - TTM_SETTOOLINFOA = WM_USER + 9; - TTM_HITTESTA = WM_USER + 10; - TTM_GETTEXTA = WM_USER + 11; - TTM_UPDATETIPTEXTA = WM_USER + 12; - TTM_ENUMTOOLSA = WM_USER + 14; - TTM_GETCURRENTTOOLA = WM_USER + 15; - - TTM_ADDTOOLW = WM_USER + 50; - TTM_DELTOOLW = WM_USER + 51; - TTM_NEWTOOLRECTW = WM_USER + 52; - TTM_GETTOOLINFOW = WM_USER + 53; - TTM_SETTOOLINFOW = WM_USER + 54; - TTM_HITTESTW = WM_USER + 55; - TTM_GETTEXTW = WM_USER + 56; - TTM_UPDATETIPTEXTW = WM_USER + 57; - TTM_ENUMTOOLSW = WM_USER + 58; - TTM_GETCURRENTTOOLW = WM_USER + 59; - TTM_WINDOWFROMPOINT = WM_USER + 16; - TTM_TRACKACTIVATE = WM_USER + 17; // wParam = TRUE/FALSE start end lparam = LPTOOLINFO - TTM_TRACKPOSITION = WM_USER + 18; // lParam = dwPos - TTM_SETTIPBKCOLOR = WM_USER + 19; - TTM_SETTIPTEXTCOLOR = WM_USER + 20; - TTM_GETDELAYTIME = WM_USER + 21; - TTM_GETTIPBKCOLOR = WM_USER + 22; - TTM_GETTIPTEXTCOLOR = WM_USER + 23; - TTM_SETMAXTIPWIDTH = WM_USER + 24; - TTM_GETMAXTIPWIDTH = WM_USER + 25; - TTM_SETMARGIN = WM_USER + 26; // lParam = lprc - TTM_GETMARGIN = WM_USER + 27; // lParam = lprc - TTM_POP = WM_USER + 28; - TTM_POPUP = WM_USER + 34; - TTM_UPDATE = WM_USER + 29; - - TTM_ADDTOOL = {$IFDEF UNICODE_CTRLS} TTM_ADDTOOLW {$ELSE} TTM_ADDTOOLA {$ENDIF}; - TTM_DELTOOL = {$IFDEF UNICODE_CTRLS} TTM_DELTOOLW {$ELSE} TTM_DELTOOLA {$ENDIF}; - TTM_NEWTOOLRECT = {$IFDEF UNICODE_CTRLS} TTM_NEWTOOLRECTW {$ELSE} TTM_NEWTOOLRECTA {$ENDIF}; - TTM_GETTOOLINFO = {$IFDEF UNICODE_CTRLS} TTM_GETTOOLINFOW {$ELSE} TTM_GETTOOLINFOA {$ENDIF}; - TTM_SETTOOLINFO = {$IFDEF UNICODE_CTRLS} TTM_SETTOOLINFOW {$ELSE} TTM_SETTOOLINFOA {$ENDIF}; - TTM_HITTEST = {$IFDEF UNICODE_CTRLS} TTM_HITTESTW {$ELSE} TTM_HITTESTA {$ENDIF}; - TTM_GETTEXT = {$IFDEF UNICODE_CTRLS} TTM_GETTEXTW {$ELSE} TTM_GETTEXTA {$ENDIF}; - TTM_UPDATETIPTEXT = {$IFDEF UNICODE_CTRLS} TTM_UPDATETIPTEXTW {$ELSE} TTM_UPDATETIPTEXTA {$ENDIF}; - TTM_ENUMTOOLS = {$IFDEF UNICODE_CTRLS} TTM_ENUMTOOLSW {$ELSE} TTM_ENUMTOOLSA {$ENDIF}; - TTM_GETCURRENTTOOL = {$IFDEF UNICODE_CTRLS} TTM_GETCURRENTTOOLW {$ELSE} TTM_GETCURRENTTOOLA {$ENDIF}; - - TTM_RELAYEVENT = WM_USER + 7; - TTM_GETTOOLCOUNT = WM_USER +13; - - TTF_IDISHWND = $0001; - TTF_CENTERTIP = $0002; - TTF_RTLREADING = $0004; - TTF_SUBCLASS = $0010; - TTF_TRACK = $0020; - TTF_ABSOLUTE = $0080; - TTF_TRANSPARENT = $0100; - TTF_DI_SETITEM = $8000; // valid only on the TTN_NEEDTEXT callback - - LPSTR_TEXTCALLBACKA = LPSTR(-1); - LPSTR_TEXTCALLBACKW = LPWSTR(-1); - LPSTR_TEXTCALLBACK = {$IFDEF UNICODE_CTRLS} LPSTR_TEXTCALLBACKW {$ELSE} LPSTR_TEXTCALLBACKA {$ENDIF}; - - CW_USEDEFAULT = Integer($80000000); - -type - PTBAddBitmap = ^TTBAddBitmap; - TTBAddBitmap = packed record - hInst: THandle; - nID: UINT; - end; - - PTBButton = ^TTBButton; - TTBButton = packed record - iBitmap: Integer; - idCommand: Integer; - fsState: Byte; - fsStyle: Byte; - bReserved: array[1..2] of Byte; - dwData: Longint; - iString: Integer; - end; - - PTBButtonInfo = ^TTBButtonInfo; - TTBButtonInfo = packed record - cbSize: UINT; - dwMask: DWORD; - idCommand: Integer; - iImage: Integer; - fsState: Byte; - fsStyle: Byte; - cx: Word; - lParam: DWORD; - pszText: PKOLChar; - cchText: Integer; - end; - - PColorMap = ^TColorMap; - TColorMap = packed record - cFrom: TColorRef; - cTo: TColorRef; - end; - - PTBNotify = ^TTBnotify; - TTBNotify = packed record - hdr: TNMHdr; - iItem: Integer; - tbButton: TTBButton; - cchText: Integer; - pszText: PChar; - end; - - PNMTBCustomDraw = ^TNMTBCustomDraw; - TNMTBCustomDraw = packed record - nmcd: TNMCUSTOMDRAW; - hbrMonoDither: HBrush; - hbrLines : HBrush; - hpenLines : HPen; - clrText : COLORREF; - clrMark : COLORREF; - clrTextHighlight: COLORREF; - clrBtnFace : COLORREF; - clrBtnHighlight : COLORREF; - clrHighlightHotTrack: COLORREF; - rcText : TRect; - nStringBkMode : Integer; - nHLStringBkMode : Integer; - iListGap : Integer; - end; - - PTooltipText = ^TTooltipText; - TTooltipText = packed record - hdr: TNMHdr; - lpszText: PKOLChar; - szText: array[0..79] of KOLChar; - hinst: HINST; - uFlags: UINT; - lParam: LPARAM; - end; - - PToolInfo = ^TToolInfo; - TToolInfo = packed record - cbSize: UINT; - uFlags: UINT; - hwnd: HWND; - uId: UINT; - Rect: TRect; - hInst: THandle; - lpszText: PKOLChar; - lParam: LPARAM; - end; - -const - WM_MOUSEHOVER = $02A1; - WM_MOUSELEAVE = $02A3; - - TME_HOVER = $00000001; - TME_LEAVE = $00000002; - TME_QUERY = $40000000; - TME_CANCEL = $80000000; - - HOVER_DEFAULT = $FFFFFFFF; - - ODT_HEADER = 100; - ODT_TAB = 101; - ODT_LISTVIEW = 102; - -type - tagTRACKMOUSEEVENT = packed record - cbSize: DWORD; - dwFlags: DWORD; - hwndTrack: HWND; - dwHoverTime: DWORD; - end; - PTrackMouseEvent = ^TTrackMouseEvent; - TTrackMouseEvent = tagTRACKMOUSEEVENT; - -////////////////////////////////////////////////////////////////////////////// - - -///////////////////////////////////////////////////////// -// Some stuff from new Delphi versions (not available in old ones): - {$IFNDEF UNICODE_CTRLS} -const - //IDC_HAND = MakeIntResource(32649); - IDC_HAND = PChar(32649); - {$ENDIF} - -///////////////////////////////////////////////////////// -const - VK_PAGE_DOWN = VK_NEXT; - VK_PAGE_UP = VK_PRIOR; - VK_ALT = VK_MENU; - -PBT_APMQUERYSUSPEND = 00 ; -PBT_APMQUERYSTANDBY = 01 ; -PBT_APMQUERYSUSPENDFAILED = 02 ; -PBT_APMQUERYSTANDBYFAILED = 03 ; -PBT_APMSUSPEND = 04 ; -PBT_APMSTANDBY = 05 ; -PBT_APMRESUMECRITICAL = 06 ; -PBT_APMRESUMESUSPEND = 07 ; -PBT_APMRESUMESTANDBY = 08 ; -PBTF_APMRESUMEFROMFAILURE = 000001 ; -PBT_APMBATTERYLOW = 09 ; -PBT_APMPOWERSTATUSCHANGE = 10 ; -PBT_APMOEMEVENT = 11 ; -PBT_APMRESUMEAUTOMATIC = $12 ; // hexadecimal $12 = 18 ! - -{ DATETIMEPICKER} - -const - // messages - DTM_FIRST = $1000; - DTM_GETSYSTEMTIME = DTM_FIRST + 1; - DTM_SETSYSTEMTIME = DTM_FIRST + 2; - DTM_GETRANGE = DTM_FIRST + 3; - DTM_SETRANGE = DTM_FIRST + 4; - DTM_SETFORMATA = DTM_FIRST + 5; - DTM_SETMCCOLOR = DTM_FIRST + 6; - DTM_GETMCCOLOR = DTM_FIRST + 7; - DTM_GETMONTHCAL = DTM_FIRST + 8; - DTM_SETMCFONT = DTM_FIRST + 9; - DTM_GETMCFONT = DTM_FIRST + 10; - DTM_SETFORMATW = DTM_FIRST + 50; - DTM_SETFORMAT = {$IFDEF UNICODE_CTRLS} DTM_SETFORMATW {$ELSE} DTM_SETFORMATA {$ENDIF}; - - // Ranges - GDTR_MIN = $0001; - GDTR_MAX = $0002; - - // Return Values - GDT_ERROR = -1; - GDT_VALID = 0; - GDT_NONE = 1; - - // notifications - DTN_FIRST = 0-760; { datetimepick } - DTN_LAST = 0-799; - - DTN_DATETIMECHANGE = DTN_FIRST + 1; // the systemtime has changed - DTN_USERSTRINGA = DTN_FIRST + 2; // the user has entered a string - DTN_USERSTRINGW = DTN_FIRST + 15; - DTN_WMKEYDOWNA = DTN_FIRST + 3; // modify keydown on app format field (X) - DTN_WMKEYDOWNW = DTN_FIRST + 16; - DTN_FORMATA = DTN_FIRST + 4; // query display for app format field (X) - DTN_FORMATW = DTN_FIRST + 17; - DTN_FORMATQUERYA = DTN_FIRST + 5; // query formatting info for app format field (X) - DTN_FORMATQUERYW = DTN_FIRST + 18; - DTN_DROPDOWN = DTN_FIRST + 6; // MonthCal has dropped down - DTN_CLOSEUP = DTN_FIRST + 7; // MonthCal is popping up - DTN_USERSTRING = {$IFDEF UNICODE_CTRLS} DTN_USERSTRINGW {$ELSE} DTN_USERSTRINGA {$ENDIF}; - DTN_WMKEYDOWN = {$IFDEF UNICODE_CTRLS} DTN_WMKEYDOWNW {$ELSE} DTN_WMKEYDOWNA {$ENDIF}; - DTN_FORMAT = {$IFDEF UNICODE_CTRLS} DTN_FORMATW {$ELSE} DTN_FORMATA {$ENDIF}; - DTN_FORMATQUERY = {$IFDEF UNICODE_CTRLS} DTN_FORMATQUERYW {$ELSE} DTN_FORMATQUERYA {$ENDIF}; - - // styles - DTS_UPDOWN = $0001; // use UPDOWN instead of MONTHCAL - DTS_SHOWNONE = $0002; // allow a NONE selection - DTS_SHORTDATEFORMAT = $0000; // use the short date format - // (app must forward WM_WININICHANGE messages) - DTS_LONGDATEFORMAT = $0004; // use the long date format - // (app must forward WM_WININICHANGE messages) - DTS_TIMEFORMAT = $0008; // use the time format - // (app must forward WM_WININICHANGE messages) - DTS_APPCANPARSE = $0010; // allow user entered strings - // (app MUST respond to DTN_USERSTRING) - DTS_RIGHTALIGN = $0020; // right-align popup instead of left-align it - - // color index constants - MCSC_BACKGROUND = 0; // the background color (between months) - MCSC_TEXT = 1; // the dates - MCSC_TITLEBK = 2; // background of the title - MCSC_TITLETEXT = 3; - MCSC_MONTHBK = 4; // background within the month cal - MCSC_TRAILINGTEXT = 5; // the text color of header & trailing days - - // structures -type - tagNMDATETIMESTRINGA = packed record - nmhdr: TNmHdr; - pszUserString: PAnsiChar; // string user entered - st: TSystemTime; // app fills this in - dwFlags: DWORD; // GDT_VALID or GDT_NONE - end; - tagNMDATETIMESTRINGW = packed record - nmhdr: TNmHdr; - pszUserString: PWideChar; // string user entered - st: TSystemTime; // app fills this in - dwFlags: DWORD; // GDT_VALID or GDT_NONE - end; - tagNMDATETIMESTRING = {$IFDEF UNICODE_CTRLS} tagNMDATETIMESTRINGW {$ELSE} tagNMDATETIMESTRINGA {$ENDIF}; - PNMDateTimeStringA = ^TNMDateTimeStringA; - PNMDateTimeStringW = ^TNMDateTimeStringW; - PNMDateTimeString = {$IFDEF UNICODE_CTRLS} PNMDateTimeStringW {$ELSE} PNMDateTimeStringA {$ENDIF}; - TNMDateTimeStringA = tagNMDATETIMESTRINGA; - TNMDateTimeStringW = tagNMDATETIMESTRINGW; - TNMDateTimeString = {$IFDEF UNICODE_CTRLS} TNMDateTimeStringW {$ELSE} TNMDateTimeStringA {$ENDIF}; - -const - HDN_FIRST = 0-300; { header } - HDN_LAST = 0-399; - HDM_HITTEST = HDM_FIRST + 6; - HDM_GETITEMRECT = HDM_FIRST + 7; - HDM_SETIMAGELIST = HDM_FIRST + 8; - HDM_GETIMAGELIST = HDM_FIRST + 9; - HDM_ORDERTOINDEX = HDM_FIRST + 15; - HDM_CREATEDRAGIMAGE = HDM_FIRST + 16; // wparam = which item = by index; - HDM_GETORDERARRAY = HDM_FIRST + 17; - HDM_SETORDERARRAY = HDM_FIRST + 18; - HDM_SETHOTDIVIDER = HDM_FIRST + 19; - HDM_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT; - HDM_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT; - HDN_ITEMCHANGINGA = HDN_FIRST-0; - HDN_ITEMCHANGEDA = HDN_FIRST-1; - HDN_ITEMCLICKA = HDN_FIRST-2; - HDN_ITEMDBLCLICKA = HDN_FIRST-3; - HDN_DIVIDERDBLCLICKA = HDN_FIRST-5; - HDN_BEGINTRACKA = HDN_FIRST-6; - HDN_ENDTRACKA = HDN_FIRST-7; - HDN_TRACKA = HDN_FIRST-8; - HDN_GETDISPINFOA = HDN_FIRST-9; - HDN_BEGINDRAG = HDN_FIRST-10; - HDN_ENDDRAG = HDN_FIRST-11; - - HDN_ITEMCHANGINGW = HDN_FIRST-20; - HDN_ITEMCHANGEDW = HDN_FIRST-21; - HDN_ITEMCLICKW = HDN_FIRST-22; - HDN_ITEMDBLCLICKW = HDN_FIRST-23; - HDN_DIVIDERDBLCLICKW = HDN_FIRST-25; - HDN_BEGINTRACKW = HDN_FIRST-26; - HDN_ENDTRACKW = HDN_FIRST-27; - HDN_TRACKW = HDN_FIRST-28; - HDN_GETDISPINFOW = HDN_FIRST-29; - -type - tagNMHEADERA = packed record - Hdr: TNMHdr; - Item: Integer; - Button: Integer; - PItem: PHDItemA; - end; - tagNMHEADERW = packed record - Hdr: TNMHdr; - Item: Integer; - Button: Integer; - PItem: PHDItemW; - end; - tagNMHEADER = tagNMHEADERA; - PHDNotifyA = ^THDNotifyA; - PHDNotifyW = ^THDNotifyW; - THDNotifyA = tagNMHEADERA; - THDNotifyW = tagNMHEADERW; - -{******************************************************************************} diff --git a/plugins/ImportTXT/kol/delphidef.inc b/plugins/ImportTXT/kol/delphidef.inc deleted file mode 100644 index a6a6e51c93..0000000000 --- a/plugins/ImportTXT/kol/delphidef.inc +++ /dev/null @@ -1,48 +0,0 @@ -//{$DEFINE _FPC} -{$DEFINE ASM_VERSION} // Comment this line to produce Pascal code. - // Or, just add PAS_VERSION to conditionals - // of your project (must be rebuilt). - -{$IFDEF ASM_VERSION} - {$IFDEF PAS_VERSION} - {$UNDEF ASM_VERSION} - // To compile a project with ASM_VERSION option turned off, - // define a symbol PAS_VERSION in project options. - {$ENDIF} -{$ENDIF} - -{$I KOLDEF.INC} - -//{$DEFINE USE_CONSTRUCTORS} -// Comment this line to produce smaller code if constructors are not used. -// When uncommented, this definition allows to create descendant controls -// and objects overriding constructors, which are actually members of objects. -// Otherwise, global functions (usually named New) are used to -// create and initialize object instances. This gives smaller code, but -// prevents from using OOP inheritance. -// Note: creating descendant objects derived from TObj does not require using -// of this option. It is actually needed only for deriving new controls on -// base of TControl. See also option USE_CUSTOMEXTENSIONS below. - -//{$DEFINE USE_CUSTOMEXTENSIONS} -// Uncomment this option or add it to your project conditional defines, -// if You wish to extend existing TControl object from -// the inner of those. When this option is turned on, include directive at the -// tail of TControl declaration is enabled, causing a compiler to include your -// portion of source directly into the TControl body. See comments near this -// directive there. (Search the word: USE_CUSTOMEXTENSIONS). -// Please note, that this option is not fully supported now. - -{$IFNDEF NOT_UNLOAD_RICHEDITLIB} - {$DEFINE UNLOAD_RICHEDITLIB} -{$ENDIF} -// You can freely comment this directive. 1st, if the application does not -// use richedit control. 2nd, even if it does, freeing the library handle -// actually is not needed. -// Another way to turn this option off is to define symbol NOT_UNLOAD_RICHEDITLIB -// in your project options. - -//{$DEFINE TEST_VERSION} -{$IFNDEF _D6orHigher} - {$DEFINE PARANOIA} //seems not needed under D6 !!! Inprise fixed this, finally... -{$ENDIF} \ No newline at end of file diff --git a/plugins/ImportTXT/kol/err.pas b/plugins/ImportTXT/kol/err.pas deleted file mode 100644 index daeba01826..0000000000 --- a/plugins/ImportTXT/kol/err.pas +++ /dev/null @@ -1,1197 +0,0 @@ -{$DEFINE ASM_VERSION} -//{$DEFINE VARIANT_USED} - -{$IFDEF ASM_VERSION} - {$IFDEF PAS_VERSION} - {$UNDEF ASM_VERSION} - {$ENDIF} -{$ENDIF} - -{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - - KKKKK KKKKK OOOOOOOOO LLLLL - KKKKK KKKKK OOOOOOOOOOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKKKKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL - KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL - - Key Objects Library (C) 2000 by Kladov Vladimir. - - mailto: bonanzas@xcl.cjb.net - Home: http://kol.nm.ru - http://xcl.cjb.net - http://xcl.nm.ru - - =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} -{ - This code is grabbed mainly from standard SysUtils.pas unit, - provided by Borland Delphi. This unit is for handling exceptions, - and to use it just place a reference to exceptions unit in - uses clause of any of your unit or dpr-file. -} - -{ Copyright (C) 1995,99 Inprise Corporation } -{ Copyright (C) 2001, Kladov Vladimir } - -unit err; -{* Unit to provide error handling for KOL programs using efficient - exceptions mechanism. To use it, just place a reference to it into - uses clause of any unit of the project (or dpr-file). - |

- It is possible to use standard SysUtils instead, but it increases - size of executable at least by 10K. Using this unit to handle exceptions - increases executable only by 6,5K. -} - -interface - -uses Windows, KOL; - -{$I KOLDEF.INC} -{$IFDEF _D6orHigher} - {$WARN SYMBOL_DEPRECATED OFF} -{$ENDIF} -{$IFDEF _D7orHigher} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CODE OFF} -{$ENDIF} - -{+} // These resource strings are grabbed from SysConst and changed a bit to make it smaller. - -//{$DEFINE USE_RESOURCESTRING} -{$IFDEF _D2orD3} - {$IFDEF USE_RESOURCESTRING} - {$UNDEF USE_RESOURCESTRING} - {$ENDIF} -{$ENDIF} - -{$IFDEF _D2orD3} -type - LongWord = DWORD; -{$ENDIF} -{$IFNDEF USE_RESOURCESTRING} -const -{$ELSE} -resourcestring -{$ENDIF} - SUnknown = ''; - //SInvalidInteger = '''%s'' is not a valid integer value'; - //SInvalidFloat = '''%s'' is not a valid floating point value'; - //SInvalidDate = '''%s'' is not a valid date'; - //SInvalidTime = '''%s'' is not a valid time'; - //SInvalidDateTime = '''%s'' is not a valid date and time'; - //STimeEncodeError = 'Invalid argument to time encode'; - //SDateEncodeError = 'Invalid argument to date encode'; - SOutOfMemory = 'Out of memory'; - SInOutError = 'I/O error %d'; - SFileNotFound = 'File not found'; - SInvalidFilename = 'Invalid filename'; - STooManyOpenFiles = 'Too many open files'; - SAccessDenied = 'File access denied'; - SEndOfFile = //'Read beyond end of file'; - 'End of file'; - SDiskFull = 'Disk full'; - //SInvalidInput = 'Invalid numeric input'; // {-} Seems for console input only - SDivByZero = 'Division by zero'; - SRangeError = 'Range check error'; - SIntOverflow = 'Integer overflow'; - SInvalidOp = 'Invalid floating point operation'; - SZeroDivide = 'Floating point division by zero'; - SOverflow = 'Floating point overflow'; - SUnderflow = 'Floating point underflow'; - SInvalidPointer = 'Invalid pointer operation'; - SInvalidCast = 'Invalid class typecast'; - SAccessViolation = 'Access violation at address %p. %s of address %p'; - SStackOverflow = 'Stack overflow'; - SControlC = //'Control-C hit'; - '^C'; // {-} for console applications only - SPrivilege = 'Privileged instruction'; - SOperationAborted = 'Operation aborted'; - SException = 'Exception %s in module %s at %p.'#10'%s%s'; - //SExceptTitle = 'Application Error'; - //SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument'; - //SArgumentMissing = 'No argument for format ''%s'''; - SInvalidVarCast = 'Invalid variant type conversion'; - SInvalidVarOp = 'Invalid variant operation'; - SDispatchError = 'Variant method calls not supported'; - SVarArrayCreate = 'Error creating variant array'; - SVarNotArray = 'Variant is not an array'; - SVarArrayBounds = 'Variant array index out of bounds'; - SVar = 'EVariant'; - SReadAccess = 'Read'; - SWriteAccess = 'Write'; - //SResultTooLong = 'Format result longer than 4096 characters'; - //SFormatTooLong = 'Format string too long'; - SExternalException = 'External exception %x'; - SAssertionFailed = 'Assertion failed'; - SIntfCastError = 'Interface not supported'; - SSafecallException = 'Exception in safecall method'; - SAssertError = '%s (%s, line %d)'; - SAbstractError = 'Abstract Error'; - SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p'; - {SCannotReadPackageInfo = 'Cannot access package information for package ''%s'''; - sErrorLoadingPackage = 'Can''t load package %s.'#13#10'%s'; - SInvalidPackageFile = 'Invalid package file ''%s'''; - SInvalidPackageHandle = 'Invalid package handle'; - SDuplicatePackageUnit = 'Cannot load package ''%s.'' It contains unit ''%s,''' + - ';which is also contained in package ''%s''';} - SWin32Error = 'Win32 Error. Code: %d.'#10'%s'; - SUnkWin32Error = 'A Win32 API function failed'; - SNL = 'Application is not licensed to use this feature'; -{-} - -type - -{ Generic procedure pointer } - - TProcedure = procedure; - -{ Generic filename type } - - TFileName = type string; - -{ Exceptions } - Exception = class; - TDestroyException = procedure( Sender: Exception ) of object; - - TError = ( e_Abort, e_Heap, e_OutOfMem, e_InOut, e_External, e_Int, - e_DivBy0, e_Range, e_IntOverflow, e_Math, e_Math_InvalidArgument, - e_InvalidOp, e_ZeroDivide, e_Overflow, e_Underflow, e_InvalidPointer, - e_InvalidCast, e_Convert, e_AccessViolation, e_Privilege, - e_StackOverflow, e_CtrlC, e_Variant, e_PropReadOnly, - e_PropWriteOnly, e_Assertion, e_Abstract, e_IntfCast, - e_InvalidContainer, e_InvalidInsert, e_Package, e_Win32, - e_SafeCall, e_License, e_Custom, e_Com, e_Ole, e_Registry ); - {* Main error codes. These are to determine which exception occure. You - can use e_Custom code for your own exceptions. } - - Exception = class(TObject) - {* Exception class. In KOL, there is a single exception class is used. - Instead of inheriting new exception classes from this ancestor, an - instance of the same Exception class should be used. The difference - is only in Code property, which contains a kind of exception. } - protected - FCode: TError; - FErrorCode: DWORD; - FMessage: KOLString; - FExceptionRecord: PExceptionRecord; - FData: Pointer; - FOnDestroy: TDestroyException; - procedure SetData(const Value: Pointer); - public - constructor Create(ACode: TError; const Msg: string); - {* Use this constructor to raise exception, which does not require of - argument formatting. } - constructor CreateFmt(ACode: TError; const Msg: string; const Args: array of const); - {* Use this constructor to raise an exception with formatted Message string. - Take into attention, that Format procedure defined in KOL, uses API wvsprintf - function, which can understand a restricted set of format specifications. } - constructor CreateCustom(AError: DWORD; const Msg: String); - {* Use this constructor to create e_Custom exception and to assign AError to - its ErrorCode property. } - constructor CreateCustomFmt(AError: DWORD; const Msg: String; const Args: array of const); - {* Use this constructor to create e_Custom exception with formatted message - string and to assign AError to its ErrorCode property. } - constructor CreateResFmt(ACode: TError; Ident: Integer; const Args: array of const); - {* } - destructor Destroy; override; - {* destructor } - property Message: KOLString read FMessage; // write FMessage; - {* Text string, containing descriptive message about the exception. } - property Code: TError read FCode; - {* Main exception code. This property can be used to determine, which exception - occure. } - property ErrorCode: DWORD read FErrorCode write FErrorCode; - {* This code is to detailize error. For Code = e_InOut, ErrorCode contains - more detail description of input/output error. For e_Custom, You can - assign it to any value You want. } - property ExceptionRecord: PExceptionRecord read FExceptionRecord; - {* This property is only for e_External exception. } - property Data: Pointer read FData write SetData; - {* Custom defined pointer. Use it in your custom exceptions. } - property OnDestroy: TDestroyException read FOnDestroy write FOnDestroy; - {* This event is to allow to do something when custom Exception is - released. } - end; - {* - With err unit, it is possible to use all capabilities of Delphi exception - handling almost in the same way as usual. The difference only in that the - single exception class should be used. To determine which exception occure, - use property Code. So, code to handle exception can be written like follow: - ! try - ! ... - ! except on E: Exception do - ! case E.Code of - ! e_DivBy0: HandleDivideByZero; - ! e_Overflow: HandleOverflow; - ! ... - ! end; - ! end; - To raise an error, create an instance of Exception class object, but - pass a Code to its constructor: - ! var E: Exception; - ! ... - ! E := Exception.Create( e_Custom, 'My custom exception' ); - ! E.ErrorCode := MY_MAGIC_CODE_FOR_CUSTOM_EXCEPTION; - ! raise E; - } - - ExceptClass = class of Exception; - -{ Exit procedure handling } - -{ AddExitProc adds the given procedure to the run-time library's exit - procedure list. When an application terminates, its exit procedures are - executed in reverse order of definition, i.e. the last procedure passed - to AddExitProc is the first one to get executed upon termination. } - -procedure AddExitProc(Proc: TProcedure); - -{ System error messages } - -function SysErrorMessage(ErrorCode: Integer): string; - -{ Exception handling routines } - -function ExceptObject: TObject; -function ExceptAddr: Pointer; - -function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; - Buffer: PKOLChar; Size: Integer): Integer; - -procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); - -procedure Abort; - -//procedure OutOfMemoryError; - -{ RaiseLastWin32Error calls the GetLastError API to retrieve the code for } -{ the last occuring Win32 error. If GetLastError returns an error code, } -{ RaiseLastWin32Error then raises an exception with the error code and } -{ message associated with with error. } - -procedure RaiseLastWin32Error; - -{ Win32Check is used to check the return value of a Win32 API function } -{ which returns a BOOL to indicate success. If the Win32 API function } -{ returns False (indicating failure), Win32Check calls RaiseLastWin32Error } -{ to raise an exception. If the Win32 API function returns True, } -{ Win32Check returns True. } - -function Win32Check(RetVal: BOOL): BOOL; - -{ Termination procedure support } - -type - TTerminateProc = function: Boolean; - -{ Call AddTerminateProc to add a terminate procedure to the system list of } -{ termination procedures. Delphi will call all of the function in the } -{ termination procedure list before an application terminates. The user- } -{ defined TermProc function should return True if the application can } -{ safely terminate or False if the application cannot safely terminate. } -{ If one of the functions in the termination procedure list returns False, } -{ the application will not terminate. } - -procedure AddTerminateProc(TermProc: TTerminateProc); - -{ CallTerminateProcs is called by VCL when an application is about to } -{ terminate. It returns True only if all of the functions in the } -{ system's terminate procedure list return True. This function is } -{ intended only to be called by Delphi, and it should not be called } -{ directly. } - -function CallTerminateProcs: Boolean; - -{$IFNDEF _D2} -function GDAL: LongWord; -procedure RCS; -procedure RPR; -{$ENDIF} - - -{ SafeLoadLibrary calls LoadLibrary, disabling normal Win32 error message - popup dialogs if the requested file can't be loaded. SafeLoadLibrary also - preserves the current FPU control word (precision, exception masks) across - the LoadLibrary call (in case the DLL you're loading hammers the FPU control - word in its initialization, as many MS DLLs do)} - -{$IFNDEF _D2orD3} -function SafeLoadLibrary(const Filename: KOLString; - ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; -{$ENDIF} - -implementation - -{procedure ConvertError(const Ident: string); -begin - raise Exception.Create(e_Convert, Ident); -end; - -procedure ConvertErrorFmt(ResString: PResStringRec; const Args: array of const); -begin - raise Exception.CreateFmt(e_Convert, LoadResString(ResString), Args); -end;} - -{ Memory management routines } - -function AllocMem(Size: Cardinal): Pointer; -begin - GetMem(Result, Size); - FillChar(Result^, Size, 0); -end; - -{ Exit procedure handling } - -type - PExitProcInfo = ^TExitProcInfo; - TExitProcInfo = record - Next: PExitProcInfo; - SaveExit: Pointer; - Proc: TProcedure; - end; - -var - ExitProcList: PExitProcInfo = nil; - -procedure DoExitProc; -var - P: PExitProcInfo; - Proc: TProcedure; -begin - P := ExitProcList; - ExitProcList := P^.Next; - ExitProc := P^.SaveExit; - Proc := P^.Proc; - Dispose(P); - Proc; -end; - -procedure AddExitProc(Proc: TProcedure); -var - P: PExitProcInfo; -begin - New(P); - P^.Next := ExitProcList; - P^.SaveExit := ExitProc; - P^.Proc := Proc; - ExitProcList := P; - ExitProc := @DoExitProc; -end; - -{ System error messages } - -function SysErrorMessage(ErrorCode: Integer): string; -var - Len: Integer; - Buffer: array[0..255] of KOLChar; -begin - Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or - FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, - SizeOf(Buffer), nil); - while (Len > 0) and ((Buffer[Len - 1] <= ' ') or - (Buffer[Len - 1] = '.')) do Dec(Len); - SetString(Result, Buffer, Len); -end; - -{ Exception handling routines } - -{var - OutOfMemory: EOutOfMemory; - InvalidPointer: EInvalidPointer;} - -type - PRaiseFrame = ^TRaiseFrame; - TRaiseFrame = record - NextRaise: PRaiseFrame; - ExceptAddr: Pointer; - ExceptObject: TObject; - ExceptionRecord: PExceptionRecord; - end; - -{ Return current exception object } - -function ExceptObject: TObject; -begin - if RaiseList <> nil then - Result := PRaiseFrame(RaiseList)^.ExceptObject else - Result := nil; -end; - -{ Return current exception address } - -function ExceptAddr: Pointer; -begin - if RaiseList <> nil then - Result := PRaiseFrame(RaiseList)^.ExceptAddr else - Result := nil; -end; - -{ Convert physical address to logical address } - -function ConvertAddr(Address: Pointer): Pointer; assembler; -asm - TEST EAX,EAX { Always convert nil to nil } - JE @@1 - SUB EAX, $1000 { offset from code start; code start set by linker to $1000 } -@@1: -end; - -{ Format and return an exception error message } - -{$IFDEF _D2} // this code is luck in D2 system.pas -{type - PLibModule = ^TLibModule; - TLibModule = record - Next: PLibModule; - Instance: Longint; - ResInstance: Longint; - Reserved: Integer; - end;} - -function FindResourceHInstance(Instance: Longint): Longint; -begin - Result := Instance; -end; -{$ENDIF} - -type - PStrData = ^TStrData; - TStrData = record - Ident: Integer; - Buffer: PKOLChar; - BufSize: Integer; - nChars: Integer; - end; - -function EnumStringModules(Instance: Longint; Data: Pointer): Boolean; -begin - with PStrData(Data)^ do - begin - nChars := LoadString(Instance, Ident, Buffer, BufSize); - Result := nChars = 0; - end; -end; - -{$IFNDEF _D2} -function FindStringResource(Ident: Integer; Buffer: PKOLChar; BufSize: Integer): Integer; -var - StrData: TStrData; -begin - StrData.Ident := Ident; - StrData.Buffer := Buffer; - StrData.BufSize := BufSize; - StrData.nChars := 0; - EnumResourceModules(EnumStringModules, @StrData); - Result := StrData.nChars; -end; -{$ENDIF} - -{$IFDEF _D2} -function LoadStr(Ident: Integer): string; -var - Buffer: array[0..1023] of Char; -begin - SetString(Result, Buffer, LoadString(HInstance, Ident, Buffer, - SizeOf(Buffer))); -end; -{$ELSE} -function LoadStr(Ident: Integer): string; -var - Buffer: array[0..1023] of KOLChar; -begin - SetString(Result, Buffer, FindStringResource(Ident, Buffer, SizeOf(Buffer))); -end; -{$ENDIF} - -function FmtLoadStr(Ident: Integer; const Args: array of const): string; -begin - //FmtStr(Result, LoadStr(Ident), Args); - Result := Format(LoadStr(Ident), Args); -end; - -function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; - Buffer: PKOLChar; Size: Integer): Integer; -var - MsgPtr: PKOLChar; - //MsgEnd: PChar; - //MsgLen: Integer; - ModuleName: array[0..MAX_PATH] of KOLChar; - //Temp: array[0..MAX_PATH] of Char; - Fmt: array[0..255] of KOLChar; - Info: TMemoryBasicInformation; - ConvertedAddress: Pointer; -begin - VirtualQuery(ExceptAddr, Info, sizeof(Info)); - if (Info.State <> MEM_COMMIT) or - (GetModuleFilename( THandle(Info.AllocationBase), {Temp} ModuleName, - SizeOf({Temp} ModuleName)) = 0) then - begin - GetModuleFileName(HInstance, {Temp} ModuleName, SizeOf({Temp} ModuleName)); - ConvertedAddress := ConvertAddr(ExceptAddr); - end - else - Integer(ConvertedAddress) := Integer(ExceptAddr) - Integer(Info.AllocationBase); - //StrLCopy(ModuleName, AnsiStrRScan(Temp, '\') + 1, SizeOf(ModuleName) - 1); - {-} // Why to extract unit name from a path? Isn't it well to show complete path - // and to economy code for the extraction. - MsgPtr := ''; - //MsgEnd := ''; - if ExceptObject is Exception then - begin - MsgPtr := PKOLChar(Exception(ExceptObject).Message); - //MsgLen := StrLen(MsgPtr); - //if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.'; - {-} // Isn't it too beautiful - devote ~40 bytes of code just to decide, - // add or not a point at the end of the message. - end; - {$IFNDEF USE_RESOURCESTRING} - {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}( Fmt, SException ); - {$ELSE} - LoadString(FindResourceHInstance(HInstance), - PResStringRec(@SException).Identifier, Fmt, SizeOf(Fmt)); - {$ENDIF} - //MsgOK( ModuleName ); - {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF} - ( Buffer, PKOLChar( Format( Fmt, [ ExceptObject.ClassName, - ModuleName, ConvertedAddress, MsgPtr, '' {MsgEnd}]) ) ); - Result := {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}(Buffer); -end; - -{ Display exception message box } - -procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); -var - Buffer: array[0..1023] of KOLChar; -begin - ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, SizeOf(Buffer)); - {if IsConsole then - WriteLn(Buffer) - else} - begin - {LoadString(FindResourceHInstance(HInstance), PResStringRec(@SExceptTitle).Identifier, - Title, SizeOf(Title));} - MessageBox(0, Buffer, {Title} nil, MB_OK {or MB_ICONSTOP} or MB_SYSTEMMODAL); - end; -end; - -{ Raise abort exception } - -procedure Abort; - - function ReturnAddr: Pointer; - asm -// MOV EAX,[ESP + 4] !!! codegen dependant - MOV EAX,[EBP - 4] - end; - -begin - raise Exception.Create(e_Abort, SOperationAborted) at ReturnAddr; -end; - -{ Raise out of memory exception } - -{procedure OutOfMemoryError; -begin - raise OutOfMemory; -end;} - -{ Exception class } - -constructor Exception.CreateResFmt(ACode: TError; Ident: Integer; - const Args: array of const); -begin - FMessage := Format(LoadStr(Ident), Args); -end; - -destructor Exception.Destroy; -begin - if Assigned( FOnDestroy ) then - FOnDestroy( Self ); - inherited; -end; - -procedure Exception.SetData(const Value: Pointer); -begin - FData := Value; -end; - -constructor Exception.Create(ACode: TError; const Msg: string); -begin - FCode := ACode; - FMessage := Msg; - //FAllowFree := TRUE; -end; - -constructor Exception.CreateCustom(AError: DWORD; const Msg: String); -begin - FCode := e_Custom; - FMessage := Msg; - FErrorCode := AError; -end; - -constructor Exception.CreateCustomFmt(AError: DWORD; const Msg: String; - const Args: array of const); -begin - FCode := e_Custom; - FErrorCode := AError; - FMessage := Format(Msg, Args); -end; - -constructor Exception.CreateFmt(ACode: TError; const Msg: string; - const Args: array of const); -begin - FCode := ACode; - FMessage := Format(Msg, Args); -end; - -{ EHeapException class } - -{procedure EHeapException.FreeInstance; -begin - if AllowFree then - inherited FreeInstance; -end;} - -{ Create I/O exception } - -function CreateInOutError: Exception; -type - TErrorRec = record - Code: Integer; - Ident: string; - end; -const - ErrorMap: array[0..5] of TErrorRec = ( - (Code: 2; Ident: SFileNotFound), - (Code: 3; Ident: SInvalidFilename), - (Code: 4; Ident: STooManyOpenFiles), - (Code: 5; Ident: SAccessDenied), - (Code: 100; Ident: SEndOfFile), - (Code: 101; Ident: SDiskFull){, - (Code: 106; Ident: SInvalidInput)} ); -var - I: Integer; - InOutRes: Integer; -begin - I := Low(ErrorMap); - InOutRes := IOResult; // resets IOResult to zero - while (I <= High(ErrorMap)) and (ErrorMap[I].Code <> InOutRes) do Inc(I); - if I <= High(ErrorMap) then - Result := Exception.Create(e_InOut, ErrorMap[I].Ident) - else - Result := Exception.CreateFmt(e_InOut, SInOutError, [InOutRes]); - //Result := Exception.Create(e_InOut, SInOutError + Int2Str( InOutRes ) ); - Result.ErrorCode := InOutRes; -end; - -{ RTL error handler } - -type - TExceptMapRec = packed record - ECode: TError; - EIdent: String; - end; - -const - ExceptMap: array[1..24] of TExceptMapRec = ( - (ECode: e_OutOfMem; EIdent: SOutOfMemory), - (ECode: e_InvalidPointer; EIdent: SInvalidPointer), - (ECode: e_DivBy0; EIdent: SDivByZero), - (ECode: e_Range; EIdent: SRangeError), - (ECode: e_IntOverflow; EIdent: SIntOverflow), - (ECode: e_InvalidOp; EIdent: SInvalidOp), - (ECode: e_ZeroDivide; EIdent: SDivByZero), - (ECode: e_Overflow; EIdent: SOverflow), - (ECode: e_Underflow; EIdent: SUnderflow), - (ECode: e_InvalidCast; EIdent: SInvalidCast), - (ECode: e_AccessViolation;EIdent: SAccessViolation), - (ECode: e_Privilege; EIdent: SPrivilege), - (ECode: e_CtrlC; EIdent: SControlC), - // {-} Only for console applications - (ECode: e_StackOverflow; EIdent: SStackOverflow), - {$IFDEF VARIANT_USED} - (ECode: e_Variant; EIdent: SInvalidVarCast), - (ECode: e_Variant; EIdent: SInvalidVarOp), - (ECode: e_Variant; EIdent: SDispatchError), - (ECode: e_Variant; EIdent: SVarArrayCreate), - (ECode: e_Variant; EIdent: SVarNotArray), - (ECode: e_Variant; EIdent: SVarArrayBounds), - {$ELSE} - (ECode: e_Variant; EIdent: SVar), - (ECode: e_Variant; EIdent: SVar), - (ECode: e_Variant; EIdent: SVar), - (ECode: e_Variant; EIdent: SVar), - (ECode: e_Variant; EIdent: SVar), - (ECode: e_Variant; EIdent: SVar), - {$ENDIF} - (ECode: e_Assertion; EIdent: SAssertionFailed), - (ECode: e_External; EIdent: SExternalException), - (ECode: e_IntfCast; EIdent: SIntfCastError), - (ECode: e_SafeCall; EIdent: SSafecallException)); - -procedure ErrorHandler(ErrorCode: Integer; ErrorAddr: Pointer); -var - E: Exception; -begin - {case ErrorCode of - 1: E := OutOfMemory; - 2: E := InvalidPointer; - 3..24: with ExceptMap[ErrorCode] do E := EClass.Create(EIdent); - else - E := CreateInOutError; - end;} - - { + } - if ErrorCode <= 24 then - with ExceptMap[ErrorCode] do E := Exception.Create(ECode, EIdent) - else E := CreateInOutError; - { - } - - raise E at ErrorAddr; -end; - -{ Assertion error handler } - -{ This is complicated by the desire to make it look like the exception } -{ happened in the user routine, so the debugger can give a decent stack } -{ trace. To make that feasible, AssertErrorHandler calls a helper function } -{ to create the exception object, so that AssertErrorHandler itself does } -{ not need any temps. After the exception object is created, the asm } -{ routine RaiseAssertException sets up the registers just as if the user } -{ code itself had raised the exception. } - -function CreateAssertException(const Message, Filename: string; - LineNumber: Integer): Exception; -var - S: string; -begin - if Message <> '' then S := Message else S := SAssertionFailed; - Result := Exception.CreateFmt(e_Assertion, SAssertError, - [S, Filename, LineNumber]); -end; - -{ This code is based on the following assumptions: } -{ - Our direct caller (AssertErrorHandler) has an EBP frame } -{ - ErrorStack points to where the return address would be if the } -{ user program had called System.@RaiseExcept directly } -procedure RaiseAssertException(const E: Exception; const ErrorAddr, ErrorStack: Pointer); -asm - MOV ESP,ECX - MOV [ESP],EDX - MOV EBP,[EBP] - JMP System.@RaiseExcept -end; - -{ If you change this procedure, make sure it does not have any local variables } -{ or temps that need cleanup - they won't get cleaned up due to the way } -{ RaiseAssertException frame works. Also, it can not have an exception frame. } -procedure AssertErrorHandler(const Message, Filename: string; - LineNumber: Integer; ErrorAddr: Pointer); -var - E: Exception; -begin - E := CreateAssertException(Message, Filename, LineNumber); - RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+4); -end; - -{ Abstract method invoke error handler } - -procedure AbstractErrorHandler; -begin - raise Exception.Create(e_Abstract, SAbstractError); -end; - -{$IFDEF ASM_VERSION} -function MapException(P: PExceptionRecord): Byte; -asm //cmd //opd - MOV EAX, [EAX].TExceptionRecord.ExceptionCode - SUB EAX, $C0000000 - CMP EAX, $FD - JA @@code22 - - XOR ECX, ECX - MOV EDX, offset @@cvTable - 1 -@@loo: - INC EDX - MOV CL, [EDX] - JECXZ @@code22 - INC EDX - CMP AL, [EDX] - JNE @@loo - - MOV AL, CL - RET - -@@cvTable: - DB 3, $94 - DB 4, $8C - DB 5, $95 - DB 6, $8F, 6, $90, 6, $92 - DB 7, $8E - DB 8, $91 - DB 9, $8D, 9, $93 - DB 11, $05 - DB 12, $96 - DB 14, $FD - DB 0 - -@@code22: - MOV AL, 22 -end; -{$ELSE} //Pascal -function MapException(P: PExceptionRecord): Byte; -begin - case P.ExceptionCode of - STATUS_INTEGER_DIVIDE_BY_ZERO: - Result := 3; - STATUS_ARRAY_BOUNDS_EXCEEDED: - Result := 4; - STATUS_INTEGER_OVERFLOW: - Result := 5; - STATUS_FLOAT_INEXACT_RESULT, - STATUS_FLOAT_INVALID_OPERATION, - STATUS_FLOAT_STACK_CHECK: - Result := 6; - STATUS_FLOAT_DIVIDE_BY_ZERO: - Result := 7; - STATUS_FLOAT_OVERFLOW: - Result := 8; - STATUS_FLOAT_UNDERFLOW, - STATUS_FLOAT_DENORMAL_OPERAND: - Result := 9; - STATUS_ACCESS_VIOLATION: - Result := 11; - STATUS_PRIVILEGED_INSTRUCTION: - Result := 12; - STATUS_CONTROL_C_EXIT: - Result := 13; - STATUS_STACK_OVERFLOW: - Result := 14; - else - Result := 22; { must match System.reExternalException } - end; -end; -{$ENDIF} - -function GetExceptionClass(P: PExceptionRecord): ExceptClass; -//var ErrorCode: Byte; -begin - //ErrorCode := MapException(P); - Result := Exception; {ExceptMap[ErrorCode].EClass;} -end; - -function GetExceptionObject(P: PExceptionRecord): Exception; -var - ErrorCode: Integer; - - function CreateAVObject: Exception; - var - AccessOp: string; // string ID indicating the access type READ or WRITE - AccessAddress: Pointer; - MemInfo: TMemoryBasicInformation; - ModName: array[0..MAX_PATH] of KOLChar; - begin - with P^ do - begin - if ExceptionInformation[0] = 0 then - AccessOp := SReadAccess else - AccessOp := SWriteAccess; - AccessAddress := Pointer(ExceptionInformation[1]); - VirtualQuery(ExceptionAddress, MemInfo, SizeOf(MemInfo)); - if (MemInfo.State = MEM_COMMIT) and (GetModuleFileName(THandle(MemInfo.AllocationBase), - ModName, SizeOf(ModName)) <> 0) then - Result := Exception.CreateFmt(e_AccessViolation, sModuleAccessViolation, - [ExceptionAddress, ExtractFileName(ModName), AccessOp, - AccessAddress]) - else Result := Exception.CreateFmt(e_AccessViolation, sAccessViolation, - [ExceptionAddress, AccessOp, AccessAddress]); - end; - end; - -begin - ErrorCode := MapException(P); - case ErrorCode of - 3..10, 12..21: - with ExceptMap[ErrorCode] do Result := Exception.Create(ECode, EIdent); - 11: Result := CreateAVObject; - else - begin - Result := Exception.CreateFmt(e_External, SExternalException, [P.ExceptionCode]); - //Result.FExceptionRecord := P; - end; - end; - Result.FExceptionRecord := P; -end; - -{ RTL exception handler } - -procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); far; -begin - ShowException(ExceptObject, ExceptAddr); - Halt(1); -end; - -{+} -function InitAssertErrorProc: Boolean; -begin - AssertErrorProc := @AssertErrorHandler; - Result := TRUE; -end; -{-} - -procedure InitExceptions; -begin - {OutOfMemory := EOutOfMemory.Create(SOutOfMemory); - InvalidPointer := EInvalidPointer.Create(SInvalidPointer);} - ErrorProc := @ErrorHandler; - ExceptProc := @ExceptHandler; - ExceptionClass := Exception; - - ExceptClsProc := @GetExceptionClass; - - ExceptObjProc := @GetExceptionObject; - - {AssertErrorProc := @AssertErrorHandler;} - {+} // Initialize Assert only when "Assertions" option is turned on in Compiler: - Assert( InitAssertErrorProc, '' ); - {-} - - //AbstractErrorProc := @AbstractErrorHandler; - // {-} KOL does not use classes, so EAbstractError should never be raised. - -end; - -procedure DoneExceptions; -begin - {OutOfMemory.AllowFree := True; - OutOfMemory.FreeInstance; - OutOfMemory := nil; - InvalidPointer.AllowFree := True; - InvalidPointer.Free; - InvalidPointer := nil;} - ErrorProc := nil; - ExceptProc := nil; - ExceptionClass := nil; - //ExceptClsProc := nil; --see InitExceptions - ExceptObjProc := nil; - AssertErrorProc := nil; -end; - -{ RaiseLastWin32Error } - -procedure RaiseLastWin32Error; -var - LastError: DWORD; - Error: Exception; -begin - LastError := GetLastError; - if LastError <> ERROR_SUCCESS then - Error := Exception.CreateFmt(e_Win32, SWin32Error, [LastError, - SysErrorMessage(LastError)]) - else - Error := Exception.Create(e_Win32, SUnkWin32Error ); - Error.ErrorCode := LastError; - raise Error; -end; - -{ Win32Check } - -function Win32Check(RetVal: BOOL): BOOL; -begin - if not RetVal then RaiseLastWin32Error; - Result := RetVal; -end; - -type - PTerminateProcInfo = ^TTerminateProcInfo; - TTerminateProcInfo = record - Next: PTerminateProcInfo; - Proc: TTerminateProc; - end; - -var - TerminateProcList: PTerminateProcInfo = nil; - -procedure AddTerminateProc(TermProc: TTerminateProc); -var - P: PTerminateProcInfo; -begin - New(P); - P^.Next := TerminateProcList; - P^.Proc := TermProc; - TerminateProcList := P; -end; - -function CallTerminateProcs: Boolean; -var - PI: PTerminateProcInfo; -begin - Result := True; - PI := TerminateProcList; - while Result and (PI <> nil) do - begin - Result := PI^.Proc; - PI := PI^.Next; - end; -end; - -procedure FreeTerminateProcs; -var - PI: PTerminateProcInfo; -begin - while TerminateProcList <> nil do - begin - PI := TerminateProcList; - TerminateProcList := PI^.Next; - Dispose(PI); - end; -end; - -{ --- } - -function AL1(const P): LongWord; -asm - MOV EDX,DWORD PTR [P] - XOR EDX,DWORD PTR [P+4] - XOR EDX,DWORD PTR [P+8] - XOR EDX,DWORD PTR [P+12] - MOV EAX,EDX -end; - -function AL2(const P): LongWord; -asm - MOV EDX,DWORD PTR [P] - ROR EDX,5 - XOR EDX,DWORD PTR [P+4] - ROR EDX,5 - XOR EDX,DWORD PTR [P+8] - ROR EDX,5 - XOR EDX,DWORD PTR [P+12] - MOV EAX,EDX -end; - -const - AL1s: array[0..2] of LongWord = ($FFFFFFF0, $FFFFEBF0, 0); - AL2s: array[0..2] of LongWord = ($42C3ECEF, $20F7AEB6, $D1C2F74E); - -procedure ALV; -begin - raise Exception.Create(e_License, SNL); -end; - -{$IFNDEF _D2} -function ALR: Pointer; -var - LibModule: PLibModule; -begin - if MainInstance <> 0 then - Result := Pointer(LoadResource(MainInstance, FindResource(MainInstance, 'DVCLAL', - PKOLChar( RT_RCDATA )))) - else - begin - Result := nil; - LibModule := LibModuleList; - while LibModule <> nil do - begin - with LibModule^ do - begin - Result := Pointer(LoadResource(Instance, FindResource(Instance, 'DVCLAL', - PKOLChar( RT_RCDATA )))); - if Result <> nil then Break; - end; - LibModule := LibModule.Next; - end; - end; - if Result = nil then ALV; -end; - -function GDAL: LongWord; -type - TDVCLAL = array[0..3] of LongWord; - PDVCLAL = ^TDVCLAL; -var - P: Pointer; - A1, A2: LongWord; - PAL1s, PAL2s: PDVCLAL; - ALOK: Boolean; -begin - P := ALR; - A1 := AL1(P^); - A2 := AL2(P^); - Result := A1; - PAL1s := @AL1s; - PAL2s := @AL2s; - ALOK := ((A1 = PAL1s[0]) and (A2 = PAL2s[0])) or - ((A1 = PAL1s[1]) and (A2 = PAL2s[1])) or - ((A1 = PAL1s[2]) and (A2 = PAL2s[2])); - FreeResource(Integer(P)); - if not ALOK then ALV; -end; - -procedure RCS; -var - P: Pointer; - ALOK: Boolean; -begin - P := ALR; - ALOK := (AL1(P^) = AL1s[2]) and (AL2(P^) = AL2s[2]); - FreeResource(Integer(P)); - if not ALOK then ALV; -end; - -procedure RPR; -var - AL: LongWord; -begin - AL := GDAL; - if (AL <> AL1s[1]) and (AL <> AL1s[2]) then ALV; -end; -{$ENDIF} - -{$IFNDEF _D2orD3} -function SafeLoadLibrary(const Filename: KOLString; ErrorMode: UINT): HMODULE; -var - OldMode: UINT; - FPUControlWord: Word; -begin - OldMode := SetErrorMode(ErrorMode); - try - asm - FNSTCW FPUControlWord - end; - try - Result := LoadLibrary(PKOLChar(Filename)); - finally - asm - FNCLEX - FLDCW FPUControlWord - end; - end; - finally - SetErrorMode(OldMode); - end; -end; -{$ENDIF} - -{procedure Exception.FreeInstance; -begin - if FAllowFree then - inherited; -end;} - - - -initialization - InitExceptions; - -finalization - FreeTerminateProcs; - DoneExceptions; - -end. - diff --git a/plugins/ImportTXT/kol/kol.pas b/plugins/ImportTXT/kol/kol.pas deleted file mode 100644 index 0a1e74283f..0000000000 --- a/plugins/ImportTXT/kol/kol.pas +++ /dev/null @@ -1,61852 +0,0 @@ -//[START OF KOL.pas] -{**************************************************************** - - KKKKK KKKKK OOOOOOOOO LLLLL - KKKKK KKKKK OOOOOOOOOOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKKKKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL - KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL - - Key Objects Library (C) 2000 by Vladimir Kladov. - -**************************************************************** -* VERSION 3.18 -**************************************************************** - - K.O.L. - is a set of objects and functions to create small programs - with the Delphi, but without the VCL/CLX. KOL allows to create - executables of size about 10 times smaller. But this does not mean that - KOL is less power then the VCL - perhaps just the opposite... - - KOL is provided free with the source code. - Copyright (C) Vladimir Kladov, 2000-2011. - - For code provided by other developers (even if later - changed by me) authors are noted in the source. - - mailto: vk@kolmck.net - Web-Page: http://kolmck.net - - See also Mirror Classes Kit (M.C.K.) which allows - to create KOL programs visually. - -****************************************************************} - -{$I KOLDEF.inc} - -{$IFDEF x64} - {$DEFINE PAS_ONLY} -{$ENDIF} -{$IFDEF PAS_ONLY} - {$DEFINE PAS_VERSION} -{$ENDIF} - -{$IFDEF EXTERNAL_KOLDEFS} - {$INCLUDE PROJECT_KOL_DEFS.INC} -{$ENDIF} -{$IFDEF EXTERNAL_DEFINES} - {$INCLUDE EXTERNAL_DEFINES.INC} -{$ENDIF EXTERNAL_DEFINES} - - {$DEFINE GDI} - -{$UNDEF LIN} {$UNDEF WIN} {$UNDEF GDI} -{$IFDEF LINUX} - {$DEFINE UNIX} - {$DEFINE LIN} - {$DEFINE PAS_VERSION} - {$DEFINE NOT_USE_RICHEDIT} - {$IFNDEF GTK} - {$IFNDEF XQT} - {$DEFINE GTK} // it is also possible to define GTK as a project option - {$ENDIF XQT} // even for Windows system - {$ENDIF GTK} -{$ELSE} // to exploit GTK under Win32 rather then native GDI - {$DEFINE WIN} - {$DEFINE GDI} -{$ENDIF} - - {$IFDEF GTK} {$UNDEF GDI} {$DEFINE _X_} - {$DEFINE NOT_USE_RICHEDIT} - {$ENDIF} -//{$IFDEF Q_T} {$UNDEF GDI} {$DEFINE _X_} {$ENDIF} - -{$IFDEF WIN} {$IFDEF GDI} - {$DEFINE WIN_GDI} -{$ENDIF GDI} {$ENDIF WIN} - -{$INCLUDE delphidef.inc} - -{$IFDEF WIN_GDI} - //test -{$ENDIF WIN_GDI} -{$IFDEF LIN} - //test -{$ENDIF LIN} - -unit KOL; -{* - Please note, that KOL does not use keyword 'class'. Instead, - poor Pascal 'object' is the base of our objects. So, remember, - how we worked earlier with such Object Pascal's objects: -|
- - to create objects dynamically, use P instead of - T to allocate a pointer for dynamically created - object instance; -|
- - remember, that constructors of objects can not be virtual. - Override procedure Init instead in your own derived objects; -|
- - rather then call constructors of objects, call global procedures - New (e.g. NewLabel). If not, first (for virtualally - created objects) call New( ); then call constructor Create - (which calls Init) - but this is possible only if the constructor - is overriden by a new one. -|
- - the operator 'is' is not applicable to objects. And operator 'as' - is not necessary (and is not applicable too), use typecast to desired - object type, e.g.: "PSomeObjectType( C )" inplace of "C as TSomeClassType". -|
-|

- Also remember, that IF [ MyObj: PMyObj ] THEN - - NOT[ with MyObj do ] BUT[ with MyObj^ do ] - - Though it is possible to skip '^' symbol when accessing member - fields, methods, properties, e.g. [ MyObj.Execute; ] -|
-|&U=   %0
-|&B=%0
-|&C=%0 -| -| -| -| -| -| -| -|
objects functions by category
- - - - - - - - - - - -| -| - Visual objects constructing functions -|

- - - - - - - - - - - - -|
- - Following conditional symbols can be used in a project - (Project | Options | Directories/Conditional Defines) - to change code generated a bit. There are following: -|
-
-  EXTERNAL_KOLDEFS      - since there are a lot of such symbols, it may be not
-                          possible to include all the desired optional symbols
-                          in the Project Options (Delphi has a restriction to 256
-                          characters in a semicolon-separated list of included
-                          options). This symbol allows to exceed this restriction:
-                          you place your defines in an included file
-                          EXTERNAL_DEFINES.INC, located in your project directory.
-                          Since this is a normal pascal source, use usual Pascal
-                          syntax:  add a directive (*$DEFINE symbol*) for each
-                          symbol you want, and you can decorate it with usual
-                          comments if necessary.
-  ENABLE_DEPRECATED     - some old declaration made "deprecated" and moved to
-                          KOL_deprecated.inc. This symbol provides including
-                          such declarations into KOL.pas and makes it available
-                          again.
-  DISABLE_DEPRECATED    - (default) - disables deprecated declaration.
-  WIN                   - (default) - version for Windows.
-  LINUX                 - version for Linux (only PAS_VERSION) -- not yet ready
-                          When not defined, symbol WIN is defined automatically.
-  LINUX_USE_HOME_STARTFDIR - in Linux app, HOME directory of the user will be
-                          returned by GetStartDir function.
-  GTK                   - version for GTK (Linux or Win32) -- not yet ready
-  XQT                   - version for QT (Linux or Win32) -- not yet ready
-  FPC                   - Free Pascal version. KOL can be used with such compiler
-                          to create Win32 applications. To create Win-CE
-                          applications (with FPC compiler)), use the separate
-                          version of KOL specially designed for it.
-  INPACKAGE             - version for Mirror Classes Library package (design-time
-                          only). This option should be included only in MCK package
-                          options and never in options of the KOL/MCK application.
-  PAS_VERSION           - to use Pascal version of the code.
-  PARANOIA              - to force short versions of asm instructions (for D5
-                          and below, D6 and higher use those instructions always).
-  USE_CMOV              - force using CMOV machine instruction in asm code (not
-                          recommended, still on some machines your application
-                          will not work).
-  SMALLEST_CODE         - to create minimal code application (affected:
-                          (o) SimpleGetCtlBrushHandle - returns solid silver brush
-                              always;
-                          (o) _NewWindowed
-                              - only default system font used by default;
-                              font of the parent control is not applied to its
-                              children automatically (but see SMALLEST_CODE_PARENTFONT);
-                              - fBrush always set to NIL by default (parent Brush
-                              is not applied);
-                          (o) WndProcDoEraseBkgnd
-                              - child controls windows are not created in WM_ERASEBKGND
-                              if were not created earlier (in most case, all OK
-                              with this - controls are created BTW);
-                              - SetBkColor, SetBkMode, SetBrushOrgEx are not
-                              called (all OK therefore)
-                          (o) by default, NOT_UNLOAD_RICHEDITLIB is defined if
-                              UNLOAD_RICHEDITLIB is not defined in project options
-                              (this minimizes finalization section).
-                          (o) _NewControl
-                              - BoundsRect initialized with a rectangle
-                                (aParent.fMarginLeft, aParent.fMarginTop,
-                                 aParent.fMarginLeft+64, aParent.fMargin+64)
-                                rather then with (aParent.fMargin+aParent.fMarginLeft,
-                                aParent.fMargin+aParent.fMarginTop,
-                                aParent.fMargin+aParent.fMarginLeft+64,
-                                aParent.fMargin+aParent.fMarginTop+64).
-                                In most cases this is enough.
-                          (o) Int2Hex
-                              there are no check for second perameter > 15
-                          (o) .... other see in code
-  SMALLER_CODE          - like smallest code, but fuctionality is the same.
-                          The speed can be lower therefore.
-  SMALLEST_CODE_PARENTFONT - Parent font therefore is applied for child controls,
-                             but initially only.
-  SPEED_FASTER          - by default (but off when SMALLEST_CODE on) - sorting of
-                          TStrList.AnsiSort and comparing using AnsiCompareStrA,
-                          AnsiCompareStrNoCaseA is much faster (about 5-6 times).
-                          Also, sorting of lists and strlists is redircted to
-                          SortArray which is faster about 5-15% (vs SortData).
-                          To turn off, add a symbol SPEED_NORMAL.
-  REGKEYGETSTREX_ALWAYS - If you use already RegKeyGetStrEx, add this option to
-                          redirect RegKeyGetStr to it.
-  NOT_USE_KOLMATH       - Only for _X_ (GTK + Linux): to prevent referencing
-                          KOLmath in uses. This makes method TCanvas.Arc
-                          unavailable, but the application become smaller.
-  NOT_USE_EXCEPTIONS    - to prevent referencing unit ERR.PAS in uses even when
-                          KOLmath is listed there.
-  REDEFINE_ABS          - usual Abs works as a macro which is better in most
-                          cases. But who knows...
-  CUSTOM_APPICON        - when this option is defined, the resource name for the
-                          application icon is extracted from a file
-                          CusomAppIconRsrcName_PAS.inc (place it in your project
-                          folder and type there name of the recource in qutations).
-                          By default, string 'MAIN' is used like in usual Delphi
-                          application.
-  USE_NAMES             - to use property Name with any TObj. This makes also
-                          available method TObj.FindObj( name ): PObj.
-  UNIQUE_NAMES          - provide Name property to be unique among all siblings.
-  USE_MHTOOLTIP         - to use KOLMHTOOLTIP.pas (actually it is not a separate
-                          unit but a set of portions of code included into KOL.pas
-                          in different places). This unit provides tooltips (hints)
-                          for arbitrary controls which appear when mouse is over
-                          such controls.
-  USE_GRUSH             - to use ToGRush.pas unit, which provides automatic
-                          redirection of the most cintrols creation functions
-                          to the KOLGRushControls.pas.
-  (USE_CONSTRUCTORS     - to use constructors like in VCL. Note: this option is
-                          not carefully tested!)
-  TLIST_FAST            - very fast implementation of TList (for coast of some
-                          additional code).
-  DFLT_TLIST_NOUSE_BLOCKS - for TLIST_FAST: by default, do not make all TList
-                          objects using new (fast) algoritms, but only those of
-                          TList objects, which property UseBlocks was set to
-                          TRUE after creating it.
-  STREAM_LARGE64        - turns on support of streams (and files) of size larger
-                          then 4 Gbytes. Data type Int64 used for parameters of
-                          the most of methods and functions in such case. (Note:
-                          Int64 was introduced since Delphi5, so in earlier Delphi
-                          versions using this symbol is not possible).
-  STREAM_COMPAT         - still STREAM_LARGE64 appeared (in v2.84), most of
-                          methods and functions declarations became incompatible
-                          with earlier created extensions. This symbol provides
-                          compatibility for such extensions, but it desables
-                          using large streams.
-  OLD_STREAM_CAPACITY   - to use elder TStream.SetCapacity algorithm (it did not
-                          make Capacity smaller than already achieved, but in
-                          newer version, Capacity can be set to a smaller value,
-                          and for memory streams, rest of memory is freeing in
-                          such case).
-  OLD_MEMSTREAMS_SETSIZE - to use elder TStream.SetSize for memory streams. In
-                          a new version, setting new size also changes Capacity
-                          to the same value (in earlier case, a value for
-                          Capacity property was calculated to become a bit
-                          greater then a value set for Size property).
-  OLD_COMPAT            - to use symbol ';' as a file list separator (all operations
-                          using DoFileOp function such as DeleteFile2Recycle and
-                          CopyMoveFiles).
-  OLD_REGKEYGETSUBKEYS  - to use elder version of RegKeyGetSubKeys functions
-                          (new version is faster).
-  OLD_REGKEYGETVALUENAMES - to use elder version of RegKeyGetValueNames
-                          (newer version is faster).
-  USE_CUSTOMEXTENSIONS  - to extend TControl with custom additions.
-  DATE0_0001            - to correct correctly TDateTime to TSystemTime and vice
-                          versa even for dates earlier then 1-Jan-1601.
-  UNICODE_CTRLS         - to use Unicode versions of controls (WM_XXXXW messages,
-                          etc.)
-  SAFE_CODE             - use more safe code in some algorithms (but more slowly
-                          and taking more code a bit).
-  USE_OnIdle            - to use OnIdle event
-  SNAPMOUSE2DFLTBTN     - for all MessageBox-based functions, snap mouse to
-                          default button is provided if such option is on in
-                          mouse driver settings.
-  BUTTON_DBLCLICK       - to prevent clicking buttons with double click (separate
-                          event OnMouseDblClk is fired in such case), this takes
-                          smaller code but buttons can not be pressed with mouse
-                          fast. When SMALLEST_CODE on, this option also is on.
-  ALL_BUTTONS_RESPOND_TO_ENTER - obvious (by default, buttons respond to key
-                        SPACE, since those are working this way in Windows).
-  CLICK_DEFAULT_CANCEL_BTN_DIRECTLY - to prevent visual effect of default/cancel
-                             button pressing with Enter/Escape keys. Also, button
-                             don't become focused in such case.
-  DEFAULT_CANCEL_BTN_EXCLUSIVE - to disable assigning to a button properties
-                             DefaultBtn and CancelBtn simultaneously.
-  NO_DEFAULT_BUTTON_BOLD - to prevent DefaultBtn to be visually with
-                             a bold border.
-  BITBTN_DISABLEDGLYPH2 - to restore old behaviour of multi-glyph bitbtn, when
-                          index 2 was used to represent the button in disabled
-                          state, and glyph with index 1 was used forpressed dtate.
-                          Now by default index 1 corresponds to the disabled state,
-                          and index 2 to the pressed state, i.e. these are swapped.
-  ESC_CLOSE_DIALOGS     - to allow closing all dialogs with ESCAPE.
-  KEY_PREVIEW           - form also receive WM_KEYDOWN (OnKeyDown event fired)
-  SUPPORT_ONDEADCHAR    - to support OnKeyDeadChar event in responce to
-                          WM_DEADCHAR, WM_SYSDEADCHAR
-  OpenSaveDialog_Extended - to allow using custom extensions for OpenSaveDialog.
-  AUTO_CONTEXT_HELP     - to use automatic respond to WM_CONTEXTMENU to call
-                        context help.
-  NOT_FIX_CURINDEX      - to use old version of TControl.SetItems, which could
-                        lead to loose CurIndex value (e.g. for Combobox)
-  NOT_FIX_MODAL         - not to fix modal (if fixed, click on any window
-                          activates the application. If not fixed, code is
-                          smaller very a little, but only click on modal form
-                          activates the application). This does not fix calling
-                          MsgBox though.
-  MODAL_ACTIVATE_FIX    - if this option is set, all the windows of clicked app
-                          with active modal form are brought to foreground, not
-                          only modal form itself. This option is not necessary if
-                          only two forms are visible at a time (the main form and
-                          the active modal form).
-  NEW_MODAL             - to use extended modalness.
-  USE_SETMODALRESULT    - to guarantee ModalResult property assigning handling.
-  USE_SHOWMODALPARENTED_ALWAYS - to use TControl.ShowModalParented( Applet )
-                          instead of TControl.ShowModal always.
-  USE_MENU_CURCTL       - to use CurCtl property in popup menu to detect which
-                        control initiated a pop-up.
-  NEW_MENU_ACCELL       - to use new menu accelerators handling, without
-                        AcceleratorTable (not tested for all cases)
-  USE_DROPDOWNCOUNT     - to force setting combobox dropdown count.
-  NOT_UNLOAD_RICHEDITLIB - to stop unload Rich Edit library in finalization
-                        section (to economy several byte of code).
-  NOT_USE_RICHEDIT      - not use richedit (it will not be possible to create richedit)
-  TV_DRAG_RBUTTON       - to allow dragging tree view items with right mouse
-                          button too.
-  TOOLBAR_FORCE_CHILDALIGN - this option provides Align working for child
-                          controls of the toolbar control, but when with this option
-                          is turned on it is impossible to have neighbour controls
-                          on a form correctly aligned. This last disadvantage is
-                          not important if a toolbar is always placed on a separate
-                          panel-like control as a child.
-                          Note: this option has no effect for Win9x, still use of
-                          it under Win9x can crash the application!!!
-  TOOLBAR_DOT_NOAUTOSIZE_BUTTON - this option forces prefix dot character in
-                          button caption to be treated as an instruction to
-                          remove TBSTYLE_AUTOSIZE from the button style. Actually,
-                          this feature not necessary still custom button size can
-                          be set even if such style is on for a button.
-  CANRESIZE_THICKFRAME  - to use elder version of CanResize, changing border
-                          style of the window (this cause incorrect form view in
-                          Vista Aero theme (due a bug in Vista?)).
-  ANCHORS_WM_SIZE       - to check WM_SIZE message in Anchor handling window
-                          procedure. By default, now used WM_WINDOWPOSCHANGED.   
-  USE_PROP              - to use GetProp / SetProp (old style) in place of
-                          Get / SetWindowLong( wnd, GWL_USERDATA... ) (slower?)
-
-  PROVIDE_EXITCODE      - PostQuitMessage( value ) assigns value to ExitCode
-  INITIALFORMSIZE_FIXMENU - form size initially is really the same as defined at
-                          design time even for forms having main menu bar
-  USE_GRAPHCTLS         - to use graphic (non-windowed) controls
-  RICHEDIT_XPBORDER     - provide correct drawing rich edit control border with
-                          XP themes.
-  GRAPHCTL_XPSTYLES     - to use XP themed Visual styles for drawing graphic
-                          controls. This does not affect windowed controls
-                          which visual style is controlled by the manifest.
-                          This option also turns on RICHEDIT_XPBORDER option.
-  GRAPHCTL_HOTTRACK     - to use hot-tracking also together with XP themed
-                          graphic controls (otherwise only static XP themed
-                          view is provided). Also, turn this option on if you
-                          want to handle OnMouseEnter and OnMouseLeabe events
-                          for graphic controls.
-  NEW_OPEN_DIR_STYLE_EX - to use new code for TOpenDirDialog, which provides
-                          correct working of the dialog with an option
-                          odNewDialogStyle set (even in Windows 9x system).
-  HTMLHELP_NOTOP        - when Html help is called, its window become a child of
-                          the desktop, not application (in such case it is not
-                          closed together with the application, and it is apper
-                          not on top of the application).
-  ICON_DIFF_WH          - to support icons having Width <> Height
-  ICONLOAD_PRESERVEBMPS - when an icon is loaded, its bitmap and mask are
-                          extracted and in case when such symbol is defined,
-                          these one or two bitmaps are preserved until TIcon
-                          object is destroyed.
-  LOADEX                - to use TBitmap.LoadFromStreamEx while loading icon
-                          from a stream or a file.
-  USE_OLDCONVERT2MASK   - to use elder Convert2Mask method (newer is more correct).
-  FIX_TRANSPBMPPALETTE  - for TBitmap.StretchDrawMasked, bitmaps with PixelFormat
-                          = pf4bit or pf8bit are first converted (in a temporary
-                          TBitmap object) to pf32bit, and then are drawn. This
-                          fixes problems with palette usage for such DIB bitmaps.
-  FILL_BROKEN_BITMAP    - TBitmap.LoadFromStreamEx: broken bitmaps rest of
-                          scanlines are be filled with zeroes (usually black color)
-                          rather then left containing trash memory bits.
-  AUTO_REPLACE_CLEARTYPE- to replace automatically CLEARTYPE_QUALITY fonts
-                          with ANTIALIASED_QUALITY when running under elder
-                          Windows version than XP.
-  FORCE_ALTERNATEFILENAME- TDirList.ScanDirectoryFORCE_ALTERNATEFILENAME - forced
-                          using an alternate file path and filename for unicode
-                          paths (принудительное использование альтернативного имени
-                          пути и имени файла для юникод путей)
-
-  NEW_GRADIENT - to use new gradient painting by homm (fast).
-  OLD_ALIGN    - to prevent using new Align by Galkov.
-  NEW_ALIGN    - (default) - to use new Align implementation (faster).
-  OLD_TRANSPARENT       - to prevent using NEW_TRANSPARENT
-  NEW_TRANSPARENT       - created by Alexander Karpinsky a.k.a. homm (faster)
-  SBOX_OLDPOS           - to use elder formulas to calculate scroll box positions
-                          (just for compatibility with very old apps using it).
-  OLD_REFCOUNT          - to prevent using new RefInc / RefDec behaviour
-                          (new style of using RefCount works better).
-  OLD_FREE              - to declare Free as a method as in earlier versions of KOL.
-                          In new versions, Free is declared as a property, and
-                          "calling" it just redirects call to RefDec. OLD_FREE
-                          can be used for compatibility with compilers not
-                          understanding "calling" a property without assigning
-                          something to or from it (Turbo Delphi?).
-  SCROLL_OLD            - for compatibility with the old applications using
-                          TScrollBar: there was another method of adjusting
-                          SBMax and SBPageSize: SBMax should be corrected to
-                          (nMaxItems-1-SBPageSize).
-  FILE_EXISTS_EX - to use more correct (but a bit large code in FileExists functon)
-  USE_AUTOFREE4CONTROLS - (default) - from 2.40, most of control sub-objects are
-                          destroying using Add2AutoFree (smaller code).
-  NOT_USE_AUTOFREE4CONTROLS - this option returns to previous behaviour (just to
-                          compare code size). Will be deprecated in future.
-                          Ignored when UNION_FIELDS is used (by default)
-  ENDSESSION_HALT - to halt the process when WM_ENDSESSION comes.
-  FILESTREAM_POSITION   - in PAS_VERSION, Stream..fData.fPosition always show
-                          current position (for debug purposes)
-  PSEUDO_THREADS        - to use pseudo-threads instead of normal threads.
-  WAIT_SLEEP            - for PSEUDO_THREADS: sleep 10 ms in a
-                          WaitForMultipleObjects loop.
-  ENUM_DYN_HANDLERS_AFTER_RUN - to allow all the events handling even when
-                        AppletTerminated become TRUE.
-  STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED - use this long-named otpion to
-                          prevent any functionality of WndProcTransparent after
-                          AppletTerminated is set to true.
-  STOPTIMER_AFTER_APPLETTERMINATED - use this symbol to prevent timer event
-                          firing after setting AppletTerminated to TRUE.
-  TIMER_APPLETWND       - to use Applet window to handle WM_TIMER events
-                          (otherwise special single invisible window is created
-                          to handle such events).
-  SUPPORT_LONG_TIMER    - LINUX only: set this option if TTimer.Interval can be
-                          set to a value greater then 1,800,000 (30 minutes).
-  DEBUG_MENU            - to debug menu.
-  DEBUG_GDIOBJECTS      - to allow counting all the GDI objects used.
-  CHK_BITBLT            - to check BitBlt operations.
-  DEBUG_ENDSESSION      - to allow debugging WM_ENDSESSION handling.
-  DEBUG_CREATEWINDOW    - to debug CreateWindow.
-  CRASH_DEBUG           - to fill object memory with $DD before freeing it
-                          (program really crashes when the object is
-                          attempted to destroy more then once and in most
-                          cases when a destroyed object is accessed after the
-                          destruction).
-  DEBUG_MCK             - specially designed to debug Mirror Classes Kit.
-  DEBUG_OBJKIND         - for each TControl object kind a reference to PChar
-                          with object kind name is stored in the structure of
-                          the object (field fObjKind).
-  DEBUG                 - other debugging.
-  EXTERNAL_DEFINES      - if count of options necessary to set is very large
-                          Delphi ignores past of those. To avoid this problem,
-                          set only this option in Project's options, and place
-                          all other options to ExternalDefines.inc file as a
-                          sequence of {$DEFINE ... directives.
-                          But note, such file should be located in a
-                          project directory, but not in the directory where KOL.pas
-                          is located. This is enough to provide different sets
-                          of defines for each project.
-  ---- from version 3.00, following symbols are added:
-  USE_FLAGS             - to compress boolean flags used (about 6 bytes instead
-                          more then 50 flags occupying earlies 1 byte for each
-                          flag). This option is turned on by default. To turn off,
-                          define a symbol USE_OLD_FLAGS !
-  EVENTS_DYNAMIC        - to create events record (about 600 bytes) only for
-                          controls having assigned events. To turn off, define a
-                          symbol EVENTS_STATIC.
-  NIL_EVENTS            - by default, is off. This option returns back again checking
-                          TControl's events if it is assigned before calling. By
-                          default, now this option is off, all events are assigned
-                          to dummy event handlers at create, so checking if the handler
-                          is assigned is not necessary. But it is not allowed to
-                          assign NIL to the event, instead call ResetEvent method
-                          with the correspondent index (e.g. idx_fOnMessage).
-  COMMANDACTIONS_OBJ    - to store command actions certain for different control
-                          kinds in shared objects, separately from TControl object
-                          instances. To turn off, define a symbol COMMANDACTIONS_RECORD.
-  PACK_COMMANDACTIONS   - this option must be defined together with COMMANDACTIONS_OBJ
-                          and must not with COMMANDACTIONS_RECORD (just do nothing
-                          and this is applied automatically).
-  |
-} -{= K.O.L - ключевая библиотека объектов. (C) Кладов Владимир, 2000-2007. -} - -{$A-} // align off, otherwise code is not good - -{$Q-} // no overflow check: this option makes code wrong -{$R-} // no range checking: this option makes code wrong -{$T-} // not typed @-operator -//{$D+} -//______________________________________________________________________________ -// -//{$DEFINE INPACKAGE} // Uncomment this line while rebuild MCK package -// for Delphi3 only, then restore the comment mark!!!!!!!!!!!!!!!!!!!! -//______________________________________________________________________________ - -{$IFDEF INPACKAGE} // use this symbol in packages requiring kol.pas - {$WARNINGS OFF} - //{$DEFINE NOT_USE_AUTOFREE4CONTROLS} - {$DEFINE PAS_VERSION} - {$UNDEF ASM_VERSION} - {$UNDEF ASM_UNICODE} - {$IFDEF _D2009orHigher} - {$DEFINE UNICODE_CTRLS} - {$ENDIF} -{$ENDIF} -{$IFDEF _D7orHigher} - {$WARN UNSAFE_TYPE OFF} // Too many such warnings in Delphi7 - {$WARN UNSAFE_CODE OFF} - {$WARN UNSAFE_CAST OFF} -{$ENDIF} - -interface - -{$IFnDEF CREATE_VISIBLE} - {$DEFINE CREATE_HIDDEN} -{$ENDIF} - -{$IFDEF NEW_ALIGN} - {$UNDEF OLD_ALIGN} -{$ELSE} - {$IFNDEF OLD_ALIGN} - {$DEFINE NEW_ALIGN} - {$ENDIF} -{$ENDIF} - -{$IFDEF OLD_ALIGN} - {$UNDEF NEW_ALIGN} -{$ELSE} - {$IFNDEF NEW_ALIGN} - {$DEFINE NEW_ALIGN} - {$ENDIF} -{$ENDIF} - -{$IFNDEF OLD_TRANSPARENT} - {$DEFINE NEW_TRANSPARENT} -{$ENDIF} - -{$IFNDEF NOT_UNION_FIELDS} - {$DEFINE UNION_FIELDS} -{$ENDIF} - -{$IFDEF UNION_FIELDS} - {$UNDEF NOT_USE_AUTOFREE4CONTROLS} -{$ENDIF} - -{$IFNDEF NOT_USE_AUTOFREE4CONTROLS} - {$DEFINE USE_AUTOFREE4CONTROLS} - {$DEFINE USE_AUTOFREE4CHILDREN} -{$ENDIF} - -{$IFDEF SMALLEST_CODE} - {$DEFINE NOT_UNLOAD_RICHEDITLIB} - {$DEFINE SMALLER_CODE} - {$DEFINE CREATE_VISIBLE} -{$ELSE} - {$IFnDEF SPEED_NORMAL} - {$DEFINE SPEED_FASTER} - {$ENDIF} -{$ENDIF} -{$IFDEF _D2} - {$UNDEF SPEED_FASTER} -{$ENDIF} - -{$IFDEF SAFE_CODE} - {$UNDEF NO_SAFE_CODE} -{$ENDIF} -{$IFDEF NO_SAFE_CODE} - {$UNDEF SAFE_CODE} -{$ENDIF} -{$IFnDEF NO_SAFE_CODE} -{$IFnDEF SMALLER_CODE} - {$DEFINE SAFE_CODE} -{$ENDIF} -{$ENDIF} - -{$IFDEF NOT_USE_RICHEDIT} - {$DEFINE NOT_UNLOAD_RICHEDITLIB} -{$ENDIF} - -//{$DEFINE DEBUG_GDIOBJECTS} -//{$DEFINE CHK_GDI} - -uses {$IFDEF WIN}messages, windows {$IFNDEF NOT_USE_RICHEDIT}, RichEdit {$ENDIF}{$ENDIF WIN} - {$IFDEF LIN}, Libc, Xlib{$ENDIF} - {$IFDEF GTK}, Glib2 , Gdk2, Gtk2, pango {$ENDIF GTK} - {$IFDEF CHK_GDI}, ChkGdi {$ENDIF}; - -{$IFDEF LIN} - {$DEFINE global_declare} {$I KOL_Linux.inc} {$UNDEF global_declare} -////type HDC = TGC; // from Xlib (temporary definition?) -{$ENDIF LIN} - -var - AppTheming: Boolean; -{$IFDEF DEBUG_GDIOBJECTS} -var - BrushCount: Integer; - FontCount: Integer; - PenCount: Integer; -{$ENDIF} - -{$IFDEF _D2009orHigher} -type KOLWideString = UnicodeString; -{$ELSE} -{$IFDEF _D3orHigher} -type KOLWideString = WideString; -{$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE_CTRLS} - {$IFDEF _D2} - {$ERROR 'Delphi 2 cannot compile with UNICODE_CTRLS defined!'} - {$ENDIF} -const - SizeOfKOLChar = SizeOf(WideChar); - - type - KOLString = KOLWideString; - KOL_String = type KOLWideString; - KOLChar = type WideChar; - PKOLChar = PWideChar; - PKOL_Char = type PWideChar; -{$ELSE} -const - SizeOfKOLChar = SizeOf(AnsiChar); - - type - KOLString = AnsiString; - KOL_String = type AnsiString; - KOLChar = type AnsiChar; - PKOLChar = PAnsiChar; - PKOL_Char = type PAnsiChar; - {$IFDEF ASM_VERSION} - {$IFNDEF ASM_NOUNICODE} - {$DEFINE ASM_UNICODE} - {$ENDIF} - {$UNDEF PAS_VERSION} - {$ENDIF} -{$ENDIF} - -{$IFNDEF ASM_VERSION} - {$DEFINE PAS_VERSION} -{$ENDIF ASM_VERSION} - -{$IFDEF PAS_VERSION} - {$UNDEF ASM_VERSION} - {$UNDEF ASM_UNICODE} - {$UNDEF ASM_TLIST} -{$ENDIF} - -{BCB++}(*type DWORD = Windows.DWORD;*){--BCB} - -{$IFDEF WIN} -//{_#IF [DELPHI]} -{$INCLUDE delphicommctrl.inc} -{$IFDEF UNICODE_CTRLS} - {$DEFINE interface_part} {$I KOL_unicode.inc} {$UNDEF interface_part} -{$ELSE} // ANSI_CTRLS - {$DEFINE interface_part} {$I KOL_ansi.inc} {$UNDEF interface_part} -{$ENDIF UNICODE_CTRLS} -//{_#ENDIF} -{$ENDIF WIN} - -type - _TObj = object - {* auxiliary object type. See TObj. } - protected - procedure Init; virtual; - {* Is called from a constructor to initialize created object instance - filling its fields with 0. Can be overriden in descendant objects - to add another initialization code there. (Main reason of intending - is what constructors can not be virtual in poor objects). } - {= Вызывается для инициализации объекта. } - public - function VmtAddr: Pointer; - {* Returns addres of virtual methods table of object. ? } - {= возвращает адрес таблицы виртуальных методов (VMT). ? } - end; - - PObj = ^TObj; - {* } - - PList = ^TList; - {* } - - PPointerList = ^TPointerList; - TPointerList = array[0..{$IFDEF _DXE2orHigher} 65536 - {$ELSE} MaxInt div 4 - 1 {$ENDIF}] of Pointer; - - TObjectMethod = procedure of object; - {* } - TOnEvent = procedure( Sender: PObj ) of object; - {* This type of event is the most common - event handler when called can - know only what object was a sender of this call. Replaces good known - VCL TNotifyEvent event type. } - - TOnEventMoving = procedure( Sender: PObj; P: PRect ) of object; - -{ --------------------------------------------------------------------- - TObj - base object to derive all others ----------------------------------------------------------------------- } -//[TObj DEFINITION] - TObj = object( _TObj ) - {* Prototype for all objects of KOL. All its methods are important to - implement objects in a manner similar to Delphi TObject class. } - {= Базовый класс для всех прочих объектов KOL. } - protected - {$IFDEF DEBUG_OBJKIND} - fObjKind: PChar; - {$ENDIF} - fRefCount: Integer; - fOnDestroy: TOnEvent; - {$IFDEF OLD_REFCOUNT} - procedure DoDestroy; - {$ENDIF} - protected - fAutoFree: PList; - {* Is called from a constructor to initialize created object instance - filling its fields with 0. Can be overriden in descendant objects - to add another initialization code there. (Main reason of intending - is what constructors can not be virtual in poor objects). } - {= Вызывается для инициализации объекта. } - fTag: DWORD; - {* Custom data. } - public - destructor Destroy; virtual; - {* Disposes memory, allocated to an object. Does not release huge strings, - dynamic arrays and so on. Such memory should be freeing in overriden - destructor. } - {= Освобождает память, выделенную для объекта. Не освобождает память, выделенную - для строк, динамичиских массивов и т.п. Такая память должна быть освобождена - в переопределенном деструкторе объекта. } - {$IFnDEF NIL_EVENTS} - //procedure Init; virtual; - {* Can be overriden in descendant objects - to add initialization code there. (Main reason of intending - is what constructors can not be virtual in poor objects). } - {$ENDIF NIL_EVENTS} - procedure Final; - {* It is called in destructor to perform OnDestroy event call and to - released objects, added to fAutoFree list. } - public - procedure RefInc; - {* See comments below. } - {= См. RefDec ниже. } - function RefDec: Integer; - {* Decrements reference count. If it is becoming <0, and Free - method was already called, object is (self-) destroyed. Otherwise, - Free method does not destroy object, but only sets flag - "Free was called". - |
- Use RefInc..RefDec to provide a block of code, where - object can not be destroyed by call of Free method. - This makes code more safe from intersecting flows of processing, - where some code want to destroy object, but others suppose that it - is yet existing. - |
- If You want to release object at the end of block RefInc..RefDec, - do it immediately BEFORE call of last RefDec (to avoid situation, - when object is released in result of RefDec, and attempt to - destroy it follow leads to AV exception). - |
- Actually, this "function" is a procedure and does not return - any sensible value. It is declared as a function for internal - needs (to avoid creating separate code for Free method) - } - {= Уменьшает счетчик использования. Если в результате счетчик становится - < 0, и метод Free уже был вызван, объект (само-) разрушается. Иначе, - метод Free не разрушает объект, а только устанавливает флаг "Free был - вызван". - |
- Используйте RefInc..RefDec для предотвращения разрушения объекта на - некотором участке кода (если есть такая необходимость). - |
- Если нужно убить (временный) объект вместе с последним RefDec, сделайте - вызов Free немедленно ПЕРЕД последним RefDec. } - property RefCount: Integer read fRefCount; - {* } - {$IFDEF OLD_FREE} - procedure Free; - {$ELSE NEW_FREE} - property Free: Integer read RefDec; - {* Before calling destructor of object, checks if passed pointer is not - nil - similar what is done in VCL for TObject. It is ALWAYS recommended - to use Free instead of Destroy - see also comments to RefInc, RefDec. } - {= До вызова деструктора, проверяет, не передан ли nil в качестве параметра. - ВСЕГДА рекомендуется использовать Free вместо Destroy - см. так же RefInc, - RefDec. } - {$ENDIF NEW_FREE} - - // By Vyacheslav Gavrik: - function InstanceSize: Integer; - {* Returns a size of object instance. } - - constructor Create; - {* Constructor. Do not call it. Instead, use New function - call for certain object, e.g., NewLabel( AParent, 'caption' ); } - {= Конструктор. Не следует вызывать его. Для конструирования объектов, - вызывайте соответствующую глобальную функцию New<имя-объекта>. Например, - NewLabel( MyForm, 'Метка№1' ); } - class function AncestorOfObject( Obj: Pointer ): Boolean; - {* Is intended to replace 'is' operator, which is not applicable to objects. } - function VmtAddr: Pointer; - {* Returns addres of virtual methods table of object. } - {= возвращает алрес таблицы виртуальных методов (VMT). } - property OnDestroy: TOnEvent read fOnDestroy write fOnDestroy; - {* This event is provided for any KOL object, so You can provide your own - OnDestroy event for it. } - {= Данное событие обеспечивается для всех объектов KOL. Позволяет сделать - что-нибудь в связи с разрушением объекта. } - procedure Add2AutoFree( Obj: PObj ); - {* Adds an object to the list of objects, destroyed automatically - when the object is destroyed. Do not add here child controls of - the TControl (these are destroyed by another way). Only non-control - objects, which are not destroyed automatically, should be added here. } - procedure Add2AutoFreeEx( Proc: TObjectMethod ); - {* Adds an event handler to the list of events, called in destructor. - This method is mainly for internal use, and allows to auto-destroy - VCL components, located on KOL form at design time (in MCK project). } - procedure RemoveFromAutoFree( Obj: PObj ); - {* Removes an object from auto-free list } - procedure RemoveFromAutoFreeEx( Proc: TObjectMethod ); - {* Removes a procedure from auto-free list } - property Tag: DWORD read fTag write fTag; - {* Custom data field. } - protected - {$IFDEF USE_NAMES} - fName: AnsiString; - fNamedObjList: Plist; - fOwnerObj: PObj; - {$ENDIF} - public - {$IFDEF USE_NAMES} - procedure SetName( NewOwnerObj: PObj; NewName: AnsiString); - property Name: Ansistring read FName; - - property NamedObjList : PList read fNamedObjList; - property OwnerObj: PObj read FOwnerObj; - function FindObj(const ObjName: Ansistring): PObj; - {$ENDIF} - end; - -{ --------------------------------------------------------------------- - TList - object to implement list of pointers (or dwords) ----------------------------------------------------------------------- } - TList = object( TObj ) - {* Simple list of pointers. It is used in KOL instead of standard VCL - TList to store any kind data (or pointers to these ones). Can be created - calling function NewList. } - {= Простой список указателей. } - protected - fItems: PPointerList; - fCount: Integer; - fCapacity: Integer; - fAddBy: Integer; - procedure SetCount(const Value: Integer); - procedure SetAddBy(Value: Integer); - destructor Destroy; virtual; - {* Destroys list, freeing memory, allocated for pointers. Programmer - is resposible for destroying of data, referenced by the pointers. } - procedure SetCapacity( Value: Integer ); - function Get( Idx: Integer ): Pointer; - procedure Put( Idx: Integer; Value: Pointer ); - {$IFDEF USE_CONSTRUCTORS} - procedure Init; virtual; - {$ENDIF} - protected - {$IFDEF TLIST_FAST} - fBlockList: PList; - fLastKnownBlockIdx: Integer; - fLastKnownCountBefore: Integer; - fUseBlocks: Boolean; - fNotOptimized: Boolean; - {$ENDIF} - public - procedure Clear; - {* Makes Count equal to 0. Not responsible for freeing (or destroying) - data, referenced by released pointers. } - procedure Add( Value: Pointer ); - {* Adds pointer to the end of list, increasing Count by one. } - procedure Insert( Idx: Integer; Value: Pointer ); - {* Inserts pointer before given item. Returns Idx, i.e. index of - inserted item in the list. Indeces of items, located after insertion - point, are increasing. To add item to the end of list, pass Count - as index parameter. To insert item before first item, pass 0 there. } - function IndexOf( Value: Pointer ): Integer; - {* Searches first (from start) item pointer with given value and returns - its index (zero-based) if found. If not found, returns -1. } - procedure Delete( Idx: Integer ); - {* Deletes given (by index) pointer item from the list, shifting all - follow item indeces up by one. } - procedure DeleteRange( Idx, Len: Integer ); - {* Deletes Len items starting from Idx. } - procedure Remove( Value: Pointer ); - {* Removes first entry of a Value in the list. } - property Count: Integer read fCount write SetCount; - {* Returns count of items in the list. It is possible to delete a number - of items at the end of the list, keeping only first Count items alive, - assigning new value to Count property (less then Count it is). } - property Capacity: Integer read fCapacity write SetCapacity; - {* Returns number of pointers which could be stored in the list - without reallocating of memory. It is possible change this value - for optimize usage of the list (for minimize number of reallocating - memory operations). } - property Items[ Idx: Integer ]: Pointer read Get write Put; default; - {* Provides access (read and write) to items of the list. Please note, - that TList is not responsible for freeing memory, referenced by stored - pointers. } - function Last: Pointer; - {* Returns the last item (or nil, if the list is empty). } - procedure Swap( Idx1, Idx2: Integer ); - {* Swaps two items in list directly (fast, but without testing of - index bounds). } - procedure MoveItem( OldIdx, NewIdx: Integer ); - {* Moves item to new position. Pass NewIdx >= Count to move item - after the last one. } - procedure Release; - {* Especially for lists of pointers to dynamically allocated memory. - Releases all pointed memory blocks and destroys object itself. } - procedure ReleaseObjects; - {* Especially for a list of objects derived from TObj. - Calls Free for every of the object in the list, and then calls - Free for the object itself. } - property AddBy: Integer read fAddBy write SetAddBy; - {* Value to increment capacity when new items are added or inserted - and capacity need to be increased. } - property DataMemory: PPointerList read fItems; - {* Raw data memory. Can be used for direct access to items of a list. - Do not use it for TLIST_FAST ! } - procedure Assign( SrcList: PList ); - {* Copies all source list items. } - {$IFDEF _D4orHigher} - procedure AddItems( const AItems: array of Pointer ); - {* Adds a list of items given by a dynamic array. } - {$ENDIF} - function ItemAddress( Idx: Integer ): Pointer; - {* Returns an address of memory occupying by the item with index Idx. - (If the item is a pointer, returned value is a pointer to a pointer). - Item with index requested must exist. } - {$IFDEF TLIST_FAST} - property UseBlocks: Boolean read fUseBlocks write fUseBlocks; - {$ENDIF} - procedure OptimizeForRead; - end; - -function NewList: PList; -{* Returns pointer to newly created TList object. Use it instead usual - TList.Create as it is done in VCL or XCL. } - -{$IFDEF _D4orHigher} -function NewListInit( const AItems: array of Pointer ): PList; -{* Creates a list filling it initially with certain Items. } -{$ENDIF} - -{$IFNDEF TLIST_FAST} -{$IFNDEF PAS_ONLY} -procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer ); -{* Very fast adds Value to List elements from List[FromIdx] to List[FromIdx+Count-1]. - Given elements must exist. Count must be > 0. } -{$ENDIF} -{$ENDIF} - -procedure Free_And_Nil( var Obj ); -{* Obj.Free and Obj := nil, where Obj *MUST* be TObj or its descendant - (TControl, TMenu, etc.) This procedure is not compatible with VCL's - FreeAndNil, which works with TObject, since this it has another name. } - -{$IFDEF WIN_GDI} -{ ------------------------------- threads ------------------------------------ } - -const - ABOVE_NORMAL_PRIORITY_CLASS = $8000; // only for Windows 2K - BELOW_NORMAL_PRIORITY_CLASS = $4000; // and higher ! - -type - PThread = ^TThread; - - TThreadMethod = procedure of object; - TThreadMethodEx = procedure( Sender: PThread; Param: Pointer ) of object; - - TOnThreadExecute = function(Sender: PThread): Integer of object; - {* Event to be called when Execute method is called for TThread } - -{ --------------------------------------------------------------------- - TThread object ----------------------------------------------------------------------- } - TThread = object(TObj) - private - function GetPriorityBoost: Boolean; - procedure SetPriorityBoost(const Value: Boolean); - {* Thread object. It is possible not to derive Your own thread-based - object, but instead create thread Suspended and assign event - OnExecute. To create, use one of NewThread of NewThreadEx functions, - or derive Your own descendant object and write creation function - (or constructor) for it. - |

- Aknowledgements. Originally class ZThread was developed for XCL: - |
* By: Tim Slusher : junior@nlcomm.com - |
* Home: http://www.nlcomm.com/~junior - } - protected - FSuspended, - FTerminated: Boolean; - FHandle: THandle; - FThreadId: DWORD; - FOnSuspend: TObjectMethod; - FOnResume: TOnEvent; - FData : Pointer; - FOnExecute : TOnThreadExecute; - FMethod: TThreadMethod; - FMethodEx: TThreadMethodEx; - F_AutoFree: Boolean; - FPriority: Integer; - function GetPriorityCls: Integer; - function GetThrdPriority: Integer; - procedure SetPriorityCls(Value: Integer); - procedure SetThrdPriority(Value: Integer); - procedure Init; virtual; - destructor Destroy; virtual; - {* } - public - {$IFDEF PSEUDO_THREADS} - FPrtyCls: Integer; - DoNotWakeUntil: DWORD; - AllThreads: PList; // only for MainThread - CurrentThread: PThread; - StackBottom: Pointer; // except for MainThread - CurStackPos: Pointer; - Stack_Empty: Boolean; - procedure SwitchToThread( T: PThread ); // methods of MainThread - procedure NextThread; - {$ENDIF} - public - FResult: Integer; - function Execute: integer; virtual; - {* Executes thread. Do not call this method from another thread! (Even do - not call this method at all!) Instead, use Resume. - |
- Note also that in contrast to VCL, it is not necessary to create your - own descendant object from TThread and override Execute method. In KOL, - it is sufficient to create an instance of TThread object (see NewThread, - NewThreadEx, NewThreadAutoFree functions) and assign OnExecute event - handler for it. } - procedure Resume; - {* Continues executing. It is necessary to make call for every - nested Suspend. } - procedure Suspend; - {* Suspends thread until it will be resumed. Can be called from another - thread or from the thread itself. } - procedure Terminate; - {* Terminates thread. } - function WaitFor: Integer; - {* Waits (infinitively) until thead will be finished. } - function WaitForTime( T: DWORD ): Integer; - {* Waits (T milliseconds) until thead will be finished. } - - property Handle: THandle read FHandle; - {* Thread handle. It is created immediately when object is created - (using NewThread). } - property Suspended: Boolean read FSuspended; - {* True, if suspended. } - property Terminated: Boolean read FTerminated; - {* True, if terminated. } - property ThreadId: DWORD read FThreadId; - {* Thread id. } - property PriorityClass: Integer read GetPriorityCls write SetPriorityCls; - {* Thread priority class. One of following values: HIGH_PRIORITY_CLASS, - IDLE_PRIORITY_CLASS, NORMAL_PRIORITY_CLASS, REALTIME_PRIORITY_CLASS. } - property ThreadPriority: Integer read GetThrdPriority write SetThrdPriority; - {* Thread priority value. One of following values: THREAD_PRIORITY_ABOVE_NORMAL, - THREAD_PRIORITY_BELOW_NORMAL, THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_IDLE, - THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_TIME_CRITICAL. } - property Data : Pointer read FData write FData; - {* Custom data pointer. Use it for Youe own purpose. } - - property OnExecute: TOnThreadExecute read FOnExecute write FOnExecute; - {* Is called, when Execute is starting. } - property OnSuspend: TObjectMethod read FOnSuspend write FOnSuspend; - {* Is called, when Suspend is performed. } - property OnResume: TOnEvent read FOnResume write FOnResume; - {* Is called, when resumed. } - procedure Synchronize( Method: TThreadMethod ); - {* Call it to execute given method in main thread context. Applet variable - must exist for that time. } - procedure SynchronizeEx( Method: TThreadMethodEx; Param: Pointer ); - {* Call it to execute given method in main thread context, with a given - parameter. Applet variable must exist for that time. Param must not be nil. } - {$IFDEF USE_CONSTRUCTORS} - constructor ThreadCreate; - constructor ThreadCreateEx( const Proc: TOnThreadExecute ); - {$ENDIF USE_CONSTRUCTORS} - - property AutoFree: Boolean read F_AutoFree write F_AutoFree; - {* Set this property to true to provide automatic destroying of thread - object when its executing is finished. } - property PriorityBoost: Boolean read GetPriorityBoost write SetPriorityBoost; - {* By default, priority boost is enabled for all threads. } - end; - -function NewThread: PThread; -{* Creates thread object (always suspended). After creating, set event - OnExecute and perform Resume operation. } - -function NewThreadEx( const Proc: TOnThreadExecute ): PThread; stdcall; -{* Creates thread object, assigns Proc to its OnExecute event and runs - it. } - -function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread; -{* Creates thread object similar to NewThreadEx, but freeing automatically - when executing of such thread finished. Be sure that a thread is resumed - at least to provide its object keeper freeing. } - -{$IFDEF PSEUDO_THREADS} -var MainThread: PThread; - PseudoThreadStackSize: DWORD = 1024 * 1024; - CreatingMainThread: Boolean; - -function WaitForSingleObject( hHandle: THandle; dwMilliseconds: DWORD ): DWORD; stdcall; -function WaitForMultipleObjects( nCount: DWORD; - lpHandles: PHandle; fWaitAll: BOOL; dwMilliseconds: DWORD ): DWORD; stdcall; -procedure Sleep( n: DWORD ); -{$ENDIF} - -{ ----------------------------------- streams -------------------------------- } - -{$ENDIF WIN_GDI} -type - TMoveMethod = ( spBegin, spCurrent, spEnd ); -{$IFDEF WIN_GDI} -type - {$IFDEF STREAM_LARGE64} - TStrmSize = Int64; - TStrmMove = Int64; - {$UNDEF ASM_STREAM} - {$UNDEF STREAM_COMPAT} - {$ELSE} - TStrmSize = DWORD; - TStrmMove = Integer; - {$IFDEF ASM_VERSION} - {$IFNDEF ASM_NOSTREAM} - {$DEFINE ASM_STREAM} - {$ENDIF} - {$ENDIF} - {$ENDIF} - - PStream = ^TStream; - - PStreamMethods = ^TStreamMethods; - TStreamMethods = Packed Record - fSeek: function( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod ): TStrmSize; - fGetSiz: function( Strm: PStream ): TStrmSize; - fSetSiz: procedure( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Value: TStrmSize ); - fRead: function( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; - fWrite: function( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; - fClose: procedure( Strm: PStream ); - fCustom: Pointer; - fWait: procedure( Strm: PStream ); - end; - - TStreamData = Packed Record - fHandle: THandle; - fCapacity, fSize, fPosition: TStrmSize; - fThread: PThread; - CASE Integer OF - 2: ( - fStream1, - fStream2: PStream; - ); - 3: ( - fBaseStream: PStream; - fFromPos: TStrmSize; - ); - 4: ( - fBlkSize: Integer; - fBlocks: PList; - fJustWrittenBlkAddress: Pointer; - ); - end; - -{ --------------------------------------------------------------------- - TStream - streaming objects incapsulation ----------------------------------------------------------------------- } - TStream = object(TObj) - {* Simple stream object. Can be opened for file, or as memory stream (see - NewReadFileStream, NewWriteFileStream, NewMemoryStream, etc.). And, another - type of streaming object can be derived (without inheriting new object - type, just by writing another New...Stream method, which calls - _NewStream and pass methods record to it). } - protected - fPMethods: PStreamMethods; - fMethods: TStreamMethods; - fMemory: Pointer; - fData: TStreamData; - fParam1, fParam2: TStrmMove; // parameters to use in thread - fOnChangePos: TOnEvent; - function GetCapacity: TStrmSize; - procedure SetCapacity(const Value: TStrmSize); - function DoAsyncRead( Sender: PThread ): Integer; - function DoAsyncWrite( Sender: PThread ): Integer; - function DoAsyncSeek( Sender: PThread ): Integer; - protected - function GetFileStreamHandle: THandle; - procedure SetPosition(const Value: TStrmSize); - function GetPosition: TStrmSize; - function GetSize: TStrmSize; - procedure SetSize(const NewSize: TStrmSize); - destructor Destroy; virtual; - public - function Read(var Buffer; const Count: TStrmSize): TStrmSize; - {* Reads Count bytes from a stream. Returns number of bytes read. } - function Seek({$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize; - {* Allows to change current position or to obtain it. Property - Position uses this method both for get and set position. } - function Write(var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize; - {* Writes Count bytes from Buffer, starting from current position - in a stream. Returns how much bytes are written. } - function WriteVal( Value: DWORD; Count: DWORD ): DWORD; - {* Writes maximum 4 bytes of Value to a stream. Allows writing constants - easier than via Write. } - function WriteStr( S: AnsiString ): DWORD; - {* Writes string to the stream, not including ending #0. Exactly - Length( S ) characters are written. } - function WriteStrZ( S: AnsiString ): DWORD; - {* Writes string, adding #0. Number of bytes written is returned. } - {$IFDEF _D3orHigher} - function WriteWStrZ( S: KOLWideString ): DWORD; - {* Writes string, adding #0. Number of bytes written is returned. } - {$ENDIF} - function ReadStrZ: AnsiString; - {* Reads string, finished by #0. After reading, current position in - the stream is set to the byte, follows #0. } - {$IFDEF _D3orHigher} - function ReadWStrZ: KOLWideString; - {* Reads string, finished by #0. After reading, current position in - the stream is set to the byte, follows #0. } - {$ENDIF} - function ReadStr: AnsiString; - {* Reads string, finished by #13, #10 or #13#10 symbols. Terminating symbols - #13 and/or #10 are not added to the end of returned string though - stream positioned follow it. } - function ReadStrLen( Len: Integer ): AnsiString; - {* Reads string of the given length Len. } - function WriteStrEx(S: AnsiString): DWord; - {* Writes string S to stream, also saving its size for future use by - ReadStrEx* functions. Returns number of actually written characters. } - function ReadStrExVar(var S: AnsiString): DWord; - {* Reads string from stream and assigns it to S. - Returns number of actually read characters. - Note: - String must be written by using WriteStrEx function. - Return value is count of characters READ, not the length of string. } - function ReadStrEx: AnsiString; - {* Reads string from stream and returns it. } - function WriteStrPas( S: AnsiString ): DWORD; - {* Writes a string in Pascal short string format - 1 byte length, then string - itself without trailing #0 char. S parameter length should not exceed 255 - chars, rest chars are truncated while writing. Total amount of bytes - written is returned. } - function ReadStrPas: AnsiString; - {* Reads 1 byte from a stream, then treat it as a length of following string - which is read and returned. A purpose of this function is reading strings - written using WriteStrPas. } - property Size: TStrmSize read GetSize write SetSize; - {* Returns stream size. For some custom streams, can be slow - operation, or even always return undefined value (-1 recommended). } - property Position: TStrmSize read GetPosition write SetPosition; - {* Current position. } - - property Memory: Pointer read fMemory; - {* Only for memory stream. } - property Handle: THandle read GetFileStreamHandle; - {* Only for file stream. It is possible to check that Handle <> - INVALID_HANDLE_VALUE to ensure that file stream is created OK. } - - //---------- for asynchronous operations (using thread - not tested): - procedure SeekAsync(MoveTo: TStrmMove; MoveMethod: TMoveMethod); - {* Changes current position asynchronously. To wait for finishing the - operation, use method Wait. } - procedure ReadAsync(var Buffer; Count: DWord); - {* Reads Count bytes from a stream asynchronously. To wait finishing the - operation, use method Wait. } - procedure WriteAsync(var Buffer; Count: DWord); - {* Writes Count bytes from Buffer, starting from current position - in a stream - asynchronously. To wait finishing the operation, - use method Wait. } - function Busy: Boolean; - {* Returns TRUE until finishing the last asynchronous operation - started by calling SeekAsync, ReadAsync, WriteAsync methods. } - procedure Wait; - {* Waits for finishing the last asynchronous operation. } - - property Methods: PStreamMethods read fPMethods; - {* Pointer to TStreamMethods record. Useful to implement custom-defined - streams, which can access its fCustom field, or even to change - methods when necessary. } - property Data: TStreamData read fData; - {* Pointer to TStreamData record. Useful to implement custom-defined - streams, which can access Data fields directly when implemented. } - - property Capacity: TStrmSize read GetCapacity write SetCapacity; - {* Amound of memory allocated for data (MemoryStream). } - - procedure SaveToFile( const Filename: KOLString; const Start, CountSave: TStrmSize ); - {* } - - property OnChangePos: TOnEvent read fOnChangePos write fOnChangePos; - {* To allow using this event, create stream with special constructing - function like NewMemoryStreamWithEvent or NewReadFileStreamWithEvent, - or replace reading / writing methods to certain supporting OnChangePos - event. } - end; - -function _NewStream( const StreamMethods: TStreamMethods ): PStream; -{* Use this method only to define your own stream type. See also declared - below (in KOL.pas) methods used to implement standard KOL streams. You can use it in - your code to create streams, which are partially based on standard - methods. } - -// Methods below are declared here to simplify creating your -// own streams with some methods standard and some non-standard -// together: -function SeekFileStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -function GetSizeFileStream( Strm: PStream ): TStrmSize; -function ReadFileStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function ReadFileStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var ReadFileStreamProc: function( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize - = ReadFileStream; - -function WriteFileStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function WriteFileStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function WriteFileStreamEOF( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function WriteFileStreamEOFWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -procedure CloseFileStream( Strm: PStream ); -function SeekMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -function SeekMemStreamWithEvent( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -function GetSizeMemStream( Strm: PStream ): TStrmSize; - -var CapacityMask: DWORD = $4000 - 1; // must be 2**n-1 -procedure SetSizeMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -function ReadMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function ReadMemStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function WriteMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function WriteMemStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -procedure CloseMemStream( Strm: PStream ); -procedure SetSizeFileStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); - -function ReadMemBlkStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function SeekMemBlkStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -function WriteMemBlkStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -procedure ResizeMemBlkStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -procedure FreeMemBlkStream( Strm: PStream ); - -function SeekConcatStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -function GetSizeConcatStream( Strm: PStream ): TStrmSize; -procedure SetSizeConcatStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -function ReadConcatStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function WriteConcatStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -procedure CloseConcatStream( Strm: PStream ); - -function SeekSubStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -function GetSizeSubStream( Strm: PStream ): TStrmSize; -procedure SetSizeSubStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -function ReadSubStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -function WriteSubStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -procedure CloseSubStream( Strm: PStream ); - -procedure DummyCloseStream( Strm: PStream ); - -function DummyReadWrite( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -procedure DummySetSize( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Value: TStrmSize ); -procedure DummyStreamProc(Strm: PStream); - -function NewFileStream( const FileName: KOLString; Options: DWORD ): PStream; -{* Creates file stream for read and write. Exact set of open attributes - should be passed through Options parameter (see FileCreate where those - flags are listed). } - -function NewFileStreamWithEvent( const FileName: KOLString; Options: DWORD ): PStream; -{* Creates file stream for read and write. Exact set of open attributes - should be passed through Options parameter (see FileCreate where those - flags are listed). Also, resulting stream is supporting OnChangePos event. } - -function NewReadFileStream( const FileName: KOLString ): PStream; -{* Creates file stream for read only. } - -function NewReadFileStreamWithEvent( const FileName: KOLString ): PStream; -{* Creates file stream for read only, supporting OnChangePos event. } - -function NewWriteFileStream( const FileName: KOLString ): PStream; -{* Creates file stream for write only. Truncating of file (if needed) - is provided automatically. } - -function NewWriteFileStreamWithEvent( const FileName: KOLString ): PStream; -{* Creates file stream for write only. Truncating of file (if needed) - is provided automatically. Created stream supports OnChangePos event. } - -function NewReadWriteFileStream( const FileName: KOLString ): PStream; -{* Creates stream for read and write file. To truncate file, if it is - necessary, change Size property. } - -{$IFDEF _D3orHigher} -function NewReadFileStreamW( const FileName: KOLWideString ): PStream; -{* Creates file stream for read only. } - -function NewWriteFileStreamW( const FileName: KOLWideString ): PStream; -{* Creates file stream for write only. Truncating of file (if needed) - is provided automatically. } - -function NewReadWriteFileStreamW( const FileName: KOLWideString ): PStream; -{* Creates stream for read and write file. To truncate file, if it is - necessary, change Size property. } -{$ENDIF} - -function NewExFileStream( F: HFile ): PStream; -{* Creates read only stream to read from opened file or pipe from the current - position. - When stream is destroyed, file handle still not closed (your code should do - this) and file position is not changed (after the last read operation). } - -function NewMemoryStream: PStream; -{* Creates memory stream (read and write). } - -function NewMemoryStreamWithEvent: PStream; -{* Creates memory stream (read and write). Created stream support OnChangePos - event. } - -function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream; -{* Creates memory stream on base of existing memory. It is not possible - to write out of top bound given by Size (i.e. memory can not be resized, - or reallocated. When stream object is destroyed this memory is not freed. } - -function NewMemBlkStream( BlkSize: Integer ): PStream; -{* Creates memory stream which consists from blocks of given size. Contrary to - a memory stream, contents of the blocks stream should not be accessed - directly via fMemory but therefore it is possible to access its parts by - portions written to blocks still those were written contigously. To do so, - get an address of just written portion for further usage via field - fJustWrittenBlkAddress. It is guarantee that blocks of memory allocated - during write process never are relocated until destruction the stream. } - -function NewMemBlkStream_WriteOnly( BlkSize: Integer ): PStream; -{* Same as NewMemoryStream} - -function NewConcatStream( Stream1, Stream2: PStream ): PStream; -{* Creates a stream which is a concatenation of two source stream. After - the call, both source streams are belonging to the resulting stream and these - will be destroyed together with the resulting stream. (So forget about it). - - After the call, first stream will not be changed in size via methods of - concatenated stream (and it is not recommended to use further Stream1 and - Stream2 methods too). But Stream2 can still be increased, if it allows doing - so when some data are appended or Size of resulting stream is changed (but - not less then Stream1.Size). - - Nature and physical location of Stream1 and Stream2 are not important and - can be absolutely different. But it is supposed that both streams are not - compressed and its Size is known always and Seek operation is valid. - - This function accepts recursive (multi-level) usage: resulting concatenation - stream can be used as a left or right parameter to create another concatenation - stream later, so it is possible to build a tree of streams concatenated, - concatenating this way several different streams and use it as a single - data streaming object. -} - -function NewSubStream( BaseStream: PStream; const FromPos, Size: TStrmSize ): PStream; -{* Creates a stream which is a subpart of BaseStream passes, starting from - FromPos and with given Size. Like in function NewConcatStream, passes - BaseStream become owned by newly created sub-stream object, and will be - destroyed automatically together with a sub-stream. - - If you want to provide more long life time for a base stream (e.g. if you - plan to use it after a sub-stream based on it is destroyed), use method - RefInc for base stream once to prevent it from destroying when the sub-stream - is destroyed. - - Note: be careful and avoid direct calling methods and properties of the base - stream, while you have a sub-stream created on base it, since the sub-stream - actually redirects all the requests to the parent base stream. - - Sub-stream accepts setting Size to greater value later, and if some data - are written to it, it is written actually to the base stream, and when it - is written beyond the end position, this will increase size of the base - stream too (and if it is a file stream, this also will increase size of the - file on which the base stream was created). - - This function accepts recursive (multi-level) usage: it is possible to create - later another sub-stream on base of existing sub-stream, still it is actully - can be treated as usual stream. -} - -function Stream2Stream( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -{* Copies Count (or less, if the rest of Src is not sufficiently long) - bytes from Src to Dst, but with optimizing in cases, when Src or/and - Dst are memory streams (intermediate buffer is not allocated). } -function Stream2StreamEx( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -{* Copies Count bytes from Src to Dst, but without any optimization. - Unlike Stream2Stream function, it can be applied to very large streams. - See also Stream2StreamExBufSz. } -function Stream2StreamExBufSz( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize; BufSz: DWORD ): TStrmSize; -{* Copies Count bytes from Src to Dst using buffer of given size, but without - other optimizations. - Unlike Stream2Stream function, it can be applied to very large streams } -function Resource2Stream( DestStrm : PStream; Inst : HInst; - ResName : PKOLChar; ResType : PKOLChar ): Integer; -{* Loads given resource to DestStrm. Useful for non-standard - resources to load it into memory (use memory stream for such - purpose). Use one of following resource types to pass as ResType: - |
-RT_ACCELERATOR	Accelerator table
-RT_ANICURSOR	Animated cursor
-RT_ANIICON	Animated icon
-RT_BITMAP	Bitmap resource
-RT_CURSOR	Hardware-dependent cursor resource
-RT_DIALOG	Dialog box
-RT_FONT	        Font resource
-RT_FONTDIR	Font directory resource
-RT_GROUP_CURSOR	Hardware-independent cursor resource
-RT_GROUP_ICON	Hardware-independent icon resource
-RT_ICON	        Hardware-dependent icon resource
-RT_MENU	        Menu resource
-RT_MESSAGETABLE	Message-table entry
-RT_RCDATA	Application-defined resource (raw data)
-RT_STRING	String-table entry
-RT_VERSION	Version resource
-   |
- |
For example: - !var MemStrm: PStream; - ! JpgObj: PJpeg; - !...... - ! MemStrm := NewMemoryStream; - ! JpgObj := NewJpeg; - !...... - ! Resource2Stream( MemStrm, hInstance, 'MYJPEG', RT_RCDATA ); - ! MemStrm.Position := 0; - ! JpgObj.LoadFromStream( MemStrm ); - ! MemStrm.Free; - !...... - } -{$ENDIF WIN_GDI} - -{ ------------------------- string list objects ------------------------------ } - -type - TCompareStrListFun = function( const S1, S2: PAnsiChar ): Integer; - TCompareEvent = function (const Data: Pointer; const e1,e2 : Dword) : Integer; - {* Event type to define comparison function between two elements of an array. - This event handler must return negative or positive value (correspondently - for cases e1e2), or 0 if items are equal. Items are enumerated - from 0 to uNElem. } - TSwapEvent = procedure (const Data : Pointer; const e1,e2 : Dword); - {* Event type to define swap procedure which is swapping two elements of the - sorting data. } - TCompareArrayEvent = function(e1,e2 : DWord) : Integer; - {* Event type to define comparison function between two elements of an array. - Like in TCompareEvent, but e1 and e2 are not indexes in the array but items - itselves. } - - PStrList = ^TStrList; -{ --------------------------------------------------------------------- - TStrList - string list ----------------------------------------------------------------------- } - TStrList = object(TObj) - {* Easy string list implementation (non-visual, just to store - string data). It is well improved and has very high performance - allowing to work fast with huge text files (more then megabyte - of text data). - | - Please note that #0 charaster if stored in string lines, will cut it - preventing reading the rest of a line. Be careful, if your data - contain such characters. } - protected - procedure Init; virtual; - protected - fList: PList; - fCount: Integer; - fCaseSensitiveSort: Boolean; - fAnsiSort: Boolean; - fTextBuf: PAnsiChar; - fTextSiz: DWORD; - fCompareStrListFun: TCompareStrListFun; - function GetPChars(Idx: Integer): PAnsiChar; - //procedure AddTextBuf( Src: PAnsiChar; Len: DWORD ); - protected - function Get(Idx: integer): Ansistring; - function GetTextStr: Ansistring; - procedure Put(Idx: integer; const Value: Ansistring); - procedure SetTextStr(const Value: Ansistring); - destructor Destroy; virtual; - protected - // by Dod: - procedure SetValue(const AName, Value: Ansistring); - function GetValue(const AName: Ansistring): Ansistring; - public - // by Dod: - function IndexOfName(AName: Ansistring): Integer; - {* by Dod. Returns index of line starting like Name=... } - function IndexOfName_NoCase(AName: Ansistring): Integer; - property Values[const AName: Ansistring]: Ansistring read GetValue write SetValue; - {* by Dod. Returns right side of a line starting like Name=... } - public - function Add(const S: Ansistring): integer; - {* Adds a string to list. } - procedure AddStrings(Strings: PStrList); - {* Merges string list with given one. Very fast - more preferrable to - use than any loop with calling Add method. } - procedure Assign(Strings: PStrList); - {* Fills string list with strings from other one. The same as AddStrings, - but Clear is called first. } - procedure Clear; - {* Makes string list empty. } - procedure Delete(Idx: integer); - {* Deletes string with given index (it *must* exist). } - procedure DeleteLast; - {* Deletes the last string (it *must* exist). } - function IndexOf(const S: AnsiString): integer; - {* Returns index of first string, equal to given one. } - function IndexOf_NoCase(const S: Ansistring): integer; - {* Returns index of first string, equal to given one (while comparing it - without case sensitivity). } - function IndexOfStrL_NoCase( Str: PAnsiChar; L: Integer ): integer; - {* Returns index of first string, equal to given one (while comparing it - without case sensitivity). } - function Find(const S: AnsiString; var Index: Integer): Boolean; - {* Returns Index of the string, equal or greater to given pattern, but - works only for sorted TStrList object. Returns TRUE if exact string found, - otherwise nearest (greater then a pattern) string index is returned, - and the result is FALSE. And in such _case Index is returned negated - when the S string is less then the string found. } - function FindFirst(const S: AnsiString; var Index: Integer): Boolean; - {* Like above but always returns Index of the first string, equal or greater - to given pattern. Also works only for sorted TStrList object. Returns TRUE - if exact string found, otherwise nearest (greater then a pattern) string - index is returned, and the result is FALSE. } - procedure Insert(Idx: integer; const S: Ansistring); - {* Inserts string before one with given index. } - procedure Move(CurIndex, NewIndex: integer); - {* Moves string to another location. } - procedure SetText(const S: Ansistring; Append2List: Boolean); - {* Allows to set strings of string list from given string (in which - strings are separated by $0D,$0A or $0D characters). Text must not - contain #0 characters. Works very fast. This method is used in - all others, working with text arrays (LoadFromFile, MergeFromFile, - Assign, AddStrings). } - procedure SetUnixText( const S: AnsiString; Append2List: Boolean ); - {* Allows to assign UNIX-style text (with #10 as string separator). } - property Count: integer read fCount; - {* Number of strings in a string list. } - property Items[Idx: integer]: Ansistring read Get write Put; default; - {* Strings array items. If item does not exist, empty string is returned. - But for assign to property, string with given index *must* exist. } - property ItemPtrs[ Idx: Integer ]: PAnsiChar read GetPChars; - {* Fast access to item strings as PChars. } - function Last: AnsiString; - {* Last item (or '', if string list is empty). } - property Text: Ansistring read GetTextStr write SetTextStr; - {* Content of string list as a single string (where strings are separated - by characters $0D,$0A). } - procedure Swap( Idx1, Idx2 : Integer ); - {* Swaps to strings with given indeces. } - procedure Sort( CaseSensitive: Boolean ); - {* Call it to sort string list. } - procedure AnsiSort( CaseSensitive: Boolean ); - {* Call it to sort ANSI string list. } - procedure SortEx(const CompareFun: TCompareEvent); // by Dufa - {* Call it to sort via your own compare procedure } - protected // by Alexander Pravdin: - fNameDelim: AnsiChar; - function GetLineName( Idx: Integer ): AnsiString; - procedure SetLineName( Idx: Integer; const NV: AnsiString ); - function GetLineValue(Idx: Integer): Ansistring; - procedure SetLineValue(Idx: Integer; const Value: Ansistring); - public - property LineName[ Idx: Integer ]: Ansistring read GetLineName write SetLineName; - property LineValue[ Idx: Integer ]: Ansistring read GetLineValue write SetLineValue; - property NameDelimiter: AnsiChar read fNameDelim write fNameDelim; - function Join( const sep: AnsiString ): AnsiString; - {* by Sergey Shishmintzev } - {$IFDEF WIN_GDI} - function LoadFromFile(const FileName: KOLString): Boolean; - {* Loads string list from a file. (If file does not exist, nothing - happens). Very fast even for huge text files. } - procedure LoadFromStream(Stream: PStream; Append2List: Boolean); - {* Loads string list from a stream (from current position to the end of - a stream). Very fast even for huge text. } - procedure MergeFromFile(const FileName: KOLString); - {* Merges string list with strings in a file. Fast. } - function SaveToFile(const FileName: KOLString): Boolean; - {* Stores string list to a file. } - procedure SaveToStream(Stream: PStream); - {* Saves string list to a stream (from current position). } - function AppendToFile(const FileName: KOLString): Boolean; - {* Appends strings of string list to the end of a file. } - {$ENDIF WIN_GDI} - procedure OptimizeForRead; - end; - -var DefaultNameDelimiter: AnsiChar = '='; - ThsSeparator: KOLChar = ','; - -function NewStrList: PStrList; -{* Creates string list object. } - -{$IFNDEF _FPC} -function WStrLen( W: PWideChar ): Integer; -{* Returns Length of null-terminated Unicode string. } - -{$IFDEF _D3orHigher} -function UTF8_2KOLWideString( const s: AnsiString ): KOLWideString; -{$ENDIF} -{$ENDIF _FPC} - -type - PStrListEx = ^TStrListEx; - - TStrListEx = object( TStrList ) - {* Extended string list object. Has additional capability to associate - numbers or objects with string list items. } - protected - FObjects: PList; - function GetObjects(Idx: Integer): DWORD; - function GetObjectCount: Integer; - procedure SetObjects(Idx: Integer; const Value: DWORD); - procedure Init; virtual; - procedure ProvideObjCapacity( NewCap: Integer ); - public - destructor Destroy; virtual; - {* } - property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects; - {* Objects are just 32-bit values. You can treat and use it as pointers to - any other data in the memory. But it is your task to free allocated - memory in such case therefore. - |
- If the last item of a string list is deleted vis DeleteLast method (but - not via Delete method), it's object still is preserved. As well, it is - possible to set Objects[idx] for idx >= Count. - To get know object's count, rather then strings count, use ObjectCount - property. } - property ObjectCount: Integer read GetObjectCount; - {* Returns number of objects available. This value can differ from Count - after some operations: objects are stored in the independant list and - only synchronization is provided while using methods Delete, Insert, - Add, AddObject, InsertObject while changing the list. } - procedure AddStrings(Strings: PStrListEx); - {* Merges string list with given one. Very fast - more preferrable to - use than any loop with calling Add method. } - procedure Assign(Strings: PStrListEx); - {* Fills string list with strings from other one. The same as AddStrings, - but Clear is called first. } - procedure Clear; - {* Makes string list empty. } - procedure Delete(Idx: integer); - {* Deletes string with given index (it *must* exist). } - procedure DeleteLast; - {* Deletes the last string and correspondent object in the list. } - procedure Move(CurIndex, NewIndex: integer); - {* Moves string to another location. } - procedure Swap( Idx1, Idx2 : Integer ); - {* Swaps to strings with given indeces. } - procedure Sort( CaseSensitive: Boolean ); - {* Call it to sort string list. } - procedure AnsiSort( CaseSensitive: Boolean ); - {* Call it to sort ANSI string list. } - function LastObj: DWORD; - {* Object assotiated with the last string. } - function AddObject( const S: AnsiString; Obj: DWORD ): Integer; - {* Adds a string and associates given number with it. Index of the item added - is returned. } - procedure InsertObject( Before: Integer; const S: AnsiString; Obj: DWORD ); - {* Inserts a string together with object associated. } - function IndexOfObj( Obj: Pointer ): Integer; - {* Returns an index of a string associated with the object passed as a - parameter. If there are no such strings, -1 is returned. } - procedure OptimizeForRead; - end; - -function NewStrListEx: PStrListEx; -{* Creates extended string list object. } - -{$IFNDEF _FPC} -procedure WStrCopy( Dest, Src: PWideChar ); -{* Copies null-terminated Unicode string (terminated null also copied). } -procedure WStrLCopy( Dest, Src: PWideChar; MaxLen: Integer ); -{* Copies null-terminated Unicode string (terminated null also copied). } -function WStrCmp( W1, W2: PWideChar ): Integer; -{* Compares two null-terminated Unicode strings. } -{$IFDEF _D3orHigher} -function WStrCmp_NoCase( W1, W2: PWideChar ): Integer; -{* Compares two null-terminated Unicode strings. } -{$ENDIF} -{$ENDIF _FPC} - -{$IFDEF WIN_GDI} -{$IFNDEF _D2} //------------------ WideString is not supported in D2 ----------- - -type - PWStrList = ^TWstrList; - {* } - TWStrList = object( TObj ) - {* String list to store Unicode (null-terminated) strings. } - protected - function GetCount: Integer; - function GetItems(Idx: Integer): KOLWideString; - procedure SetItems(Idx: Integer; const Value: KOLWideString); - function GetPtrs(Idx: Integer): PWideChar; - function GetText: KOLWideString; - protected - fList: PList; - fText: PWideChar; - fTextBufSz: Integer; - fTmp1, fTmp2: KOLWideString; - procedure Init; virtual; - public - procedure SetText(const Value: KOLWideString); - {* See also TStrList.SetText } - destructor Destroy; virtual; - {* } - procedure Clear; - {* See also TStrList.Clear } - property Items[ Idx: Integer ]: KOLWideString read GetItems write SetItems; - {* See also TStrList.Items } - property ItemPtrs[ Idx: Integer ]: PWideChar read GetPtrs; - {* See also TStrList.ItemPtrs } - property Count: Integer read GetCount; - {* See also TStrList.Count } - function Add( const W: KOLWideString ): Integer; - {* See also TStrList.Add } - procedure Insert( Idx: Integer; const W: KOLWideString ); - {* See also TStrList.Insert } - procedure Delete( Idx: Integer ); - {* See also TStrList.Delete } - property Text: KOLWideString read GetText write SetText; - {* See also TStrList.Text } - procedure AddWStrings( WL: PWStrList ); - {* See also TStrList.AddStrings } - procedure Assign( WL: PWStrList ); - {* See also TStrList.Assign } - function LoadFromFile( const Filename: KOLString ): Boolean; - {* See also TStrList.LoadFromFile } - procedure LoadFromStream( Strm: PStream; AppendToList: Boolean ); - {* See also TStrList.LoadFromStream } - function MergeFromFile( const Filename: KOLString ): Boolean; - {* See also TStrList.MergeFromFile } - procedure MergeFromStream( Strm: PStream ); - {* See also TStrList.MergeFromStream } - function SaveToFile( const Filename: KOLString ): Boolean; - {* See also TStrList.SaveToFile } - procedure SaveToStream( Strm: PStream ); - {* See also TStrList.SaveToStream } - function AppendToFile( const Filename: KOLString ): Boolean; - {* See also TStrList.AppendToFile } - procedure Swap( Idx1, Idx2: Integer ); - {* See also TStrList.Swap } - procedure Sort( CaseSensitive: Boolean ); - {* See also TStrList.Sort } - procedure Move( IdxOld, IdxNew: Integer ); - {* See also TStrList.Move } - function IndexOf( const s: KOLWideString ): Integer; - {* } - function IndexOf_NoCase( const s: KOLWideString ): Integer; - {* } - function Last: KOLWideString; - {* } - procedure Put(Idx: integer; const Value: KOLWideString); - {* +azsd for TBButton } - protected // by Alexander Pravdin: - fNameDelim: WideChar; - function GetLineName( Idx: Integer ): KOLWideString; - procedure SetLineName( Idx: Integer; const NV: KOLWideString ); - function GetLineValue(Idx: Integer): KOLWideString; - procedure SetLineValue(Idx: Integer; const Value: KOLWideString); - public - property LineName[ Idx: Integer ]: KOLWideString read GetLineName write SetLineName; - property LineValue[ Idx: Integer ]: KOLWideString read GetLineValue write SetLineValue; - property NameDelimiter: WideChar read fNameDelim write fNameDelim; - procedure OptimizeForRead; - protected // ++++++++++++++ by rdnks - procedure SetValue(const AName, Value: KOLWideString); - function GetValue(const AName: KOLWideString): KOLWideString; - public - function IndexOfName(AName: KOLWideString): Integer; - property Values[const AName: KOLWideString]: KOLWideString read GetValue write SetValue; - end; - - PWStrListEx = ^TWStrListEx; - - TWStrListEx = object( TWStrList ) - {* Extended Unicode string list (with Objects). } - protected - function GetObjects(Idx: Integer): DWORD; - procedure SetObjects(Idx: Integer; const Value: DWORD); - procedure ProvideObjectsCapacity( NewCap: Integer ); - protected - fObjects: PList; - procedure Init; virtual; - public - destructor Destroy; virtual; - {* } - property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects; - {* } - procedure AddWStrings( WL: PWStrListEx ); - {* } - procedure Assign( WL: PWStrListEx ); - {* } - procedure Clear; - {* } - procedure Delete( Idx: Integer ); - {* } - procedure Move( IdxOld, IdxNew: Integer ); - {* } - procedure Swap( Idx1, Idx2: Integer ); - {* See also TStrList.Swap } - procedure Sort( CaseSensitive: Boolean ); - {* See also TStrList.Sort } - function AddObject( const S: KOLWideString; Obj: DWORD ): Integer; - {* Adds a string and associates given number with it. Index of the item added - is returned. } - procedure InsertObject( Before: Integer; const S: KOLWideString; Obj: DWORD ); - {* Inserts a string together with object associated. } - function IndexOfObj( Obj: Pointer ): Integer; - {* Returns an index of a string associated with the object passed as a - parameter. If there are no such strings, -1 is returned. } - procedure OptimizeForRead; - end; - -function NewWStrList: PWStrList; -{* Creates new TWStrList object and returns a pointer to it. } - -function NewWStrListEx: PWStrListEx; -{* Creates new TWStrListEx objects and returns a pointer to it. } - -{$ENDIF not _D2} -{$ENDIF WIN_GDI} - -{$IFDEF UNICODE_CTRLS} -{$IFNDEF _D2} -type TKOLStrList = TWStrList; - PKOLStrList = PWStrList; - TKOLStrListEx = TWStrListEx; - PKOLStrListEx = PWStrListEx; -{$ELSE} -type TKOLStrList = TStrList; - PKOLStrList = PStrList; - TKOLStrListEx = TStrListEx; - PKOLStrListEx = PStrListEx; -{$ENDIF} -{$ELSE} -type TKOLStrList = TStrList; - PKOLStrList = PStrList; - TKOLStrListEx = TStrListEx; - PKOLStrListEx = PStrListEx; -{$ENDIF} - -function NewKOLStrList: PKOLStrList; -function NewKOLStrListEx: PKOLStrListEx; - -{$IFDEF WIN} -function GetFileList(const dir: KOLString): PKOLStrList; -{* By Alexander Shakhaylo. Returns list of file names of the given directory. } -{$ENDIF WIN} - -//////////////////////////////////////////////////////////////////////////////// -// GRAPHIC OBJECTS // -//////////////////////////////////////////////////////////////////////////////// -{ - It is very important, that the most of code, implementing graphic objets - from this section, is included into executable ONLY if really accessed in your - project directly (e.g., if Font or Brush properies of a control are accessed - or changed). -} -type - TColor = Integer; -const - clScrollBar = TColor(COLOR_SCROLLBAR or $80000000); - clBackground = TColor(COLOR_BACKGROUND or $80000000); - clActiveCaption = TColor(COLOR_ACTIVECAPTION or $80000000); - clInactiveCaption = TColor(COLOR_INACTIVECAPTION or $80000000); - clMenu = TColor(COLOR_MENU or $80000000); - clWindow = TColor(COLOR_WINDOW or $80000000); - clWindowFrame = TColor(COLOR_WINDOWFRAME or $80000000); - clMenuText = TColor(COLOR_MENUTEXT or $80000000); - clWindowText = TColor(COLOR_WINDOWTEXT or $80000000); - clCaptionText = TColor(COLOR_CAPTIONTEXT or $80000000); - clActiveBorder = TColor(COLOR_ACTIVEBORDER or $80000000); - clInactiveBorder = TColor(COLOR_INACTIVEBORDER or $80000000); - clAppWorkSpace = TColor(COLOR_APPWORKSPACE or $80000000); - clHighlight = TColor(COLOR_HIGHLIGHT or $80000000); - clHighlightText = TColor(COLOR_HIGHLIGHTTEXT or $80000000); - clBtnFace = TColor(COLOR_BTNFACE or $80000000); - clBtnShadow = TColor(COLOR_BTNSHADOW or $80000000); - clGrayText = TColor(COLOR_GRAYTEXT or $80000000); - clGreyText = TColor(COLOR_GRAYTEXT or $80000000); - clBtnText = TColor(COLOR_BTNTEXT or $80000000); - clInactiveCaptionText = TColor(COLOR_INACTIVECAPTIONTEXT or $80000000); - clBtnHighlight = TColor(COLOR_BTNHIGHLIGHT or $80000000); - cl3DDkShadow = TColor(COLOR_3DDKSHADOW or $80000000); - cl3DLight = TColor(COLOR_3DLIGHT or $80000000); - clInfoText = TColor(COLOR_INFOTEXT or $80000000); - clInfoBk = TColor(COLOR_INFOBK or $80000000); - - clBlack = TColor($000000); - clMaroon = TColor($000080); - clGreen = TColor($008000); - clOlive = TColor($008080); - clNavy = TColor($800000); - clPurple = TColor($800080); - clTeal = TColor($808000); - clGray = TColor($808080); - clGrey = TColor($808080); - clSilver = TColor($C0C0C0); - clRed = TColor($0000FF); - clLime = TColor($00FF00); - clYellow = TColor($00FFFF); - clBlue = TColor($FF0000); - clFuchsia = TColor($FF00FF); - clAqua = TColor($FFFF00); - clLtGray = TColor($C0C0C0); - clLtGrey = TColor($C0C0C0); - clDkGray = TColor($808080); - clDkGrey = TColor($808080); - clWhite = TColor($FFFFFF); - clNone = TColor($1FFFFFFF); - clDefault = TColor($20000000); - - clMoneyGreen = TColor($C0DCC0); - clSkyBlue = TColor($F0CAA6); - clCream = TColor($F0FBFF); - clMedGray = TColor($A4A0A0); - clMedGrey = TColor($A4A0A0); - clOrange = TColor( $3399FF ); - clBrown = TColor( $505080 ); - clDkBrown = TColor( $282840 ); - - clGRushHiLight = TColor( $F3706C ); - clGRushLighten = TColor( $F1EEDF ); - clGRushLight = TColor( $e1cebf ); - clGRushNormal = TColor( $D1beaf ); - clGRushMedium = TColor( $b6bFc6 ); - clGRushDark = TColor( $9EACB4 ); - -const - go_Color = 0; - go_FontHeight = 4; - go_FontWidth = 8; - go_FontEscapement = 12; - go_FontOrientation = 16; - go_FontWeight = 20; - go_FontItalic = 24; - go_FontUnderline = 25; - go_FontStrikeOut = 26; - go_FontCharSet = 27; - go_FontOutPrecision = 28; - go_FontClipPrecision = 29; - go_FontQuality = 30; - go_FontPitch = 31; - go_FontName = 32; - go_BrushBitmap = 4; - go_BrushStyle = 8; - go_BrushLineColor = 9; - go_PenBrushBitmap = 4; - go_PenBrushStyle = 8; - go_PenStyle = 9; - go_PenWidth = 10; - go_PenMode = 14; - go_PenGeometric = 15; - go_PenEndCap = 16; - go_PenJoin = 17; - -type - TGraphicToolType = ( gttBrush, gttFont, gttPen ); - {* Graphic object types, mainly for internal use. } - - PGraphicTool = ^TGraphicTool; - {* } - TOnGraphicChange = procedure ( Sender: PGraphicTool ) of object; - {* An event mainly for internal use. } - - TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical, - bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross); - {* Available brush styles. } - - TFontStyles = (fsBold, fsItalic, fsUnderline, fsStrikeOut); - {* Available font styles. } - TFontStyle = set of TFontStyles; - {* Font style is representing as a set of XFontStyles. } - TFontPitch = (fpDefault, fpFixed, fpVariable); - {* Availabe font pitch values. } - TFontName = type string; - {* Font name is represented as a string. } - TFontCharset = 0..255; - {* Font charset is represented by number from 0 to 255. } - TFontQuality = (fqDefault, fqDraft, fqProof, fqNonAntialiased, fqAntialiased - , fqClearType); - {* Font quality. } - - TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, - psInsideFrame); - {* Available pen styles. For more info see Delphi or Win32 help files. } - TPenMode = (pmBlack, pmNotMerge, pmMaskNotPen, pmNotCopy, pmMaskPenNot, - pmNot, pmXor, pmNotMask, pmMask, pmNotXor, pmNop, pmMergePenNot, - pmCopy, pmMergeNotPen, pmMerge, pmWhite); - {* Available pen modes. For more info see Delphi or Win32 help files. } - TPenEndCap = (pecRound, pecSquare, pecFlat); - {* Avalable (for geometric pen) end cap styles. } - TPenJoin = (pjRound, pjBevel, pjMiter); - {* Available (for geometric pen) join styles. } - - TGDIFont = packed record - Height: Integer; - Width: Integer; - Escapement: Integer; - Orientation: Integer; - Weight: Integer; - Italic: Boolean; - Underline: Boolean; - StrikeOut: Boolean; - CharSet: TFontCharset; - OutPrecision: Byte; - ClipPrecision: Byte; - Quality: TFontQuality; - Pitch: TFontPitch; - Name: array[0..LF_FACESIZE - 1] of KOLChar; - end; - - TGDIBrush = packed record - Bitmap: HBitmap; - Style: TBrushStyle; - LineColor: TColor; - end; - - TGDIPen = packed record - BrushBitmap: HBitmap; - BrushStyle: TBrushStyle; - Style: TPenStyle; - Width: Integer; - Mode: TPenMode; - Geometric: Boolean; - EndCap: TPenEndCap; - Join: TPenJoin; - end; - - TGDIToolData = packed record - Color: TColor; - case Integer of - 1: (Font: TGDIFont); - 2: (Pen: TGDIPen); - 3: (Brush: TGDIBrush); - end; - - TNewGraphicTool = function: PGraphicTool; - -{ --------------------------------------------------------------------- - TGraphicTool - object to implement GDI-tools (brush, pen, font) ----------------------------------------------------------------------- } - TGraphicTool = object( TObj ) - {* Incapsulates all GDI objects: Pen, Brush and Font. } - protected - fType: TGraphicToolType; - {$IFDEF GDI} - fHandle: THandle; - fParentGDITool: PGraphicTool; - {$ENDIF GDI} - fColorRGB: TColor; - fOnGTChange: TOnGraphicChange; - fData: TGDIToolData; - fNewProc: TNewGraphicTool; - {$IFDEF GDI} - fMakeHandleProc: function( Self_: PGraphicTool ): THandle; - {$ENDIF GDI} - procedure SetInt( const Index: Integer; Value: Integer ); - function GetInt( const Index: Integer ): Integer; - procedure SetColor( Value: TColor ); - {$IFDEF GDI} - function GetBrushBitmap: HBitmap; // for BCB only - procedure SetBrushBitmap(const Value: HBitmap); - function GetBrushStyle: TBrushStyle; // for BCB only - {$ENDIF GDI} - procedure SetBrushStyle(const Value: TBrushStyle); - function GetFontName: KOLString; - procedure SetFontName(const Value: KOLString); - function GetFontStyle: TFontStyle; - procedure SetFontStyle(const Value: TFontStyle); - function GetFontWeight: Integer; // for BCB only - procedure SetFontWeight(const Value: Integer); - {$IFDEF GDI} - function GetFontCharset: TFontCharset; // for BCB only - procedure SetFontCharset(const Value: TFontCharset); - function GetFontQuality: TFontQuality; // for BCB only - procedure SetFontQuality(const Value: TFontQuality); - function GetFontOrientation: Integer; // for BCB only - procedure SetFontOrientation(Value: Integer); - function GetFontPitch: TFontPitch; // for BCB only - procedure SetFontPitch(const Value: TFontPitch); - function GetPenMode: TPenMode; // for BCB only - procedure SetPenMode(const Value: TPenMode); - function GetPenStyle: TPenStyle; // for BCB only - procedure SetPenStyle(const Value: TPenStyle); - function GetGeometricPen: Boolean; // for BCB only - procedure SetGeometricPen(const Value: Boolean); - function GetPenEndCap: TPenEndCap; // for BCB only - procedure SetPenEndCap(const Value: TPenEndCap); - function GetPenJoin: TPenJoin; // for BCB only - procedure SetPenJoin(const Value: TPenJoin); - procedure SetLogFontStruct(const Value: TLogFont); - function GetLogFontStruct: TLogFont; - {$ENDIF GDI} - protected - procedure Changed; - {* } - {$IFDEF GDI} - function GetHandle: THandle; - {* } - {$ENDIF GDI} - protected - {$IFDEF _X_} - {$IFDEF GTK} - fPangoFontDesc: PPangoFontDescription; - FUNCTION GetPangoFontDesc: PPangoFontDescription; - {$ENDIF GTK} - {$ENDIF _X_} - public - destructor Destroy; virtual; - {* } - {$IFDEF _X_} - {$IFDEF GTK} - PROPERTY FontHandle: PPangoFontDescription read GetPangoFontDesc; - {$ENDIF GTK} - {$ENDIF _X_} - {$IFDEF GDI} - property Handle: THandle read GetHandle; - {* Every time, when accessed, real GDI object is created (if it is - not yet created). So, to prevent creating of the handle, use - HandleAllocated instead of comparing Handle with value 0. } - function HandleAllocated: Boolean; - {* Returns True, if handle is allocated (i.e., if real GDI - objet is created. } - {$ENDIF GDI} - property OnChange: TOnGraphicChange read fOnGTChange write fOnGTChange; - {* Called, when object is changed. } - {$IFDEF GDI} - function ReleaseHandle: Integer; - {* Returns Handle value (if allocated), releasing it from the - object (so, it is no more knows about this handle and its - HandleAllocated function returns False. } - {$ENDIF GDI} - property Color: TColor {index go_Color} read fData.Color write SetColor; - {* Color is the most common property for all Pen, Brush and - Font objects, so it is placed in its common for all of them. } - function Assign( Value: PGraphicTool ): PGraphicTool; - {* Assigns properties of the same (only) type graphic object, - excluding Handle. If assigning is really leading to change - object, procedure Changed is called. } - {$IFDEF GDI} - procedure AssignHandle( NewHandle: Integer ); - {* Assigns value to Handle property. } - - property BrushBitmap: HBitmap read {-BCB-}fData.Brush.Bitmap{+BCB+} - {BCB++}(*GetBrushBitmap*){--BCB} - write SetBrushBitmap; - {* Brush bitmap. For more info about using brush bitmap, - see Delphi or Win32 help files. } - {$ENDIF GDI} - property BrushStyle: TBrushStyle read {-BCB-}fData.Brush.Style{+BCB+} - {BCB++}(*GetBrushStyle*){--BCB} - write SetBrushStyle; - {$IFDEF GDI} - {* Brush style. } - property BrushLineColor: TColor index go_BrushLineColor - {$IFDEF F_P} - read GetInt - {$ELSE DELPHI} - read {-BCB-}fData.Brush.LineColor{+BCB+} - {BCB++}(*GetInt*){--BCB} - {$ENDIF F_P/DELPHI} - write SetInt; - {* Brush line color, used to represent lines in hatched brush. Default value is clBlack. } - - {$ENDIF GDI} - property FontHeight: Integer index go_FontHeight - {$IFDEF F_P} - read GetInt - {$ELSE DELPHI} - read {-BCB-}fData.Font.Height{+BCB+} - {BCB++}(*GetInt*){--BCB} - {$ENDIF F_P/DELPHI} - write SetInt; - {* Font height. Value 0 (default) says to use system default value, - negative values are to represent font height in "points", positive - - in pixels. In XCL usually positive values (if not 0) are used to - make appearance independent from different local settings. } - {$IFDEF GDI} - property FontWidth: Integer index go_FontWidth - {$IFDEF F_P} - read GetInt - {$ELSE DELPHI} - read {-BCB-}fData.Font.Width{+BCB+} - {BCB++}(*GetInt*){--BCB} - {$ENDIF F_P/DELPHI} - write SetInt; - {* Font width in logical units. If FontWidth = 0, then as it is said - in Win32.hlp, "the aspect ratio of the device is matched against the - digitization aspect ratio of the available fonts to find the closest match, - determined by the absolute value of the difference." } - property FontPitch: TFontPitch read {-BCB-}fData.Font.Pitch{+BCB+} - {BCB++}(*GetFontPitch*){--BCB} - write SetFontPitch; - {* Font pitch. Change it very rare. } - {$ENDIF GDI} - property FontStyle: TFontStyle read GetFontStyle write SetFontStyle; - {* Very useful property to control text appearance. } - {$IFDEF GDI} - property FontCharset: TFontCharset read {-BCB-}fData.Font.Charset{+BCB+} - {BCB++}(*GetFontCharset*){--BCB} - write SetFontCharset; - {* Do not change it if You do not know what You do. } - property FontQuality: TFontQuality read {-BCB-}fData.Font.Quality{+BCB+} - {BCB++}(*GetFontQuality*){--BCB} - write SetFontQuality; - {* Font quality. } - property FontOrientation: Integer read {-BCB-}fData.Font.Orientation{+BCB+} - {BCB++}(*GetFontOrientation*){--BCB} - write SetFontOrientation; - {* It is possible to rotate text in XCL just by changing this - property of a font (tenths of degree, i.e. value 900 represents - 90 degree - text written from bottom to top). } - {$ENDIF GDI} - property FontWeight: Integer read {-BCB-}fData.Font.Weight{+BCB+} - {BCB++}(*GetFontWeight*){--BCB} - write SetFontWeight; - {* Additional font weight for bold fonts (must be 0..1000). When set to - value <> 0, fsBold is added to FontStyle. And otherwise, when set to 0, - fsBold is removed from FontStyle. Value 700 corresponds to Bold, - 400 to Normal. } - property FontName: KOLString read GetFontName write SetFontName; - {* Font face name. } - {$IFDEF GDI} - function IsFontTrueType: Boolean; - {* Returns True, if font is True Type. Requires of creating of a Handle, - if it is not yet created. } - - property PenWidth: Integer index go_PenWidth - {$IFDEF F_P} - read GetInt - {$ELSE DELPHI} - read {-BCB-}fData.Pen.Width{+BCB+} - {BCB++}(*GetInt*){--BCB} - {$ENDIF F_P/DELPHI} - write SetInt; - {* Value 0 means default pen width. } - property PenStyle: TPenStyle read {-BCB-}fData.Pen.Style{+BCB+} - {BCB++}(*GetPenStyle*){--BCB} - write SetPenStyle; - {* Pen style. } - property PenMode: TPenMode read {-BCB-}fData.Pen.Mode{+BCB+} - {BCB++}(*GetPenMode*){--BCB} - write SetPenMode; - {* Pen mode. } - - property GeometricPen: Boolean read {-BCB-}fData.Pen.Geometric{+BCB+} - {BCB++}(*GetGeometricPen*){--BCB} - write SetGeometricPen; - {* True if Pen is geometric. Note, that under Win95/98 only pen styles - psSolid, psNull, psInsideFrame are supported by OS. } - property PenBrushStyle: TBrushStyle read {-BCB-}fData.Pen.BrushStyle{+BCB+} - {BCB++}(*GetBrushStyle*){--BCB} - write SetBrushStyle; - {* Brush style for hatched geometric pen. } - property PenBrushBitmap: HBitmap read {-BCB-}fData.Pen.BrushBitmap{+BCB+} - {BCB++}(*GetBrushBitmap*){--BCB} - write SetBrushBitmap; - {* Brush bitmap for geometric pen (if assigned Pen is functioning as - its style = BS_PATTERN, regadless of PenBrushStyle value). } - property PenEndCap: TPenEndCap read {-BCB-}fData.Pen.EndCap{+BCB+} - {BCB++}(*GetPenEndCap*){--BCB} - write SetPenEndCap; - {* Pen end cap mode - for GeometricPen only. } - property PenJoin: TPenJoin read {-BCB-}fData.Pen.Join{+BCB+} - {BCB++}(*GetPenJoin*){--BCB} - write SetPenJoin; - {* Pen join mode - for GeometricPen only. } - property LogFontStruct: TLogFont read GetLogFontStruct write SetLogFontStruct; - {* by Alex Pravdin: a property to change all font structure items at once. } - {$ENDIF GDI} - end; - -function Color2RGB( Color: TColor ): TColor; -{* Function to get RGB color from system color. Parameter can be also RGB - color, in that case result is just equal to a parameter. } -function RGB2BGR( Color: TColor ): TColor; -{* Converts RGB color to BGR } -{$IFDEF GTK} -FUNCTION Color2GDKColor( Color: TColor ): TGdkColor; -{$ENDIF GTK} -function ColorsMix( Color1, Color2: TColor ): TColor; -{* Returns color, which RGB components are build as an (approximate) - arithmetic mean of correspondent RGB components of both source - colors (these both are first converted from system to RGB, and - result is always RGB color). Please note: this function is fast, - but can be not too exact. } -{$IFDEF WIN_GDI} -function Color2RGBQuad( Color: TColor ): TRGBQuad; -{* Converts color to RGB, used to represent RGB values in palette entries - (actually swaps R and B bytes). } -function Color2Color16( Color: TColor ): WORD; -{* Converts Color to RGB, packed to word (as it is used in format pf16bit). } -function Color2Color15( Color: TColor ): WORD; -{* Converts Color to RGB, packed to word (as it is used in format pf15bit). } - -var // New TFont instances are intialized with the values in this structure: - DefFont: TGDIFont = ( - Height: 0; - Width: 0; - Escapement: 0; - Orientation: 0; - Weight: 0; - Italic: FALSE; - Underline: FALSE; - StrikeOut: FALSE; - CharSet: 1; - OutPrecision: 0; - ClipPrecision: 0; - Quality: fqDefault; - Pitch: fpDefault; - {$IFDEF UNICODE_CTRLS} - Name: ( 'T', 'a', 'h', 'o', 'm', 'a', - #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, - #0, #0, #0, #0, #0, #0, #0, #0, #0 ); - {$ELSE} - Name: 'System'; - {$ENDIF} - ); - DefFontColor: TColor = clWindowText; - {* Default font color. } - - GlobalGraphics_UseFontOrient: Boolean; - {* Global flag. If stays False (default), Orientation property of Font - objects is ignored. This flag is set to True automatically in - RotateFonts add-on. } - -{$ENDIF WIN_GDI} - -function NewFont: PGraphicTool; -{* Creates and returns font graphic tool object. } -function NewBrush: PGraphicTool; -{* Creates and returns new brush object. } -function NewPen: PGraphicTool; -{* Creates and returns new pen object. } - -{ ------------------------------ TCanvas object ------------------------------ } -const - HandleValid = 1; - PenValid = 2; - BrushValid = 4; - FontValid = 8; - ChangingCanvas = 16; - -{$IFDEF WIN_GDI} -type - TFillStyle = (fsSurface, fsBorder); - {* Available filling styles. For more info see Win32 or Delphi help files. } - TFillMode = (fmAlternate, fmWinding); - {* Available filling modes. For more info see Win32 or Delphi help files. } - TCopyMode = Integer; - {* Available copying modes are following: - | cmBlackness
- | cmDstInvert
- | cmMergeCopy
- | cmMergePaint
- | cmNotSrcCopy
- | cmNotSrcErase
- | cmPatCopy
- | cmPatInvert
- | cmPatPaint
- | cmSrcAnd
- | cmSrcCopy
- | cmSrcErase
- | cmSrcInvert
- | cmSrcPaint
- | cmWhiteness
    - Also it is possible to use any other available ROP2 modes. For more info, - see Win32 help files. } - -const - cmBlackness = BLACKNESS; - cmDstInvert = DSTINVERT; - cmMergeCopy = MERGECOPY; - cmMergePaint = MERGEPAINT; - cmNotSrcCopy = NOTSRCCOPY; - cmNotSrcErase = NOTSRCERASE; - cmPatCopy = PATCOPY; - cmPatInvert = PATINVERT; - cmPatPaint = PATPAINT; - cmSrcAnd = SRCAND; - cmSrcCopy = SRCCOPY; - cmSrcErase = SRCERASE; - cmSrcInvert = SRCINVERT; - cmSrcPaint = SRCPAINT; - cmWhiteness = WHITENESS; - -{$ENDIF WIN_GDI} -type - {$IFDEF _X_} - {$IFDEF GTK} - HDC = PGdkGC; - {$ENDIF GTK} - {$ENDIF _X_} - PCanvas = ^TCanvas; - {* } - TOnGetHandle = function( Canvas: PCanvas ): HDC of object; - {* For internal use mainly. } - TOnTextArea = procedure( Sender: PCanvas; var Size : TSize; var P0 : TPoint ); - {* Event to calculate actual area, occupying by a text. It is used - to optionally extend calculating of TextArea taking into considaration - font Orientation property. } - -{ --------------------------------------------------------------------- - TCanvas - high-level drawing helper object ------------------------------------------------------------------------ } - TCanvas = object( TObj ) - {* Very similar to VCL's TCanvas object. But with some changes, specific - for KOL: there is no necessary to use canvases in all applications. - And graphic tools objects are not created with canvas, but only - if really accessed in program. (Actually, even if paint box used, - only programmer decides, if to implement painting using Canvas or - to call low level API drawing functions working directly with DC). - Therefore TCanvas has some powerful extensions: rotated text support, - geometric pen support - just by changing correspondent properties - of certain graphic tool objects (Font.FontOrientation, Pen.GeometricPen). - See also additional Font properties (Font.FontWeight, Font.FontQuality, - etc. } - protected - fOwnerControl: Pointer; //PControl; - {$IFDEF _X_} - {$IFDEF GTK} - fDrawable: PGdkDrawable; - fTmpColor: PGdkColor; - {$ENDIF GTK} - {$ENDIF _X_} - fHandle : HDC; - fPenPos : TPoint; - fState : Byte; - fBrush, fPen: PGraphicTool; - fFont : PGraphicTool; // order is important for ASM version - {$IFDEF GDI} - fCopyMode : TCopyMode; - fOnChangeCanvas: TOnEvent; - {$ENDIF GDI} - fOnGetHandle: TOnGetHandle; - {$IFDEF _X_} - {$IFDEF GTK} - fSavedState: TGdkGCValues; - PROCEDURE SaveState; - PROCEDURE RestoreState; - {$ENDIF GTK} - {$ENDIF _X_} - {$IFDEF GDI} - procedure SetHandle( Value : HDC ); - {$ENDIF GDI} - procedure SetPenPos( const Value : TPoint ); - {$IFDEF GDI} - procedure CreatePen; - procedure CreateBrush; - procedure CreateFont; - procedure Changing; - {$ENDIF GDI} - procedure ObjectChanged( Sender : PGraphicTool ); - function GetBrush: PGraphicTool; - function GetFont: PGraphicTool; - function GetPen: PGraphicTool; - function GetHandle: HDC; - procedure AssignChangeEvents; - {$IFDEF GDI} - function GetPixels(X, Y: Integer): TColor; - procedure SetPixels(X, Y: Integer; const Value: TColor); - protected - fIsPaintDC : Boolean; - {* TRUE, if DC obtained during current WM_PAINT (or WM_ERASEBKGND?) - processing for a control. This affects a way how Handle is released. } - fIsAlienDC: Boolean; - {* TRUE if Canvas was created on base of existing DC, so DC is not - beloning to the Canvas and should not be deleted when the Canvas object - is destroyed. } - destructor Destroy; virtual; - {* } - {$ENDIF GDI} - property OnGetHandle: TOnGetHandle read fOnGetHandle write fOnGetHandle; - {* For internal use only. } - {$IFDEF GDI} - {$ENDIF GDI} - public - property Handle : HDC read GetHandle {$IFDEF GDI} write SetHandle {$ENDIF GDI}; - {* GDI device context object handle. Never created by - Canvas itself (to use Canvas with memory bitmaps, - always create DC by yourself and assign it to the - Handle property of Canvas object, or use property - Canvas of a bitmap). } - property PenPos : TPoint read FPenPos write SetPenPos; - {* Position of a pen. } - property Pen : PGraphicTool read GetPen; - {* Pen of Canvas object. Do not change its Pen.OnChange event value. } - property Brush : PGraphicTool read GetBrush; - {* Brush of Canvas object. Do not change its Brush.OnChange event value. } - property Font : PGraphicTool read GetFont; - {* Font of Canvas object. Do not change its Font.OnChange event value. } - procedure OffsetAndRotate( Xoff, Yoff: Integer; Angle: Double ); - {* Transforms world coordinates so that Xoff and Yoff become the - coordinates of the origin (0,0) and all further drawing is done - rotated around that point by the Angle (which is given in radians) } - {$IFNDEF NOT_USE_KOLMATH} // if using KOLmath disabled, Arc becomes unavailable - procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall; - {* Draws arc. For more info, see Delphi TCanvas help. } - {$ENDIF NOT_USE_KOLMATH} - {$IFDEF GDI} - procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall; - {* Draws chord. For more info, see Delphi TCanvas help. } - procedure DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); - {* Draws rectangle to represent focused visual object. - For more info, see Delphi TCanvas help. } - procedure Ellipse(X1, Y1, X2, Y2: Integer); - {* Draws an ellipse. For more info, see Delphi TCanvas help. } - {$ENDIF GDI} - procedure FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); - {* Fills rectangle. For more info, see Delphi TCanvas help. } - {$IFDEF GDI} - procedure FillRgn( const Rgn : HRgn ); - {* Fills region. For more info, see Delphi TCanvas help. } - procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle); - {* Fills a figure with givien color, floodfilling its surface. - For more info, see Delphi TCanvas help. } - procedure FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); - {* Draws a rectangle using Brush settings (color, etc.). - For more info, see Delphi TCanvas help. } - {$ENDIF GDI} - procedure MoveTo( X, Y : Integer ); - {* Moves current PenPos to a new position. - For more info, see Delphi TCanvas help. } - procedure LineTo( X, Y : Integer ); - {* Draws a line from current PenPos up to new position. - For more info, see Delphi TCanvas help. } - {$IFDEF GDI} - procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall; - {* Draws a pie. For more info, see Delphi TCanvas help. } - procedure Polygon(const Points: array of TPoint); - {* Draws a polygon. For more info, see Delphi TCanvas help. } - procedure Polyline(const Points: array of TPoint); - {* Draws a bound for polygon. For more info, see Delphi TCanvas help. } - procedure Rectangle(X1, Y1, X2, Y2: Integer); - {* Draws a rectangle using current Pen and/or Brush. - For more info, see Delphi TCanvas help. } - procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer); - {* Draws a rounded rectangle. For more info, see Delphi TCanvas help. } - {$ENDIF GDI} - procedure TextOutA(X, Y: Integer; const Text: AnsiString); stdcall; - {* Draws an ANSI text. For more info, see Delphi TCanvas help. } - procedure TextOut(X, Y: Integer; const Text: KOLString); stdcall; - {* Draws a text. For more info, see Delphi TCanvas help. } - procedure ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: AnsiString; - const Spacing: array of Integer ); - {* } - procedure TextRect(const Rect: TRect; X, Y: Integer; const Text: Ansistring); - {* Draws a text, clipping output into given rectangle. - For more info, see Delphi TCanvas help. } - {$IFDEF GDI} - procedure DrawText(Text: AnsiString; var Rect:TRect; Flags:DWord); - {* } - {$ENDIF GDI} - function TextExtent(const Text: KOLString): TSize; - {* Calculates size of a Text, using current Font settings. - Does not need in Handle for Canvas object (if it is not - yet allocated, temporary device context is created and used. } - procedure TextArea( const Text : KOLString; var Sz : TSize; var P0 : TPoint ); - {* Calculates size and starting point to output Text, - taking into considaration all Font attributes, including - Orientation (only if GlobalGraphics_UseFontOrient flag - is set to True, i.e. if rotated fonts are used). - Like for TextExtent, does not need in Handle (and if this - last is not yet allocated/assigned, temporary device context - is created and used). } - {$IFDEF _D3orHigher} - procedure WTextArea( const Text : KOLWideString; var Sz : TSize; var P0 : TPoint ); - {* Calculates size and starting point to output Text, - taking into considaration all Font attributes, including - Orientation (only if GlobalGraphics_UseFontOrient flag - is set to True, i.e. if rotated fonts are used). - Like for TextExtent, does not need in Handle (and if this - last is not yet allocated/assigned, temporary device context - is created and used). } - {$ENDIF _D3orHigher} - function TextWidth(const Text: KOLString): Integer; - {* Calculates text width (using TextArea). } - function TextHeight(const Text: KOLString): Integer; - {* Calculates text height (using TextArea). } - {$IFDEF GDI} - function ClipRect: TRect; - {* returns ClipBox. by Dmitry Zharov. } - - {$IFNDEF _FPC} - {$IFNDEF _D2} //------- KOLWideString not supported in D2 - procedure WTextOut(X, Y: Integer; const WText: KOLWideString); stdcall; - {* Draws a Unicode text. } - procedure WExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; - const WText: KOLWideString; const Spacing: array of Integer ); - {* } - procedure WDrawText(WText: KOLWideString; var Rect:TRect; Flags:DWord); - {* } - procedure WTextRect(const Rect: TRect; X, Y: Integer; - const WText: KOLWideString); - {* Draws a Unicode text, clipping output into given rectangle. } - function WTextExtent( const WText: KOLWideString ): TSize; - {* Calculates Unicode text width and height. } - function WTextWidth( const WText: KOLWideString ): Integer; - {* Calculates Unicode text width. } - function WTextHeight( const WText: KOLWideString ): Integer; - {* Calculates Unicode text height. } - {$ENDIF _D2} - {$ENDIF _FPC} - - property ModeCopy : TCopyMode read fCopyMode write fCopyMode; - {* Current copy mode. Is used in CopyRect method. } - procedure CopyRect( const DstRect : TRect; SrcCanvas : PCanvas; const SrcRect : TRect ); - {* Copyes a rectangle from source to destination, using StretchBlt. } - property OnChange: TOnEvent read fOnChangeCanvas write fOnChangeCanvas; - {* } - function Assign( SrcCanvas : PCanvas ) : Boolean; - {* } - {$ENDIF GDI} - {$IFDEF _X_} - protected // for _X_ case, RequiredState is protected yet (???) - procedure ForeBack(fg_color, bk_color: TColor); // install colors just before drawing - {$ENDIF _X_} - {$IFDEF GDI} - function RequiredState( ReqState : DWORD ): HDC; stdcall;// public now - {* It is possible to call this method before using Handle property - to pass it into API calls - to provide valid combinations of - pen, brush and font, selected into device context. This method - can not provide valid Handle - You always must create it by - yourself and assign to TCanvas.Handle property manually. - To optimize assembler version, returns Handle value. } - public - {$ENDIF GDI} - procedure DeselectHandles; - {* Call this method to deselect all graphic tool objects from the canvas. } - {$IFDEF GDI} - property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels; - {* Obvious. } - {$ENDIF GDI} - end; - -function NewCanvas( DC: HDC ): PCanvas; -{* Use to construct Canvas on base of memory DC. } - -procedure DummyObjProc( Sender: PObj ); - -var - GlobalCanvas_OnTextArea : Pointer = @DummyObjProc; - {* Global event to extend Canvas with possible add-ons, applied - when rotated fonts are used only (to take into consideration - Font.Orientation property in TextArea method). } - -{$IFDEF WIN_GDI} - -{ ------------------------------ Image list object --------------------------- } - -type - TImageListColors = (ilcColor,ilcColor4,ilcColor8,ilcColor16, - ilcColor24,ilcColor32,ilcColorDDB,ilcDefault); - {* ImageList color schemes available. } - - TDrawingStyles = ( dsBlend25, dsBlend50, dsMask, dsTransparent ); - {* ImageList drawing styles available. } - TDrawingStyle = Set of TDrawingStyles; - {* Style of drawing is a combination of all available drawing styles. } - - TImageType = (itBitmap,itIcon,itCursor); - {* ImageList types available. } - - PImageList = ^TImageList; - {* } - - TImgLOVrlayIdx = 1..15; - -{ --------------------------------------------------------------------- - TImageList - images container ------------------------------------------------------------------------ } - TImageList = object( TObj ) - private - fOverlayIdx: Integer; - {* ImageList incapsulation. } - protected - FHandle: THandle; - FControl: Pointer; // PControl; - fPrev, fNext: PImageList; - FColors: TImageListColors; - FMasked: Boolean; - FImgWidth: Integer; - FImgHeight: Integer; - FDrawingStyle: TDrawingStyle; - FBlendColor: TColor; - fBkColor: TColor; - FAllocBy: Integer; - FShareImages: Boolean; - FOverlay: array[ TImgLOVrlayIdx ] of Integer; - function HandleNeeded : Boolean; - procedure SetColors(const Value: TImageListColors); - procedure SetMasked(const Value: Boolean); - procedure SetImgWidth(const Value: Integer); - procedure SetImgHeight(const Value: Integer); - function GetCount: Integer; - function GetBkColor: TColor; - procedure SetBkColor(const Value: TColor); - function GetBitmap: HBitmap; - function GetMask: HBitmap; - function GetDrawStyle : DWord; - procedure SetAllocBy(const Value: Integer); - function GetHandle: THandle; - function GetOverlay(Idx: TImgLOVrlayIdx): Integer; - procedure SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer); - protected - procedure SetHandle(const Value: THandle); - {*} - public - destructor Destroy; virtual; - {*} - property Handle : THandle read GetHandle write SetHandle; - {* Handle of ImageList object. } - property ShareImages : Boolean read FShareImages write FShareImages; - {* True if images are shared between processes (it is set to True, - if its Handle is assigned to given value, which is a handle of - already existing ImageList object). } - property Colors : TImageListColors read FColors write SetColors; - {* Colors used to represent images. } - property Masked : Boolean read FMasked write SetMasked; - {* True, if mask is used. It is set to True, if first added image - is icon, e.g. } - property ImgWidth : Integer read FImgWidth write SetImgWidth; - {* Width of every image in list. If change, ImageList is cleared. } - property ImgHeight : Integer read FImgHeight write SetImgHeight; - {* Height of every image in list. If change, ImageList is cleared. } - property Count : Integer read GetCount; - {* Number of images in list. } - property AllocBy : Integer read FAllocBy write SetAllocBy; - {* Allocation factor. Default is 1. Set it to size of ImageList if this - value is known - to optimize speed of allocation. } - property BkColor : TColor read GetBkColor write SetBkColor; - {* Background color. } - property BlendColor : TColor read FBlendColor write FBlendColor; - {* Blend color. } - - property Bitmap : HBitmap read GetBitmap; - {* Bitmap, containing all ImageList images (tiled horizontally). } - property Mask : HBitmap read GetMask; - {* Monochrome bitmap, containing masks for all images in list (if not - Masked, always returns nil). } - function ImgRect( Idx : Integer ) : TRect; - {* Rectangle occupied of given image in ImageList. } - - function Add( Bmp, Msk : HBitmap ) : Integer; - {* Adds bitmap and given mask to ImageList. } - function AddMasked( Bmp : HBitmap; Color : TColor ) : Integer; - {* Adds bitmap to ImageList, using given color to create mask. } - function AddIcon( Ico : HIcon ) : Integer; - {* Adds icon to ImageList (always masked). } - procedure Delete( Idx : Integer ); - {* Deletes given image from ImageList. } - procedure Clear; - {* Makes ImageList empty. } - function Replace( Idx : Integer; Bmp, Msk : HBitmap ) : Boolean; - {* Replaces given (by index) image with bitmap and its mask with mask bitmap. } - function ReplaceIcon( Idx : Integer; Ico : HIcon ) : Boolean; - {* Replaces given (by index) image with an icon. } - function Merge( Idx : Integer; ImgList2 : PImageList; Idx2 : Integer; X, Y : Integer ) - : PImageList; - {* Merges two ImageList objects, returns resulting ImageList. } - function ExtractIcon( Idx : Integer ) : HIcon; - {* Extracts icon by index. } - function ExtractIconEx( Idx : Integer ) : HIcon; - {* Extracts icon (is created using current drawing style). } - - property DrawingStyle : TDrawingStyle read FDrawingStyle write FDrawingStyle; - {* Drawing style. } - procedure Draw( Idx : Integer; DC : HDC; X, Y : Integer ); - {* Draws given (by index) image from ImageList onto passed Device Context. } - procedure StretchDraw( Idx : Integer; DC : HDC; const Rect : TRect ); - {* Draws given image with stratching. } - - function LoadBitmap( ResourceName : PKOLChar; TranspColor : TColor ) : Boolean; - {* Loads ImageList from resource. } - //function LoadIcon( ResourceName : PAnsiChar ) : Boolean; - //function LoadCursor( ResourceName : PAnsiChar ) : Boolean; - function LoadFromFile( FileName : PKOLChar; TranspColor : TColor; ImgType : TImageType ) : Boolean; - {* Loads ImageList from file. } - function LoadSystemIcons( SmallIcons : Boolean ) : Boolean; - {* Assigns ImageList to system icons list (big or small). } - - property Overlay[ Idx: TImgLOVrlayIdx ]: Integer read GetOverlay write SetOverlay; - {* Overlay images for image list (images, used as overlay images to draw over - other images from the image list). These overalay images can be used in - listview and treeview as overlaying images (up to four masks at the same - time). } - property OverlayIdx: Integer read fOverlayIdx write fOverlayIdx; - {* Set this value to 1..15 to draw images overlayed (using Draw or DrawEx). } - {$IFDEF USE_CONSTRUCTORS} - constructor CreateImageList( POwner: Pointer ); - {$ENDIF USE_CONSTRUCTORS} - end; - -const - CLR_NONE = $FFFFFFFF; - CLR_DEFAULT = $FF000000; - -type - HImageList = THandle; - -const - ILC_MASK = $0001; - ILC_COLOR = $00FE; - ILC_COLORDDB = $00FE; - ILC_COLOR4 = $0004; - ILC_COLOR8 = $0008; - ILC_COLOR16 = $0010; - ILC_COLOR24 = $0018; - ILC_COLOR32 = $0020; - ILC_PALETTE = $0800; - -const - ILD_NORMAL = $0000; - ILD_TRANSPARENT = $0001; - ILD_MASK = $0010; - ILD_IMAGE = $0020; - ILD_BLEND25 = $0002; - ILD_BLEND50 = $0004; - ILD_OVERLAYMASK = $0F00; - -const - ILD_SELECTED = ILD_BLEND50; - ILD_FOCUS = ILD_BLEND25; - ILD_BLEND = ILD_BLEND50; - CLR_HILIGHT = CLR_DEFAULT; - -function ImageList_Create(CX, CY: Integer; Flags: UINT; - Initial, Grow: Integer): HImageList; stdcall; -function ImageList_Destroy(ImageList: HImageList): Bool; stdcall; -function ImageList_GetImageCount(ImageList: HImageList): Integer; stdcall; -function ImageList_SetImageCount(ImageList: HImageList; Count: Integer): Integer; stdcall; -function ImageList_Add(ImageList: HImageList; Image, Mask: HBitmap): Integer; stdcall; -function ImageList_ReplaceIcon(ImageList: HImageList; Index: Integer; - Icon: HIcon): Integer; stdcall; -function ImageList_SetBkColor(ImageList: HImageList; ClrBk: TColorRef): TColorRef; stdcall; -function ImageList_GetBkColor(ImageList: HImageList): TColorRef; stdcall; -function ImageList_SetOverlayImage(ImageList: HImageList; Image: Integer; - Overlay: Integer): Bool; stdcall; - -function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer; - -function Index2OverlayMask(Index: Integer): Integer; - -function ImageList_Draw(ImageList: HImageList; Index: Integer; - Dest: HDC; X, Y: Integer; Style: UINT): Bool; stdcall; - -function ImageList_Replace(ImageList: HImageList; Index: Integer; - Image, Mask: HBitmap): Bool; stdcall; -function ImageList_AddMasked(ImageList: HImageList; Image: HBitmap; - Mask: TColorRef): Integer; stdcall; -function ImageList_DrawEx(ImageList: HImageList; Index: Integer; - Dest: HDC; X, Y, DX, DY: Integer; Bk, Fg: TColorRef; Style: Cardinal): Bool; stdcall; -function ImageList_Remove(ImageList: HImageList; Index: Integer): Bool; stdcall; -function ImageList_GetIcon(ImageList: HImageList; Index: Integer; - Flags: Cardinal): HIcon; stdcall; -{$IFDEF UNICODE_CTRLS} -function ImageList_LoadImage(Instance: THandle; Bmp: PWideChar; CX, Grow: Integer; - Mask: TColorRef; pType, Flags: Cardinal): HImageList; stdcall; -{$ELSE} -function ImageList_LoadImage(Instance: THandle; Bmp: PAnsiChar; CX, Grow: Integer; - Mask: TColorRef; pType, Flags: Cardinal): HImageList; stdcall; -{$ENDIF} -function ImageList_BeginDrag(ImageList: HImageList; Track: Integer; - XHotSpot, YHotSpot: Integer): Bool; stdcall; -function ImageList_EndDrag: Bool; stdcall; -function ImageList_DragEnter(LockWnd: HWnd; X, Y: Integer): Bool; stdcall; -function ImageList_DragLeave(LockWnd: HWnd): Bool; stdcall; -function ImageList_DragMove(X, Y: Integer): Bool; stdcall; -function ImageList_SetDragCursorImage(ImageList: HImageList; Drag: Integer; - XHotSpot, YHotSpot: Integer): Bool; stdcall; -function ImageList_DragShowNolock(Show: Bool): Bool; stdcall; -function ImageList_GetDragImage(Point, HotSpot: PPoint): HImageList; stdcall; - -{ macros } -procedure ImageList_RemoveAll(ImageList: HImageList); stdcall; -function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList; - Image: Integer): HIcon; stdcall; -function ImageList_LoadBitmap(Instance: THandle; Bmp: PKOLChar; - CX, Grow: Integer; MasK: TColorRef): HImageList; stdcall; - -type - PImageInfo = ^TImageInfo; - TImageInfo = packed record - hbmImage: HBitmap; - hbmMask: HBitmap; - Unused1: Integer; - Unused2: Integer; - rcImage: TRect; - end; - -function ImageList_GetIconSize(ImageList: HImageList; var CX, CY: Integer): Bool; stdcall; -function ImageList_SetIconSize(ImageList: HImageList; CX, CY: Integer): Bool; stdcall; -function ImageList_GetImageInfo(ImageList: HImageList; Index: Integer; - var ImageInfo: TImageInfo): Bool; stdcall; -function ImageList_Merge(ImageList1: HImageList; Index1: Integer; - ImageList2: HImageList; Index2: Integer; DX, DY: Integer)://Bool - ERROR IN VCL - HImageList; stdcall; - -function LoadBmp( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap; -function LoadBmp32( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap; - -type - tagBitmap = Windows.TBitmap; - - TPixelFormat = ( pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, - pf32bit, pfCustom ); - {* Available pixel formats. } - TBitmapHandleType = ( bmDIB, bmDDB ); - {* Available bitmap handle types. } - - PBitmap = ^TBitmap; -{ ---------------------------------------------------------------------- - TBitmap - bitmap image ------------------------------------------------------------------------ } - TBitmap = object( TObj ) - {* Bitmap incapsulation object. } - protected - fHeight: Integer; - fWidth: Integer; - fHandle: HBitmap; - fCanvas: PCanvas; - fScanLineSize: Integer; - fBkColor: TColor; - fApplyBkColor2Canvas: procedure( Sender: PBitmap ); - fDetachCanvas: procedure( Sender: PBitmap ); - fCanvasAttached : Integer; - fHandleType: TBitmapHandleType; - fDIBHeader: PBitmapInfo; - fDIBBits: Pointer; - fDIBSize: Integer; - fNewPixelFormat: TPixelFormat; - fFillWithBkColor: procedure( BmpObj: PBitmap; DC: HDC; oldW, oldH: Integer ); - //stdcall; - fTransMaskBmp: PBitmap; - fTransColor: TColor; - fGetDIBPixels: function( Bmp: PBitmap; X, Y: Integer ): TColor; - fSetDIBPixels: procedure( Bmp: PBitmap; X, Y: Integer; Value: TColor ); - fScanLine0: PByte; - fScanLineDelta: Integer; - fPixelMask: DWORD; - fPixelsPerByteMask: Integer; - fBytesPerPixel: Integer; - fDIBAutoFree: Boolean; - procedure SetHeight(const Value: Integer); - procedure SetWidth(const Value: Integer); - function GetEmpty: Boolean; - function GetHandle: HBitmap; - function GetHandleAllocated: Boolean; - procedure SetHandle(const Value: HBitmap); - procedure SetPixelFormat(Value: TPixelFormat); - procedure FormatChanged; - function GetCanvas: PCanvas; - procedure CanvasChanged( Sender: PObj ); - function GetScanLine(Y: Integer): Pointer; - function GetScanLineSize: Integer; - procedure ClearData; - procedure ClearTransImage; - procedure SetBkColor(const Value: TColor); - function GetDIBPalEntries(Idx: Integer): TColor; - function GetDIBPalEntryCount: Integer; - procedure SetDIBPalEntries(Idx: Integer; const Value: TColor); - procedure SetHandleType(const Value: TBitmapHandleType); - function GetPixelFormat: TPixelFormat; - function GetPixels(X, Y: Integer): TColor; - procedure SetPixels(X, Y: Integer; const Value: TColor); - function GetDIBPixels(X, Y: Integer): TColor; - procedure SetDIBPixels(X, Y: Integer; const Value: TColor); - function GetBoundsRect: TRect; - protected - destructor Destroy; virtual; - public - property Width: Integer read fWidth write SetWidth; - {* Width of bitmap. To make code smaller, avoid changing Width or Height - after bitmap is created (using NewBitmap) or after it is loaded from - file, stream of resource. } - property Height: Integer read fHeight write SetHeight; - {* Height of bitmap. To make code smaller, avoid changing Width or Height - after bitmap is created (using NewBitmap) or after it is loaded from - file, stream of resource. } - property BoundsRect: TRect read GetBoundsRect; - {* Returns rectangle (0,0,Width,Height). } - property Empty: Boolean read GetEmpty; - {* Returns True if Width or Height is 0. } - procedure Clear; - {* Makes bitmap empty, setting its Width and Height to 0. } - procedure LoadFromFile( const Filename: KOLString ); - {* Loads bitmap from file (LoadFromStream used). } - function LoadFromFileEx( const Filename: KOLString ): Boolean; - {* Loads bitmap from a file. If necessary, bitmap is RLE-decoded. Code given - by Vyacheslav A. Gavrik. } - procedure SaveToFile( const Filename: KOLString ); - {* Stores bitmap to file (SaveToStream used). } - procedure CoreSaveToFile( const Filename: KOLString ); - {* Stores bitmap to file (CoreSaveToStream used). } - procedure RLESaveToFile( const Filename: KOLString ); - {* Stores bitmap to file (CoreSaveToStream used). } - procedure LoadFromStream( Strm: PStream ); - {* Loads bitmap from stream. Follow loading, bitmap has DIB format (without - handle allocated). It is possible to draw DIB bitmap without creating - handle for it, which can economy GDI resources. } - function LoadFromStreamEx( Strm: PStream ): Boolean; - {* Loads bitmap from a stream. Difference is that RLE decoding supported. - Code given by Vyacheslav A. Gavrik. } - procedure SaveToStream( Strm: PStream ); - {* Saves bitmap to stream. If bitmap is not DIB, it is converted to DIB - before saving. } - procedure CoreSaveToStream( Strm: PStream ); - {* Saves bitmap to stream using CORE format with RGBTRIPLE palette and - with BITMAPCOREHEADER as a header. - If bitmap is not DIB, it is converted to DIB before saving. } - procedure RLESaveToStream( Strm: PStream ); - {* Saves bitmap to stream using CORE format with RGBTRIPLE palette and - with BITMAPCOREHEADER as a header. - If bitmap is not DIB, it is converted to DIB before saving. } - procedure LoadFromResourceID( Inst: DWORD; ResID: Integer ); - {* Loads bitmap from resource using integer ID of resource. To load by name, - use LoadFromResurceName. To load resource of application itself, pass - hInstance as first parameter. This method also can be used to load system - predefined bitmaps, if 0 is passed as Inst parameter: - |
-       OBM_BTNCORNERS	OBM_REDUCE
-       OBM_BTSIZE       OBM_REDUCED
-       OBM_CHECK        OBM_RESTORE
-       OBM_CHECKBOXES   OBM_RESTORED
-       OBM_CLOSE        OBM_RGARROW
-       OBM_COMBO        OBM_RGARROWD
-       OBM_DNARROW      OBM_RGARROWI
-       OBM_DNARROWD     OBM_SIZE
-       OBM_DNARROWI     OBM_UPARROW
-       OBM_LFARROW      OBM_UPARROWD
-       OBM_LFARROWD     OBM_UPARROWI
-       OBM_LFARROWI     OBM_ZOOM
-       OBM_MNARROW      OBM_ZOOMD
-       |
} - procedure LoadFromResourceName( Inst: DWORD; ResName: PKOLChar ); - {* Loads bitmap from resurce (using passed name of bitmap resource. } - function Assign( SrcBmp: PBitmap ): Boolean; - {* Assigns bitmap from another. Returns False if not success. - Note: remember, that Canvas is not assigned - only bitmap image - is copied. And for DIB, handle is not allocating due this process. } - property Handle: HBitmap read GetHandle write SetHandle; - {* Handle of bitmap. Created whenever property accessed. To check if handle - is allocated (without allocating it), use HandleAllocated property. } - property HandleAllocated: Boolean read GetHandleAllocated; - {* Returns True, if Handle already allocated. } - function ReleaseHandle: HBitmap; - {* Returns Handle and releases it, so bitmap no more know about handle. - This method does not destroy bitmap image, but converts it into DIB. - Returned Handle actually is a handle of copy of original bitmap. If - You need not in keping it up, use Dormant method instead. } - procedure Dormant; - {* Releases handle from bitmap and destroys it. But image is not destroyed - and its data are preserved in DIB format. Please note, that in KOL, DIB - bitmaps can be drawn onto given device context without allocating of - handle. So, it is very useful to call Dormant preparing it using - Canvas drawing operations - to economy GDI resources. } - property HandleType: TBitmapHandleType read fHandleType write SetHandleType; - {* bmDIB, if DIB part of image data is filled and stored internally in - TBitmap object. DIB image therefore can have Handle allocated, which - require resources. Use HandleAllocated funtion to determine if handle - is allocated and Dormant method to remove it, if You want to economy - GDI resources. (Actually Handle needed for DIB bitmap only in case - when Canvas is used to draw on bitmap surface). Please note also, that - before saving bitmap to file or stream, it is converted to DIB. } - property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat; - {* Current pixel format. If format of bitmap is unknown, or bitmap is DDB, - value is pfDevice. Setting PixelFormat to any other format converts - bitmap to DIB, back to pfDevice converts bitmap to DDB again. Avoid - such conversations for large bitmaps or for numerous bitmaps in your - application to keep good performance. } - function BitsPerPixel: Integer; - {* Returns bits per pixel if possible. } - procedure Draw( DC: HDC; X, Y: Integer ); - {* Draws bitmap to given device context. If bitmap is DIB, it is always - drawing using SetDIBitsToDevice API call, which does not require bitmap - handle (so, it is very sensible to call Dormant method to free correspondent - GDI resources). } - procedure StretchDraw( DC: HDC; const Rect: TRect ); - {* Draws bitmap onto DC, stretching it to fit given rectangle Rect. } - procedure DrawTransparent( DC: HDC; X, Y: Integer; TranspColor: TColor ); - {* Draws bitmap onto DC transparently, using TranspColor as transparent. - See function DesktopPixelFormat also. } - procedure StretchDrawTransparent( DC: HDC; const Rect: TRect; TranspColor: TColor ); - {* Draws bitmap onto given rectangle of destination DC (with stretching it - to fit Rect) - transparently, using TranspColor as transparent. - See function DesktopPixelFormat also. } - procedure DrawMasked( DC: HDC; X, Y: Integer; Mask: HBitmap ); - {* Draws bitmap to destination DC transparently by mask. It is possible - to pass as a mask handle of another TBitmap, previously converted to - monochrome mask using Convert2Mask method. } - procedure StretchDrawMasked( DC: HDC; const Rect: TRect; Mask: HBitmap ); - {* Like DrawMasked, but with stretching image onto given rectangle. } - procedure Convert2Mask( TranspColor: TColor ); - {* Converts bitmap to monochrome (mask) bitmap with TranspColor replaced - to clBlack and all other ones to clWhite. Such mask bitmap can be used - to draw original bitmap transparently, with given TranspColor as - transparent. (To preserve original bitmap, create new instance of - TBitmap and assign original bitmap to it). See also DrawTransparent and - StretchDrawTransparent methods. } - procedure Invert; - {* Obvious. } - property Canvas: PCanvas read GetCanvas; - {* Canvas can be used to draw onto bitmap. Whenever it is accessed, handle - is allocated for bitmap, if it is not yet (to make it possible - to select bitmap to display compatible device context). } - procedure RemoveCanvas; - {* Call this method to destroy Canvas and free GDI resources. } - property BkColor: TColor read fBkColor write SetBkColor; - {* Used to fill background for Bitmap, when its width or height is increased. - Although this value always synchronized with Canvas.Brush.Color, use it - instead if You do not use Canvas for drawing on bitmap surface. } - property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels; - {* Allows to obtain or change certain pixels of a bitmap. This method is - both for DIB and DDB bitmaps, and leads to allocate handle anyway. For - DIB bitmaps, it is possible to use property DIBPixels[ ] instead, - which is much faster and does not require in Handle. } - property ScanLineSize: Integer read GetScanLineSize; - {* Returns size of scan line in bytes. Use it to measure size of a single - ScanLine. To calculate increment value from first byte of ScanLine to - first byte of next ScanLine, use difference - ! Integer(ScanLine[1]-ScanLine[0]) - (this is because bitmap can be oriented from bottom to top, so - step can be negative). } - property ScanLine[ Y: Integer ]: Pointer read GetScanLine; - {* Use ScanLine to access DIB bitmap pixels in memory to direct access it - fast. Take in attention, that for different pixel formats, different - bit counts are used to represent bitmap pixels. Also do not forget, that - for formats pf4bit and pf8bit, pixels actually are indices to palette - entries, and for formats pf16bit, pf24bit and pf32bit are actually - RGB values (for pf16bit B:5-G:6-R:5, for pf15bit B:5-G:5-R:5 (high order - bit not used), for pf24bit B:8-G:8-R:8, and for pf32bit high order byte - of TRGBQuad structure is not used). } - property DIBPixels[ X, Y: Integer ]: TColor read GetDIBPixels write SetDIBPixels; - {* Allows direct access to pixels of DIB bitmap, faster then Pixels[ ] - property. Access to read is slower for pf15bit, pf16bit formats (because - some conversation needed to translate packed RGB color to TColor). And - for write, operation performed most slower for pf4bit, pf8bit (searching - nearest color required) and fastest for pf24bit, pf32bit and pf1bit. } - property DIBPalEntryCount: Integer read GetDIBPalEntryCount; - {* Returns palette entries count for DIB image. Always returns 2 for pf1bit, - 16 for pf4bit, 256 for pf8bit and 0 for other pixel formats. } - property DIBPalEntries[ Idx: Integer ]: TColor read GetDIBPalEntries write - SetDIBPalEntries; - {* Provides direct access to DIB palette. } - function DIBPalNearestEntry( Color: TColor ): Integer; - {* Returns index of entry in DIB palette with color nearest (or matching) - to given one. } - property DIBBits: Pointer read fDIBBits; - {* This property is mainly for internal use. } - property DIBSize: Integer read fDIBSize; - {* Size of DIBBits array. } - property DIBHeader: PBitmapInfo read fDIBHeader; - {* This property is mainly for internal use. } - procedure DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect ); - {* This procedure copies given rectangle to the target device context, - but only for DIB bitmap (using SetDIBBitsToDevice API call). } - procedure RotateRight; - {* Rotates bitmap right (90 degree). Bitmap must be DIB. If You definitevely - know format of a bitmap, use instead one of methods RotateRightMono, - RotateRight4bit, RotateRight8bit, RotateRight16bit or RotateRightTrueColor - - this will economy code. But if for most of formats such methods are - called, this can be more economy just to call always universal method - RotateRight. } - procedure RotateLeft; - {* Rotates bitmap left (90 degree). Bitmap must be DIB. If You definitevely - know format of a bitmap, use instead one of methods RotateLeftMono, - RotateLeft4bit, RotateLeft8bit, RotateLeft16bit or RotateLeftTrueColor - - this will economy code. But if for most of formats such methods are - called, this can be more economy just to call always universal method - RotateLeft. } - procedure RotateRightMono; - {* Rotates bitmat right, but only if bitmap is monochrome (pf1bit). } - procedure RotateLeftMono; - {* Rotates bitmap left, but only if bitmap is monochrome (pf1bit). } - procedure RotateRight4bit; - {* Rotates bitmap right, but only if PixelFormat is pf4bit. } - procedure RotateLeft4bit; - {* Rotates bitmap left, but only if PixelFormat is pf4bit. } - procedure RotateRight8bit; - {* Rotates bitmap right, but only if PixelFormat is pf8bit. } - procedure RotateLeft8bit; - {* Rotates bitmap left, but only if PixelFormat is pf8bit. } - procedure RotateRight16bit; - {* Rotates bitmap right, but only if PixelFormat is pf16bit. } - procedure RotateLeft16bit; - {* Rotates bitmap left, but only if PixelFormat is pf16bit. } - procedure RotateRightTrueColor; - {* Rotates bitmap right, but only if PixelFormat is pf24bit or pf32bit. } - procedure RotateLeftTrueColor; - {* Rotates bitmap left, but only if PixelFormat is pf24bit or pf32bit. } - procedure FlipVertical; - {* Flips bitmap vertically } - procedure FlipHorizontal; - {* Flips bitmap horizontally } - procedure CopyRect( const DstRect : TRect; SrcBmp : PBitmap; const SrcRect : TRect ); - {* It is possible to use Canvas.CopyRect for such purpose, but if You - do not want use TCanvas, it is possible to copy rectangle from one - bitmap to another using this function. } - function CopyToClipboard: Boolean; - {* Copies bitmap to clipboard. } - function PasteFromClipboard: Boolean; - {* Takes CF_DIB format bitmap from clipboard and assigns it to the - TBitmap object. } - end; - -function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat; - -function NewBitmap( W, H: Integer ): PBitmap; -{* Creates bitmap object of given size. If it is possible, do not change its - size (Width and Heigth) later - this can economy code a bit. See TBitmap. } -function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap; -{* Creates DIB bitmap object of given size and pixel format. If it is possible, - do not change its size (Width and Heigth) later - this can economy code a bit. - See TBitmap. } -function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer; -{* May be will be useful. } - -var - DefaultPixelFormat: TPixelFormat = pf32bit; //pf16bit; - -function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor ) - : HBitmap; -{* This function can be used to load bitmap and replace some it colors to - desired ones. This function especially useful when loaded by the such way - bitmap is used as toolbar bitmap - to replace some original colors to - system default colors. To use this function properly, the bitmap shoud - be prepared as 16-color bitmap, which uses only system colors. To do so, - create a new 16-color bitmap with needed dimensions in Borland Image Editor - and paste a bitmap image, copyed in another graphic tool, and then save it. - If this is not done, bitmap will not be loaded correctly! } -function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PKOLChar; - const Map: array of TColor ): HBitmap; -{* by Alex Pravdin: like LoadMappedBitmap, but much powerful. It uses - CreateMappedBitmapEx, so it understands any bitmap color format, including - pf24bit. Also, LoadMappedBitmapEx provides auto-destroying loaded resource - when MasterObj is destroyed. } -function CreateMappedBitmap(Instance: THandle; Bitmap: Integer; - Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; stdcall; -{* Creates mapped bitmap replacing colors correspondently to the - ColorMap (each pare of colors defines color replaced and a color - used for replace it in the bitmap). See also CreateMappedBitmapEx. } -function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PKOLChar; Flags: - Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap; -{* By Alex Pravdin. -Creates mapped bitmap independently from bitmap color format (works -correctly with bitmaps having format deeper than 8bit per pixel). } - -type - PIcon = ^TIcon; -{ ---------------------------------------------------------------------- - TIcon - icon image ------------------------------------------------------------------------ } - TIcon = object( TObj ) - {* Object type to incapsulate icon or cursor image. } - protected - {$IFDEF ICON_DIFF_WH} - FWidth: Integer; - FHeight: Integer; - {$ELSE} - FSize : Integer; - {$ENDIF} - FHandle: HIcon; - FShareIcon: Boolean; - procedure SetSize(const Value: Integer); - {$IFDEF ICON_DIFF_WH} - function GetIconSize: Integer; - {$ENDIF} - procedure SetHandle(const Value: HIcon); - function GetHotSpot: TPoint; - function GetEmpty: Boolean; - protected - destructor Destroy; virtual; - public - {$IFDEF ICONLOAD_PRESERVEBMPS} - ImgBmp, MskBmp : PBitmap; - Only_Bmp: Boolean; - {$ENDIF ICONLOAD_PRESERVEBMPS} - property Size : Integer read - {$IFDEF ICON_DIFF_WH} - GetIconSize - {$ELSE} - FSize - {$ENDIF} - write SetSize; - {* Icon dimension (width and/or height, which are equal to each other always). } - {$IFDEF ICON_DIFF_WH} - property Width: Integer read FWidth; - property Height: Integer read FHeight; - {$ENDIF} - property Handle : HIcon read FHandle write SetHandle; - {* Windows icon object handle. } - procedure SetHandleEx( NewHandle: HIcon ); - {* Set Handle without changing Size (Width/Height). } - procedure Clear; - {* Clears icon, freeing image and allocated GDI resource (Handle). } - property Empty: Boolean read GetEmpty; - {* Returns True if icon is Empty. } - property ShareIcon : Boolean read FShareIcon write FShareIcon; - {* True, if icon object is shared and can not be deleted when TIcon object - is destroyed (set this flag is to True, if an icon is obtained from another - TIcon object, for example). } - property HotSpot : TPoint read GetHotSpot; - {* Hot spot point - for cursors. } - procedure Draw( DC : HDC; X, Y : Integer ); - {* Draws icon onto given device context. Icon always is drawn transparently - using its transparency mask (stored internally in icon object). } - procedure StretchDraw( DC : HDC; Dest : TRect ); - {* Draws icon onto given device context with stretching it to fit destination - rectangle. See also Draw. } - procedure LoadFromStream( Strm : PStream ); - {* Loads icon from stream. If stream contains several icons (of - different dimentions), icon with the most appropriate size is loading. } - procedure LoadFromFile( const FileName : KOLString ); - {* Load icon from file. If file contains several icons (of - different dimensions), icon with the most appropriate size is loading. } - procedure LoadFromResourceID( Inst: Integer; ResID: Integer; DesiredSize: Integer ); - {* Loads icon from resource. To load system default icon, pass 0 as Inst and - one of followin values as ResID: - |
-       IDI_APPLICATION  Default application icon.
-       IDI_ASTERISK     Asterisk (used in informative messages).
-       IDI_EXCLAMATION  Exclamation point (used in warning messages).
-       IDI_HAND         Hand-shaped icon (used in serious warning messages).
-       IDI_QUESTION     Question mark (used in prompting messages).
-       IDI_WINLOGO      Windows logo.
-       |
It is also possible to load icon from resources of another module, - if pass instance handle of loaded module as Inst parameter. } - procedure LoadFromResourceName( Inst: Integer; ResName: PKOLChar; DesiredSize: Integer ); - {* Loads icon from resource. To load own application resource, pass - hInstance as Inst parameter. It is possible to load resource from - another module, if pass its instance handle as Inst. } - procedure LoadFromExecutable( const FileName: KOLString; IconIdx: Integer ); - {* Loads icon from executable (exe or dll file). Always default sized icon - is loaded. It is possible also to get know how much icons are contained - in executable using gloabl function GetFileIconCount. To obtain icon of - another size, try to load given executable and use LoadFromResourceID - method. } - procedure SaveToStream( Strm : PStream ); - {* Saves single icon to stream. To save icons with several different - dimensions, use global procedure SaveIcons2Stream. } - procedure SaveToFile( const FileName : KOLString ); - {* Saves single icon to file. To save icons with several different - dimensions, use global procedure SaveIcons2File. } - function Convert2Bitmap( TranColor: TColor ): HBitmap; - {* Converts icon to bitmap, returning Windows GDI bitmap resource as - a result. It is possible later to assign returned bitmap handle to - Handle property of TBitmap object to use features of TBitmap. - Pass TranColor to replace transparent area of icon with given color. } - end; - - procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream ); - {* Saves several icons (of different dimentions) to stream. } - function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean; - {* Saves icons creating it from pairs of bitmaps and their masks. - BmpHandles array must contain pairs of bitmap handles, each pair - of color bitmap and mask bitmap of the same size. } - procedure SaveIcons2File( const Icons : array of PIcon; const FileName : KOLString ); - {* Saves several icons (of different dimentions) to file. (Single file - with extension .ico can contain several different sized icon images - to use later one with the most appropriate size). } - - function NewIcon: PIcon; - {* Creates new icon object, setting its Size to 32 by default. Created icon - is Empty. } - function GetFileIconCount( const FileName: KOLString ): Integer; - {* Returns number of icon resources stored in given (executable) file. } - -type - TIconHeader = packed record - idReserved: Word; (* Always set to 0 *) - idType: Word; (* Always set to 1 *) - idCount: Word; (* Number of icon images *) - (* immediately followed by idCount TIconDirEntries *) - end; - - TIconDirEntry = packed record - bWidth: Byte; (* Width *) - bHeight: Byte; (* Height *) - bColorCount: Byte; (* Nr. of colors used *) - bReserved: Byte; (* not used, 0 *) - wPlanes: Word; (* not used, 0 *) - wBitCount: Word; (* not used, 0 *) - dwBytesInRes: Longint; (* total number of bytes in images *) - dwImageOffset: Longint;(* location of image from the beginning of file *) - end; - -function LoadImgIcon( RsrcName: PKOLChar; Size: Integer ): HIcon; -{* Loads icon of specified size from the resource. } - -//////////////////////////////////////////////////////////////////////////////// -// UNIVERSAL CONTROL OBJECT // -//////////////////////////////////////////////////////////////////////////////// - -const - CM_EXECPROC = $8FFF; - CM_BASE = $B000; - CM_ACTIVATE = CM_BASE + 0; - CM_DEACTIVATE = CM_BASE + 1; - CM_ENTER = CM_BASE + 2; - CM_RELEASE = CM_BASE + 3; - CM_QUIT = CM_BASE + 4; - CM_COMMAND = CM_BASE + 5; - CM_MEASUREITEM = CM_BASE + 6; - CM_DRAWITEM = CM_BASE + 7; - CM_TRAYICON = CM_BASE + 8; - CM_INVALIDATE = CM_BASE + 9; - CM_UPDATE = CM_BASE + 10; - CM_NCUPDATE = CM_BASE + 11; - CM_SIZEPOS = CM_BASE + 12; - CM_SIZE = CM_BASE + 13; - CM_SETFOCUS = CM_BASE + 14; - CM_CBN_SELCHANGE = 15; - - CM_UIACTIVATE = CM_BASE + 16; - CM_UIDEACTIVATE = CM_BASE + 17; - CM_PROCESS = CM_BASE + 18; - CM_SHOW = CM_BASE + 19; - - CM_AUTOSIZE = CM_BASE + 20; - CM_MDIClientShowEdge = CM_BASE + 21; - - CM_INVALIDATECHILD = CM_BASE + 22; - CM_FOCUSGRAPHCTL = CM_BASE + 23; - - WM_SYNCPAINT = $88; - - CN_BASE = $BC00; - CN_CHARTOITEM = CN_BASE + WM_CHARTOITEM; - CN_COMMAND = CN_BASE + WM_COMMAND; - CN_COMPAREITEM = CN_BASE + WM_COMPAREITEM; - - CN_CTLCOLORMSGBOX = CN_BASE + WM_CTLCOLORMSGBOX; - CN_CTLCOLOREDIT = CN_BASE + WM_CTLCOLOREDIT; - CN_CTLCOLORLISTBOX = CN_BASE + WM_CTLCOLORLISTBOX; - CN_CTLCOLORBTN = CN_BASE + WM_CTLCOLORBTN; - CN_CTLCOLORDLG = CN_BASE + WM_CTLCOLORDLG; - CN_CTLCOLORSCROLLBAR = CN_BASE + WM_CTLCOLORSCROLLBAR; - CN_CTLCOLORSTATIC = CN_BASE + WM_CTLCOLORSTATIC; - - CN_DELETEITEM = CN_BASE + WM_DELETEITEM; - CN_DRAWITEM = CN_BASE + WM_DRAWITEM; - CN_HSCROLL = CN_BASE + WM_HSCROLL; - CN_MEASUREITEM = CN_BASE + WM_MEASUREITEM; - CN_PARENTNOTIFY = CN_BASE + WM_PARENTNOTIFY; - CN_VKEYTOITEM = CN_BASE + WM_VKEYTOITEM; - CN_VSCROLL = CN_BASE + WM_VSCROLL; - CN_KEYDOWN = CN_BASE + WM_KEYDOWN; - CN_KEYUP = CN_BASE + WM_KEYUP; - CN_CHAR = CN_BASE + WM_CHAR; - CN_SYSKEYDOWN = CN_BASE + WM_SYSKEYDOWN; - CN_SYSCHAR = CN_BASE + WM_SYSCHAR; - CN_NOTIFY = CN_BASE + WM_NOTIFY; - -{$ENDIF WIN_GDI} -const - ID_SELF: array[ 0..5 ] of KOLChar = ( 'S','E','L','F','_',#0 ); - {* Identifier for window property "Self", stored directly in window, when - it is created. This property is used to [fast] find TControl object, - correspondent to given window handle (using API call GetProp). } - -{$IFDEF WIN_GDI} - ID_PREVPROC: array[ 0..9 ] of KOLChar = ( 'P','R','E','V','_','P','R','O','C',#0 ); - {$IFNDEF USE_FLAGS} - RADIO_LAST: array[ 0..7 ] of KOLChar = ( 'R','A','D','_','L','S','T',#0 ); - RADIO_1ST: array[ 0..7 ] of KOLChar = ( 'R','A','D','_','1','S','T',#0 ); - {$ENDIF} - MIN_WND: array[ 0..7 ] of KOLChar = ( 'M','I','N','_','W','N','D',#0 ); - DFLT_BTN: array[ 0..7 ] of KOLChar = ( 'D','F','L','T','_','B','T',#0 ); - CNCL_BTN: array[ 0..7 ] of KOLChar = ( 'C','N','C','L','_','B','T',#0 ); - DRAG_XY: array[ 0..7 ] of KOLChar = ( 'D','R','A','G','_','X','Y',#0 ); - MDI_CHLDRN: array[ 0..10 ] of KOLChar = ( 'M','D','I','_','C','H','L','D','R','N',#0 ); - -{$ENDIF WIN_GDI} -const - MK_LBUTTON = 1; - MK_RBUTTON = 2; - MK_SHIFT = 4; - MK_CONTROL = 8; - MK_MBUTTON = $10; - MK_ALT = $20; // MK_ALT DEFINED - MK_LOCK = $40; // CAPS LOCK or SHIFT LOCK -{$IFDEF WIN_GDI} - -{$IFNDEF NOT_USE_RICHEDIT} -type - {$IFDEF UNICODE_CTRLS} - TCharFormat2 = TCharFormat2W; - {$ELSE} - {$IFDEF _D3orHigher} - TCharFormat2 = TCharFormat2A; - {$ELSE} // Delphi2 - TCharFormat2 = packed record - cbSize: UINT; - dwMask: DWORD; - dwEffects: DWORD; - yHeight: Longint; - yOffset: Longint; - crTextColor: TColorRef; - bCharSet: Byte; - bPitchAndFamily: Byte; - szFaceName: array[0..LF_FACESIZE - 1] of KOLChar; - R2Bytes: Word; - wWeight: Word; { Font weight (LOGFONT value) } - sSpacing: Smallint; { Amount to space between letters } - crBackColor: TColorRef; { Background color } - lid: LCID; { Locale ID } - dwReserved: DWORD; { Reserved. Must be 0 } - sStyle: Smallint; { Style handle } - wKerning: Word; { Twip size above which to kern char pair } - bUnderlineType: Byte; { Underline type } - bAnimation: Byte; { Animated text like marching ants } - bRevAuthor: Byte; { Revision author index } - bReserved1: Byte; - end; {$ENDIF _D3orHigher} - {$ENDIF} - - PParaFormat2 = ^TParaFormat2; - TParaFormat2 = packed record - cbSize: UINT; - dwMask: DWORD; - wNumbering: Word; - wReserved: Word; - dxStartIndent: Longint; - dxRightIndent: Longint; - dxOffset: Longint; - wAlignment: Word; - cTabCount: Smallint; - rgxTabs: array [0..MAX_TAB_STOPS - 1] of Longint; - dySpaceBefore: Longint; { Vertical spacing before para } - dySpaceAfter: Longint; { Vertical spacing after para } - dyLineSpacing: Longint; { Line spacing depending on Rule } - sStyle: Smallint; { Style handle } - bLineSpacingRule: Byte; { Rule for line spacing (see tom.doc) } - bCRC: Byte; { Reserved for CRC for rapid searching } - wShadingWeight: Word; { Shading in hundredths of a per cent } - wShadingStyle: Word; { Nibble 0: style, 1: cfpat, 2: cbpat } - wNumberingStart: Word; { Starting value for numbering } - wNumberingStyle: Word; { Alignment, roman/arabic, (), ), ., etc. } - wNumberingTab: Word; { Space bet 1st indent and 1st-line text } - wBorderSpace: Word; { Space between border and text (twips) } - wBorderWidth: Word; { Border pen width (twips) } - wBorders: Word; { Byte 0: bits specify which borders } - { Nibble 2: border style, 3: color index } - end; - - TGetTextLengthEx = packed record - flags: DWORD; { flags (see GTL_XXX defines) } - codepage: UINT; { code page for translation (CP_ACP for default, - 1200 for Unicode } - end; - -const - PFM_SPACEBEFORE = $00000040; - PFM_SPACEAFTER = $00000080; - PFM_LINESPACING = $00000100; - PFM_STYLE = $00000400; - PFM_BORDER = $00000800; { (*) } - PFM_SHADING = $00001000; { (*) } - PFM_NUMBERINGSTYLE = $00002000; { (*) } - PFM_NUMBERINGTAB = $00004000; { (*) } - PFM_NUMBERINGSTART = $00008000; { (*) } - - PFM_RTLPARA = $00010000; - PFM_KEEP = $00020000; { (*) } - PFM_KEEPNEXT = $00040000; { (*) } - PFM_PAGEBREAKBEFORE = $00080000; { (*) } - PFM_NOLINENUMBER = $00100000; { (*) } - PFM_NOWIDOWCONTROL = $00200000; { (*) } - PFM_DONOTHYPHEN = $00400000; { (*) } - PFM_SIDEBYSIDE = $00800000; { (*) } - - PFM_TABLE = $c0000000; { (*) } - EM_REDO = WM_USER + 84; - EM_AUTOURLDETECT = WM_USER + 91; - EM_GETAUTOURLDETECT = WM_USER + 92; - CFM_UNDERLINETYPE = $00800000; { (*) } - CFM_HIDDEN = $0100; { (*) } - CFM_BACKCOLOR = $04000000; - CFE_AUTOBACKCOLOR = CFM_BACKCOLOR; - GTL_USECRLF = 1; { compute answer using CRLFs for paragraphs } - GTL_PRECISE = 2; { compute a precise answer } - GTL_CLOSE = 4; { fast computation of a "close" answer } - GTL_NUMCHARS = 8; { return the number of characters } - GTL_NUMBYTES = 16; { return the number of _bytes_ } - EM_GETTEXTLENGTHEX = WM_USER + 95; - EM_SETLANGOPTIONS = WM_USER + 120; - EM_GETLANGOPTIONS = WM_USER + 121; - - EM_SETEDITSTYLE = $400 + 204; - EM_GETEDITSTYLE = $400 + 205; - - SES_EMULATESYSEDIT = 1; - SES_BEEPONMAXTEXT = 2; - SES_EXTENDBACKCOLOR = 4; - SES_MAPCPS = 8; - SES_EMULATE10 = 16; - SES_USECRLF = 32; - SES_USEAIMM = 64; - SES_NOIME = 128; - SES_ALLOWBEEPS = 256; - SES_UPPERCASE = 512; - SES_LOWERCASE = 1024; - SES_NOINPUTSEQUENCECHK = 2048; - SES_BIDI = 4096; - SES_SCROLLONKILLFOCUS = 8192; - SES_XLTCRCRLFTOCR = 16384; - - EM_GETSCROLLPOS = WM_USER + 221; - EM_SETSCROLLPOS = WM_USER + 222; - EM_GETZOOM = WM_USER + 224; - EM_SETZOOM = WM_USER + 225; -{$ENDIF NOT_USE_RICHEDIT} -{$ENDIF WIN_GDI} - -const - idx_fOnMessage = 0; - idx_fOldOnMessage = 1; - idx_fOnClick = 2; - idx_fOnMouseDown = 3; - idx_fOnMouseUp = 4; - idx_fOnMouseMove = 5; - idx_fOnMouseDblClk = 6; - idx_fOnMouseWheel = 7; - idx_fOnMouseEnter = 8; - idx_fOnMouseLeave = 9; - idx_fOnTestMouseOver = 10; - idx_fGraphCtlMouseEvent = 11; - idx_fMouseLeaveProc = 12; - idx_fOnScroll = 13; - idx_fOnChar = 14; - idx_fOnDeadChar = 15; - idx_fOnKeyUp = 16; - idx_fOnKeyDown = 17; - idx_fOnChangeCtl = 18; - idx_fOnEnter = 19; - idx_fOnLeave = 20; - idx_fLeave = 21; - idx_fOnPaint = 22; - idx_fOnPaint2 = 23; - idx_fOnPrepaint = 24; - idx_fOnPostPaint = 25; - idx_fPaintProc = 26; - idx_fOnEraseBkgnd = 27; - idx_fOnDrawItem = 28; - idx_fOnMeasureItem = 29; - idx_fDragCallback = 30; - idx_fOnSelChange = 31; - idx_fOnResize = 32; - idx_fOnHide = 33; - idx_fOnShow = 34; - idx_fOnClose = 35; - idx_fOnMove = 36; - idx_fOnMoving = 37; - idx_fOnHelp = 38; - idx_fOnQueryEndSession = 39; - idx_fOnMinimize = 40; - idx_fOnMaximize = 41; - idx_fOnRestore = 42; - idx_fOnLVCustomDraw = 43; - idx_fOnEndEditLVITem = 44; - idx_fOnLVData = 45; - idx_fOnCompareLVItems = 46; - idx_FOnLVStateChange = 47; - idx_fOnDeleteLVItem = 48; - idx_fOnColumnClick = 49; - idx_FOnSBBeforeScroll = 50; - idx_FOnSBScroll = 51; - idx_FOnDropDown = 52; - idx_FOnCloseUp = 53; - idx_FOnSplit = 54; - idx_FOnProgress = 55; - idx_FOnBitBtnDraw = 56; - idx_FOnTVBeginDrag = 57; - idx_FOnTVBeginEdit = 58; - - idx_FOnTVEndEdit = 59; - idx_FOnTVExpanding = 60; - idx_FOnTVExpanded = 61; - idx_FOnTVSelChanging = 62; - - idx_FOnTVDelete = 63; - idx_FOnDTPUserString = 64; - idx_FOnREInsModeChg = 65; - idx_FOnREOverURL = 66; - idx_FOnREURLClick = 67; - idx_fOnDropFiles = 68; - - idx_LastEvent = 68; - - idx_fWndFunc = 69; - idx_fDoInvalidate = 70; - idx_fOnDynHandlers = 71; - idx_fPass2DefProc = 72; - idx_fWndProcKeybd = 73; - idx_fControlClick = 74; - idx_fAutoSize = 75; - //{-2.95}//idx_fWndProcResizeFlicks - idx_fGotoControl = 76; - idx_fNotifyChild = 77; - idx_fScrollChildren = 78; - //idx_FBitBtnGetCaption - //idx_FBitBtnExtDraw - idx_fCreateWndExt = 79; - idx_fExMsgProc = 80; - idx_LastProc = 80; - -const - ANCHOR_LEFT = 1; - ANCHOR_RIGHT = 2; - ANCHOR_TOP = 4; - ANCHOR_BOTTOM = 8; - SELF_REQ_PAINT = 16; - PARENT_REQ_PAINT = 32; - MDI_NOT_AVAILABLE = 64; - MDI_DESTROYING = 128; - -type -/////////////////////////////////////////// -{$ifndef _D6orHigher} // -/////////////////////////////////////////// - TMethod = packed record - {* Is defined here because using of VCL classes.pas unit is - not recommended in XCL. This record type is used often - to set/access event handlers, referring to a procedure - of object (usually to set such event to an ordinal - procedure setting Data field to nil. } - Code: Pointer; // Pointer to method code. - {* If used to fake assigning to event handler of type 'procedure - of object' with ordinal procedure pointer, use symbol '@' - before method: - |
       - | Method.Code := @MyProcedure; - | } - Data: Pointer; // Pointer to object, owning the method. - {* To fake event of type 'procedure of object' with setting it to - ordinal procedure assign here NIL; } - end; - {* When assigning TMethod record to event handler, typecast it with - desired event type, e.g.: - |
       - | SomeObject.OnSomeEvent := TOnSomeEvent( Method ); - |
} -/////////////////////////////////////////// -{$endif} // -/////////////////////////////////////////// - PMethod = ^TMethod; - {* } - - function MakeMethod( Data, Code: Pointer ): TMethod; - {* Help function to construct TMethod record. Can be useful to - assign regular type procedure/function as event handler for - event, defined as object method (do not forget, that in that - case it must have first dummy parameter to replace @Self, - passed in EAX to methods of object). } - -type - T3Style = ( F3_Maximize, F3_ClipChildren, F3_ClipSiblings, - F3_Disabled, F3_Visible, F3_Minimize, - F3_Child, F3_Popup ); - T3Styles = Set of T3Style; - - T2Style = ( F2_Tabstop, F2_Group, F2_Thickframe, F2_Sysmenu, - F2_HScroll, F2_VScroll, F2_Dlgframe, F2_Border ); - T2Styles = Set of T2Style; - - TStyle = packed record - CASE Integer OF - 1: ( - f0_Style: Byte; - f1_Style: Byte; - f2_Style: T2Styles; - f3_Style: T3Styles; - ); - 2: ( Value: DWORD; ); - end; - - T1Flag = ( G1_WordWrap, G1_PreventResize, G1_IconShared, - G1_IgnoreWndCaption, G1_SizeRedraw, G1_IsStaticControl, - G1_CanNotDoublebuf, G1_HasRadio ); // - T1Flags = Set of T1Flag; - - T2Flag = ( G2_Transparent, G2_DoubleBuffered, G2_ClassicTransparent, - G2_Destroying, G2_BeginDestroying, - G2_ChangedPos, G2_ChangedW, G2_ChangedH ); // - T2Flags = Set of T2Flag; - - T3Flag = ( G3_ClassicTransparent, G3_IsForm, G3_SizeGrip, G3_IsControl, - G3_IsApplet, G3_IsMDIChild, G3_Flat, G3_MouseInCtl ); // - T3Flags = Set of T3Flag; - - T4Flag = ( G4_CreateHidden, G4_VisibleWOParent, G4_NotUseAlign, - G4_CreateVisible, G4_Pushed, G4_Checked, G4_Hot, G4_Pressed ); // - // use G4_Pushed also as KeyPreviewing for form - T4Flags = Set of T4Flag; - - T5Flag = ( G5_IsButton, G5_IsBitBtn, G5_IsSplitter, G5_IsGroupbox, - G5_IsCommonCtl, G5_3ButtonPress, G5_EraseBkgnd, G5_IgnoreDefault ); - T5Flags = Set of T5Flag; - - T6Flag = ( G6_KeyPreview, G6_DefaultBtn, G6_CancelBtn, G6_Focused, - G6_GraphicCtl, G6_CtlClassNameChg, G6_RightClick, G6_Dragging ); - T6Flags = Set of T6Flag; - - PControl = ^TControl; - {* Type of pointer to TControl visual object. All - | - constructing functions - | - New[ControlName] are returning - pointer of this type. Do not forget about some difference - of using objects from using classes. Identifier Self for - methods of object is not of pointer type, and to pass - pointer to Self, it is necessary to pass @Self instead. - At the same time, to use pointer to object in 'WITH' operator, - it is necessary to apply suffix '^' to pointer to get know - to compiler, what do You want. } -{$IFDEF WIN} - TWindowFunc = function( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; - {* Event type to define custom extended message handlers (as pointers to - procedure entry points). Such handlers are usually defined like add-ons, - extending behaviour of certain controls and attached using AttachProc - method of TControl. If the handler detects, that it is necessary to stop - further message processing, it should return True. } -{$ENDIF WIN} - - TMouseButton = ( mbNone, mbLeft, mbRight, mbMiddle ); - {* Available mouse buttons. mbNone is useful to get know, that - there were no mouse buttons pressed. } - - TMouseEventData = packed Record - {* Record to pass it to mouse handling routines, assigned to OnMouseXXXX - events. } - Button: TMouseButton; - StopHandling: Boolean; // Set it to True in OnMouseXXXX event handler to - // stop further processing - R1, R2: Byte; // Not used - Shift : DWORD; // HiWord( Shift ) = zDelta in WM_MOUSEWHEEL - X, Y : SmallInt; - end; - - TOnMouse = procedure( Sender: PControl; var Mouse: TMouseEventData ) of object; - {* Common mouse handling event type. } - - TOnKey = procedure( Sender: PControl; var Key: Longint; Shift: DWORD ) of object; - {* Key events. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT. - (See GetShiftState funtion). } - - TOnChar = procedure( Sender: PControl; var Key: KOLChar; Shift: DWORD ) of object; - {* Char event. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT. } - - TTabKey = ( tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ); - {* Available tabulating key groups. } - TTabKeys = Set of TTabKey; - {* Set of tabulating key groups, allowed to be used in with a control - (are installed by TControl.LookTabKey property). } - -{$IFDEF WIN} - TOnMessage = function( var Msg: TMsg; var Rslt: Integer ): Boolean of object; - {* Event type for events, which allows to extend behaviour of windowed controls - descendants using add-ons. } -{$ENDIF WIN} - - TOnEventAccept = procedure( Sender: PObj; var Accept: Boolean ) of object; - {* Event type for OnClose event. } - TCloseQueryReason = ( qClose, qShutdown, qLogoff ); - {* Request reason type to call OnClose and OnQueryEndSession. } - TWindowState = ( wsNormal, wsMinimized, wsMaximized ); - {* Avalable states of TControl's window object. } - - TOnSplit = function( Sender: PControl; NewSize1, NewSize2: Integer ): Boolean of object; - {* Event type for OnSplit event handler, designed specially for splitter - control. Event handler must return True to accept new size of previous - (to splitter) control and new size of the rest of client area of parent. } - - TOnTVBeginDrag = procedure( Sender: PControl; Item: THandle ) of object; - {* Event type for OnTVBeginDrag event (defined for tree view control). } - TOnTVBeginEdit = function( Sender: PControl; Item: THandle ): Boolean of object; - {* Event type for OnTVBeginEdit event (for tree view control). } - TOnTVEndEdit = function( Sender: PControl; Item: THandle; const NewTxt: KOL_String ) - : Boolean of object; - {* Event type for TOnTVEndEdit event. } - TOnTVExpanding = function( Sender: PControl; Item: THandle; Expand: Boolean ) - : Boolean of object; - {* Event type for TOnTVExpanding event. } - TOnTVExpanded = procedure( Sender: PControl; Item: THandle; Expand: Boolean ) - of object; - {* Event type for OnTVExpanded event. } - TOnTVDelete = procedure( Sender: PControl; Item: THandle ) of object; - {* Event type for OnTVDelete event. } - - //--------- by Sergey Shisminzev : - TOnTVSelChanging = function(Sender: PControl; oldItem, newItem: THandle): Boolean //~ss - of object; - {* When the handler returns False, selection is not changed. } - //------------------------------- - TOnDrag = function( Sender: PControl; ScrX, ScrY: Integer; var CursorShape: Integer; - var Stop: Boolean ): Boolean of object; - {* Event, called during dragging operation (it is initiated - with method Drag, where callback function of type TOnDrag is - passed as a parameter). Callback function receives Stop parameter True, - when operation is finishing. Otherwise, it can set it to True to force - finishing the operation (in such case, returning False means cancelling - drag operation, True - successful drag and in this last case callback is - no more called). During the operation, when input Stop value is False, - callback function can control Cursor shape, and return True, if the operation - can be finished successfully at the given ScrX, ScrY position. - ScrX, ScrY are screen coordinates of the mouse cursor. } - -{$IFDEF WIN} - TCreateParams = packed record - {* Record to pass it through CreateSubClass method. } - Caption: PKOLChar; - Style: cardinal; - ExStyle: cardinal; - X, Y: Integer; - Width, Height: Integer; - WndParent: HWnd; - Param: Pointer; - WindowClass: TWndClass; - WinClassName: array[0..63] of KOLChar; - end; - - TCreateWndParams = packed Record - ExStyle: DWORD; - WinClassName: PKOLChar; - Caption: PKOLChar; - Style: DWORD; - X, Y, Width, Height: Integer; - WndParent: HWnd; - Menu: HMenu; - Inst: THandle; - Param: Pointer; - WinClsNamBuf: array[ 0..63 ] of KOLChar; - WindowClass: TWndClass; - end; - - PCommandActions = ^TCommandActions; - TCommandActions = packed Record - aClear: procedure( Sender: PControl ); - aAddText: procedure( Sender: PControl; const S: AnsiString ); - aClick, aEnter, aLeave: WORD; - aChange: SmallInt; aSelChange: SmallInt; - aGetCount, aSetCount, aGetItemLength, aGetItemText, aSetItemText, - aGetItemData, aSetItemData: WORD; - aAddItem, aDeleteItem, aInsertItem: WORD; - aFindItem, aFindPartial: WORD; - bItem2Pos, bPos2Item: BYTE; - aGetSelCount, aGetSelected, aGetSelRange, - aGetCurrent, - aSetSelected, aSetCurrent, aSetSelRange, aExSetSelRange, - aGetSelection, aReplaceSel: WORD; - aTextAlignLeft, aTextAlignRight, aTextAlignCenter: WORD; - bTextAlignMask: Byte; - bVertAlignTop, bVertAlignCenter, bVertAlignBottom: Byte; - aDir, aSetLimit: Word; aSetImgList: Word; - aSetBkColor: Word; - aItem2XY: Word; - end; - - {$IFDEF COMMANDACTIONS_OBJ} - PCommandActionsObj = ^TCommandActionsObj; - TCommandActionsObj = object(TObj) - aClear: procedure( Sender: PControl ); - aAddText: procedure( Sender: PControl; const S: KOLString ); - aClick, aEnter, aLeave: WORD; - aChange: SmallInt; aSelChange: SmallInt; - aGetCount, aSetCount, aGetItemLength, aGetItemText, aSetItemText, - aGetItemData, aSetItemData: WORD; - aAddItem, aDeleteItem, aInsertItem: WORD; - aFindItem, aFindPartial: WORD; - bItem2Pos, bPos2Item: BYTE; - aGetSelCount, aGetSelected, aGetSelRange, - aGetCurrent, - aSetSelected, aSetCurrent, aSetSelRange, aExSetSelRange, - aGetSelection, aReplaceSel: WORD; - aTextAlignLeft, aTextAlignRight, aTextAlignCenter: WORD; - bTextAlignMask: Byte; - bVertAlignTop, bVertAlignCenter, bVertAlignBottom: Byte; - aDir, aSetLimit: Word; aSetImgList: Word; - aSetBkColor: Word; - aItem2XY: Word; - fIndexInActions: Integer; - destructor Destroy; virtual; - end; - {$ENDIF} -{$ENDIF WIN} - - TTextAlign = ( taLeft, taRight, taCenter ); - {* Text alignments available. } - TRichTextAlign = ( raLeft, raRight, raCenter, - // all other are only set but can not be displayed: - raJustify, // displayed like raLeft (though stored normally) - raInterLetter, raScaled, raGlyphs, raSnapGrid ); - {* Text alignment styles, available for RichEdit control. } - TVerticalAlign = ( vaTop, vaCenter, vaBottom ); - {* Vertical alignments available. } - TControlAlign = ( caNone, caLeft, caTop, caRight, caBottom, caClient ); - {* Control alignments available. } - TAligning = (oaWaitAlign,oaFromSelf,oaAligning); - TAlignings = set of TAligning; - - TBitBtnOption = ( bboImageList, - bboNoBorder, - bboNoCaption, - bboFixed, - bboFocusRect ); - {* Options available for NewBitBtn. } - TBitBtnOptions = set of TBitBtnOption; - {* Set of options, available for NewBitBtn. } - TGlyphLayout = ( glyphLeft, glyphTop, glyphRight, glyphBottom, glyphOver ); - {* Layout of glyph (for NewBitBtn). Layout glyphOver means that text is - drawn over glyph. } - TOnBitBtnDraw = function( Sender: PControl; BtnState: Integer ): Boolean of object; - {* Event type for TControl.OnBitBtnDraw event (which is called just before - drawing the BitBtn). If handler returns True, there are no drawing occure. - BtnState, passed to a handler, determines current button state and can - be following: 0 - not pressed, 1 - pressed, 2 - disabled, 3 - focused. - Value 4 is reserved for highlight state (then mouse is over it), but - highlighting is provided only if property Flat is set to True (or one - of events OnMouseEnter / OnMouseLeave is assigned to something). } - - TListViewStyle = ( lvsIcon, lvsSmallIcon, lvsList, lvsDetail, lvsDetailNoHeader ); - {* Styles of view for ListView control (see NewListVew). } - - TListViewItemStates = ( lvisFocus, lvisSelect, lvisBlend, lvisHighlight ); - TListViewItemState = Set of TListViewItemStates; - TListViewOption = ( - lvoIconLeft, // in lvsIcon, lvsSmallIcon place icon left from text (rather then top) - lvoAutoArrange, // keep icons auto arranged in lvsIcon and lvsSmallIcon view - lvoButton, // icons look like buttons in lvsIcon view - lvoEditLabel, // allows edit labels inplace (first column #0 text) - lvoNoLabelWrap, // item text on a single line in lvsIcon view (by default, item text may wrap in lvsIcon view). - lvoNoScroll, // obvious - lvoNoSortHeader, // click on header button does not lead to sort items - lvoHideSel, // hide selection when not in focus - lvoMultiselect, // allow to select multiple items - lvoSortAscending, - lvoSortDescending, - // extended styles (not documented in my Win32.hlp :( , got from VCL source: - lvoGridLines, - lvoSubItemImages, - lvoCheckBoxes, - lvoTrackSelect, - lvoHeaderDragDrop, - lvoRowSelect, - lvoOneClickActivate, - lvoTwoClickActivate, - lvoFlatsb, - lvoRegional, - lvoInfoTip, - lvoUnderlineHot, - lvoMultiWorkares, - // virtual list view style: - lvoOwnerData, - // custom draw style: - lvoOwnerDrawFixed - ); - TListViewOptions = Set of TListViewOption; - - TOnEditLVItem = function( Sender: PControl; Idx, Col: Integer; NewText: PKOL_Char ): Boolean - of object; - {* Event type for OnEndEditLVItem. Return True in handler to accept new text value. } - TOnDeleteLVItem = procedure( Sender: PControl; Idx: Integer ) of object; - {* Event type for OnDeleteLVItem event. } - TOnLVData = procedure( Sender: PControl; Idx, SubItem: Integer; - var Txt: KOL_String; var ImgIdx: Integer; var State: DWORD; - var Store: Boolean ) of object; - {* Event type for OnLVData event. Used to provide virtual list view control - (i.e. having lvoOwnerData style) with actual data on request. Use parameter - Store as a flag if control should store obtained data by itself or not. } - {$IFDEF ENABLE_DEPRECATED} - {$DEFINE interface_1} {$I KOL_deprecated.inc} {$UNDEF interface_1} - {$ENDIF DISABLE_DEPRECATED} - TOnCompareLVItems = function( Sender: PControl; Idx1, Idx2: Integer ): Integer - of object; - {* Event type to compare two items of the list view (while sorting it). } - TOnLVColumnClick = procedure( Sender: PControl; Idx: Integer ) of object; - {* Event type for OnColumnClick event. } - TOnLVStateChange = procedure( Sender: PControl; IdxFrom, IdxTo: Integer; OldState, NewState: DWORD ) - of object; - {* Event type for OnLVStateChange event, called in responce to select/unselect - a single item or items range in list view control). } - - TDrawActions = ( odaEntire, odaFocus, odaSelect ); - TDrawAction = Set of TDrawActions; - TDrawStates = ( odsSelected, odsGrayed, odsDisabled, odsChecked, odsFocused, - odsDefault, odsHotlist, odsInactive, - odsNoAccel, odsNoFocusRect, - ods400reserved, ods800reserved, - odsComboboxEdit, - // specific for common controls: - odsMarked, odsIndeterminate ); - {* Possible draw states. - |
odsSelected - The menu item's status is selected. - |
odsGrayed - The item is to be grayed. This bit is used only in a menu. - |
odsDisabled - The item is to be drawn as disabled. - |
odsChecked - The menu item is to be checked. This bit is used only in - a menu. - |
odsFocused - The item has the keyboard focus. - |
odsDefault - The item is the default item. - |
odsHotList - Windows 98, Windows 2000: The item is being - hot-tracked, that is, the item will be highlighted when - the mouse is on the item. - |
odsInactive - Windows 98, Windows 2000: The item is inactive - and the window associated with the menu is inactive. - |
odsNoAccel - Windows 2000: The control is drawn without the - keyboard accelerator cues. - |
odsNoFocusRect - Windows 2000: The control is drawn without - focus indicator cues. - |
odsComboboxEdit - The drawing takes place in the selection field - (edit control) of an owner-drawn combo box. - |
odsMarked - for Common controls only. The item is marked. The meaning - of this is up to the implementation. - |
odsIndeterminate - for Common Controls only. The item is in an - indeterminate state. } - TDrawState = Set of TDrawStates; - {* Set of possible draw states. } - TOnDrawItem = function( Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer; - DrawAction: TDrawAction; ItemState: TDrawState ): Boolean of object; - {* Event type for OnDrawItem event (applied to list box, combo box, list view). } - TOnMeasureItem = function( Sender: PObj; Idx: Integer ): Integer of object; - {* Event type for OnMeasureItem event. The event handler must return height of list box - item as a result. } - TGetLVItemPart = ( lvipBounds, lvipIcon, lvipLabel, lvupIconAndLabel ); - {* } - TWherePosLVItem = ( lvwpOnIcon, lvwpOnLabel, lvwpOnStateIcon, lvwpOnColumn, - lvwpOnItem ); - {* } - - TOnLVCustomDraw = function( Sender: PControl; DC: HDC; Stage: DWORD; - ItemIdx, SubItemIdx: Integer; const Rect: TRect; - ItemState: TDrawState; var TextColor, BackColor: TColor ) - : DWORD of object; - {* Event type for OnLVCustomDraw event. } - - TOnPaint = procedure( Sender: PControl; DC: HDC ) of object; - TPaintProc = procedure( DC: HDC ) of object; - - TGradientStyle = ( gsVertical, gsHorizontal, gsRectangle, gsElliptic, gsRombic, - gsTopToBottom, gsBottomToTop ); - {* Gradient fill styles. See also TGradientLayout. } - TGradientLayout = ( glTopLeft, glTop, glTopRight, - glLeft, glCenter, glRight, - glBottomLeft, glBottom, glBottomRight ); - {* Position of starting line / point for gradient filling. Depending on - TGradientStyle, means either position of first line of first rectangle - (ellipse) to be expanded in a loop to fit entire gradient panel area. } - - TEditOption = ( eoNoHScroll, eoNoVScroll, eoLowercase, eoMultiline, - eoNoHideSel, eoOemConvert, eoPassword, eoReadonly, - eoUpperCase, eoWantReturn, eoWantTab, eoNumber ); - {* Available edit options. - |
Please note, that eoWantTab option just removes TAB key from a list - of keys available to tabulate from the edit control. To provide insertion - of tabulating key, do so in TControl.OnChar event handler. Sorry for - inconvenience, but this is because such behaviour is not must in all cases. - See also TControl.EditTabChar property. } - TEditOptions = Set of TEditOption; - {* Set of available edit options. } - - TEditPositions = packed record - SelStart: Integer; - SelLength: Integer; - TopLine: Integer; - TopColumn: Integer; - ScrollPos: TPoint; - RestoreScroll: Boolean; - end; - - TRichFmtArea = ( raSelection, raWord, raAll ); - {* Characters formatting area for RichEdit. } - TRETextFormat = ( reRTF, reText, rePlainRTF, reRTFNoObjs, rePlainRTFNoObjs, - reTextized, reUnicode, reTextUnicode ); - {* Available formats for transfer RichEdit text using property - TControl.RE_Text. - |
-     reRTF - normal rich text (no transformations)
-     reText - plain text only (without OLE objects)
-     reTextized - plain text with text representation of COM objects
-     rePlainRTF - reRTF without language-specific keywords
-     reRTFNoObjs - reRTF without OLE objects
-     rePlainRTFNoObjs - rePlainRTF without OLE objects
-     reUnicode - stream is 2-byte Unicode characters rather then 1-byte Ansi
-     |
} - TRichUnderline = ( ruSingle, ruWord, ruDouble, ruDotted, - //all other - only for RichEditv3.0: - ruDash, ruDashDot, ruDashDotDot, ruWave, ruThick, ruHairLine ); - {* Rich text exteded underline styles (available only for RichEdit v2.0, - and even for RichEdit v2.0 additional styles can not displayed - but - ruDotted under Windows2000 is working). } - TRichTextSizes = ( rtsNoUseCRLF, rtsNoPrecise, rtsClose, rtsBytes ); - {* Options to calculate size of rich text. Available only for RichEdit2.0 - or higher. } - TRichTextSize = set of TRichTextSizes; - {* Set of all available optioins to calculate rich text size using - property TControl.RE_TextSize[ options ]. } - TRichNumbering = ( rnNone, rnBullets, rnArabic, rnLLetter, rnULetter, - rnLRoman, rnURoman ); - {* Advanced numbering styles for paragraph (RichEdit). - |
-     rnNone     - no numbering
-     rnBullets  - bullets only
-     rnArabic   - 1, 2, 3, 4, ...
-     rnLLetter  - a, b, c, d, ...
-     rnULetter  - A, B, C, D, ...
-     rnLRoman   - i, ii, iii, iv, ...
-     rnURoman   - I, II, III, IV, ...
-     rnNoNumber - do not show any numbers (but numbering is taking place).
-     |
} - TRichNumBrackets = ( rnbRight, rnbBoth, rnbPeriod, rnbPlain, rnbNoNumber ); - {* Brackets around number: - |
-     rnbRight   - 1) 2) 3)     - this is default !
-     rnbBoth    - (1) (2) (3)
-     rnbPeriod  - 1. 2. 3.
-     rnbPlain   - 1 2 3
-     |
} - TBorderEdge = (beLeft, beTop, beRight, beBottom); - {* Borders of rectangle. } - - {$IFNDEF NOT_USE_RICHEDIT} - {$IFDEF _D3orHigher} - TCharFormat = TCharFormat2; - {$ENDIF _D3orHigher} - PCharFormat = ^TCharFormat; - TParaFormat = TParaFormat2; - {$ENDIF NOT_USE_RICHEDIT} - - TOnTestMouseOver = function( Sender: PControl ): Boolean of object; - {* Event type for TControl.OnTestMouseOver event. The handler should - return True, if it detects if the mouse is over control. } - - TEdgeStyle = ( esRaised, esLowered, esNone, esTransparent, esSolid ); - {* Edge styles (for panel - see NewPanel). - esTransparent and esSolid - special styles equivalent to esNone - except GRushControls are used via USE_GRUSH symbol (ToGRush.pas) } - - TListOption = ( loNoHideScroll, loNoExtendSel, loMultiColumn, loMultiSelect, - loNoIntegralHeight, loNoSel, loSort, loTabstops, - loNoStrings, loNoData, loOwnerDrawFixed, loOwnerDrawVariable, - loHScroll ); - {* Options for ListBox (see NewListbox). - To use loHScroll, you also have to send LB_SETHORIZONTALEXTENT with a - maximum width of a line in pixels (wParam)! } - TListOptions = Set of TListOption; - {* Set of available options for Listbox. } - - TComboOption = ( coReadOnly, coNoHScroll, coAlwaysVScroll, coLowerCase, - coNoIntegralHeight, coOemConvert, coSort, coUpperCase, - coOwnerDrawFixed, coOwnerDrawVariable, coSimple ); - {* Options for combobox. } - TComboOptions = Set of TComboOption; - {* Set of options available for combobox. } - - TProgressbarOption = ( pboVertical, pboSmooth ); - {* Options for progress bar. } - TProgressbarOptions = set of TProgressbarOption; - {* Set of options available for progress bar. } - - TTreeViewOption = ( tvoNoLines, tvoLinesRoot, tvoNoButtons, tvoEditLabels, tvoHideSel, - tvoDragDrop, tvoNoTooltips, tvoCheckBoxes, tvoTrackSelect, - tvoSingleExpand, tvoInfoTip, tvoFullRowSelect, tvoNoScroll, - tvoNonEvenHeight ); - {* Tree view options. } - TTreeViewOptions = set of TTreeViewOption; - {* Set of tree view options. } - - TTabControlOption = ( tcoButtons, tcoFixedWidth, tcoFocusTabs, - tcoIconLeft, tcoLabelLeft, - tcoMultiline, tcoMultiselect, tcoFitRows, tcoScrollOpposite, - tcoBottom, tcoVertical, tcoFlat, tcoHotTrack, tcoBorder, - tcoOwnerDrawFixed ); - {* Options, available for TabControl. } - TTabControlOptions = set of TTabControlOption; - {* Set of options, available for TAbControl during its creation (by - NewTabControl function). } - - TToolbarOption = ( tboTextRight, tboTextBottom, tboFlat, tboTransparent, - tboWrapable, tboNoDivider, tbo3DBorder, tboCustomErase ); - {* Toolbar options. When tboFlat is set and toolbar is placed onto panel, - set its property Transparent to TRUE to provide its correct view. } - TToolbarOptions = Set of TToolbarOption; - {* Set of toolbar options. } - TOnToolbarButtonClick = procedure( Sender: PControl; BtnID: Integer ) of object; - {* Special event type to handle separate toolbar buttons click events. } - TOnTBCustomDraw = function( Sender: PControl; var NMCD: TNMTBCustomDraw ): Integer of object; - {* Event type for OnTBCustomDraw event. } - - TDateTimePickerOption = ( dtpoTime, dtpoDateLong, dtpoUpDown, dtpoRightAlign, - dtpoShowNone, dtpoParseInput ); - {* } - TDateTimePickerOptions = set of TDateTimePickerOption; - {* } - TDTParseInputEvent = procedure(Sender: PControl; const UserString: KOLString; - var DateAndTime: TDateTime; var AllowChange: Boolean) of object; - {* } - TDateTimeRange = packed record - FromDate, ToDate: TDateTime; - end; - {* } - TDateTimePickerColor = ( dtpcBackground, dtpcText, dtpcTitleBk, - dtpcTitleText, dtpcMonthBk, dtpcTrailingText ); - {MCSC_BACKGROUND = 0; // the background color (between months) - MCSC_TEXT = 1; // the dates - MCSC_TITLEBK = 2; // background of the title - MCSC_TITLETEXT = 3; - MCSC_MONTHBK = 4; // background within the month cal - MCSC_TRAILINGTEXT = 5; // the text color of header & trailing days} - - TOnDropFiles = procedure( Sender: PControl; const FileList: KOL_String; const Pt: TPoint ) of object; - {* An event type for OnDropFiles event. When the event is occur, FileList - parameter contains a list of files dropped. File names in a list are - separated with #13 character. This allows You to assign it to TStrList - object using its property Text (for example): - ! procedure TSomeObject.DropFiles( Sender: PControl; const FileList: AnsiString; - ! const Pt: TPoint ); ) - ! var FList: PStrList; - ! I: Integer; - ! begin - ! FList := NewStrList; - ! FList.Text := FileList; - ! for I := 0 to FList.Count-1 do - ! begin - ! // do something with FList.Items[ I ] - ! end; - ! FList.Free; - ! end; } - - TScrollerBar = ( sbHorizontal, sbVertical ); - TScrollerBars = set of TScrollerBar; - - TOnScroll = procedure( Sender: PControl; Bar: TScrollerBar; ScrollCmd: DWORD; - ThumbPos: DWORD ) of object; - - TOnHelp = procedure( var Sender: PControl; var Context: Integer; var Popup: Boolean ) - of object; - - TOnSBBeforeScroll = - procedure( - Sender: PControl; OldPos, NewPos: Integer; Cmd: Word; - var AllowChange: Boolean) of object; - TOnSBScroll = procedure(Sender: PControl; Cmd: Word) of object; - -{$IFDEF WIN_GDI} - TOnGraphCtlMouse = procedure( var Msg: TMsg ) of object; -{$ENDIF WIN_GDI} - TTriStateCheck = (tsUnchecked{=0}, tsChecked{=1}, tsIndeterminate{=2}); - -{$IFDEF _X_} - //---- in GTK+, each type of widget requieres its own getcaption/setcaption call - TGetCaption = FUNCTION( Ctl: PControl ): KOLString; - TSetCaption = PROCEDURE( Ctl: PControl; CONST Value: KOLString ); - - {$IFDEF GTK} - //---- in GTK+, to allow setting absolute position for children, - // we should use one of special clients like gtk_fixed, gtk_layout - TGetClientArea = FUNCTION( Ctl: PControl ): PGtkWidget; - TChildSetPos = PROCEDURE( Ctl, Chld: PControl; x, y: Integer ); - {$ENDIF GTK} -{$ENDIF _X_} - - TFormInitFunc = function(Form: PControl): PControl; - TFormInitFunc1 = function(Form: PControl; intParam: Integer): PControl; - TFormInitFuncArray = array[0..65535] of TFormInitFunc; - TFormInitFuncArray1 = array[0..65535] of TFormInitFunc1; - PFormInitFuncArray = ^TFormInitFuncArray; - PFormInitFuncArray1 = ^TFormInitFuncArray1; - - TSmallIntArray = array[0..65535] of SmallInt; - PSmallIntArray = ^TSmallIntArray; - - PPControl = ^PControl; - - {$IFDEF USE_MHTOOLTIP} - {$DEFINE pre_interface} - PMHHint = ^TMHHint; - TKOLMHHint = PMHHint; - {$UNDEF pre_interface} - {$ENDIF} - - TOnWndFunc = function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; - TProcSender = procedure( Sender: PObj ); - TOnGotoControl = function( Self_: PControl; Key: DWORD; CheckOnly: Boolean ): Boolean; - - PEvents = ^TEvents; - TEvents = record - CASE Integer OF - 1:( - //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - //................... most common events ................................... - fOnMessage: TOnMessage; - fOldOnMessage: TOnMessage; // for applet only but... - fOnClick: TOnEvent; - fOnMouseDown: TOnMouse; // CAUTION!!! Order of mouse event handlers is important. ____ - fOnMouseUp: TOnMouse; // - fOnMouseMove: TOnMouse; // - fOnMouseDblClk: TOnMouse; // - fOnMouseWheel: TOnMouse; //_____________________________________________________// - - fOnMouseEnter: TOnEvent; - fOnMouseLeave: TOnEvent; - fOnTestMouseOver: TOnTestMouseOver; // mainly for bitbtn but... - fGraphCtlMouseEvent: TOnGraphCtlMouse; - fMouseLeaveProc: TOnEvent; - fOnScroll: TOnScroll; - - fOnChar: TOnChar; - fOnDeadChar: TOnChar; - fOnKeyUp: TOnKey; - fOnKeyDown: TOnKey; - - fOnChangeCtl: TOnEvent; - fOnEnter: TOnEvent; - fOnLeave: TOnEvent; - fLeave: TOnEvent; - - fOnPaint: TOnPaint; - fOnPaint2: TOnPaint; - fOnPrepaint: TOnPaint; - fOnPostPaint: TOnPaint; - fPaintProc: TPaintProc; - fOnEraseBkgnd: TOnPaint; - fOnDrawItem: TOnDrawItem; - fOnMeasureItem: TOnMeasureItem; - - fDragCallback: TOnDrag; - - fOnSelChange: TOnEvent; - fOnResize: TOnEvent; - - fOnHide: TOnEvent; - fOnShow: TOnEvent; - - fOnClose: TOnEventAccept; // mainly for form but... - - fOnMove: TOnEvent; - fOnMoving: TOnEventMoving; - fOnHelp: TOnHelp; - //................... other events ......................................... - fOnQueryEndSession: TOnEventAccept; - - //----- order of following 3 events important: // for form only ? - fOnMinimize: TOnEvent; // - fOnMaximize: TOnEvent; // - fOnRestore: TOnEvent; // - //---------------------------------------------// - - fOnLVCustomDraw: TOnLVCustomDraw; - fOnEndEditLVItem: TOnEditLVItem; - fOnLVData: TOnLVData; - fOnCompareLVItems: TOnCompareLVItems; - FOnLVStateChange: TOnLVStateChange; - fOnDeleteLVItem: TOnDeleteLVItem; - fOnColumnClick: TOnLVColumnClick; - - FOnSBBeforeScroll: TOnSBBeforeScroll; - FOnSBScroll: TOnSBScroll; - - FOnDropDown: TOnEvent; - FOnCloseUp: TOnEvent; - - FOnSplit: TOnSplit; - - FOnProgress: TOnEvent; - - FOnBitBtnDraw: TOnBitBtnDraw; - - FOnTVBeginDrag: TOnTVBeginDrag; - FOnTVBeginEdit: TOnTVBeginEdit; - FOnTVEndEdit: TOnTVEndEdit; - FOnTVExpanding: TOnTVExpanding; - FOnTVExpanded: TOnTVExpanded; - FOnTVSelChanging: TOnTVSelChanging; - - FOnTVDelete: TOnTVDelete; - - FOnDTPUserString: TDTParseInputEvent; - - FOnREInsModeChg: TOnEvent; - FOnREOverURL: TOnEvent; - FOnREURLClick: TOnEvent; - fOnDropFiles: TOnDropFiles; - ); - 2: ( MethodEvents: array[ 0..idx_LastEvent ] of TMethod; - ); - end; - - TProcedures = record - CASE Integer OF - 1: ( - //.......................................................................... - fWndFunc: Pointer; - fDoInvalidate: TProcSender; - fOnDynHandlers: TWindowFunc; - fPass2DefProc: TOnWndFunc; - fWndProcKeybd: TOnWndFunc; - fControlClick: TProcSender; // - fAutoSize: TProcSender; - //{-2.95}//fWndProcResizeFlicks: TOnWndFunc; - fGotoControl: TOnGotoControl; - {* Initially pointer to WndFunc. For MDI child window, points to DefMDIChildProc. } - fNotifyChild: procedure( Self_, Child: PControl ); - fScrollChildren: procedure( Self_: PControl ); - fCreateWndExt: procedure( Sender: PControl ); - fExMsgProc: function( Applet: PControl; var Msg: TMsg ): Boolean; - {* Additional message handler called directly from Applet.ProcessMessage. - Used to call TranslateMDISysAccel API function for MDI application. } - ); - 2: ( Procedures: array[ 0..idx_LastProc-idx_LastEvent-1 ] of Pointer; - ); - end; - - // data fields of TControl which are certain for different kinds of control - // -- so these can be alternated using variant record type to economy run time - // size of TControl object instance - TDataFields = packed record - fCurrentControl: PControl; //---- sometimes it is used for a parent control, - // not only for parent form, so should be common. - {$IFDEF UNION_FIELDS} - CASE Integer OF - 1:( // Toolbar control fields - {$ENDIF} - fOnTBCustomDraw: TOnTBCustomDraw; - fTBevents: PList; // events for TBAssignEvents - fTBBtnImgWidth: Integer; // custom toolbar bitmap width - fTBBtMinWidth: Integer; - fTBBtMaxWidth: Integer; - fTBttCmd: PList; - fTBttTxt: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF}; - fTBCurItem: Integer; - fDefaultTBBtnStyle: Byte; // for Toolbars - fTBDropped: Boolean; - {$IFDEF UNION_FIELDS} - ); - 2:( // Combobox + Group box - {$ENDIF} - fDroppedWidth: Integer; // SmallInt; - fDropDownCount: Cardinal; - fCurIdxAtDrop: Integer; - fErasingBkgnd: Boolean; // for Group box - {$IFDEF UNION_FIELDS} - ); - 3:( // Form + Applet - {$ENDIF} - fModalResult: Integer; - fModalForm: PControl; - //fCurrentControl: PControl; - //FMinimizeWnd: PControl; - fIcon: HIcon; - - {$IFDEF USE_GRAPHCTLS} - {$IFDEF GRAPHCTL_HOTTRACK} - fHotCtl: PControl; - {$ENDIF} - {$ENDIF} - //fDefaultBtnCtl: PControl; - //fCancelBtnCtl: PControl; - fWindowState: TWindowState; - fActivating: Boolean; - fCloseQueryReason: TCloseQueryReason; - fFixingModal: ShortInt; - fShowAction: Byte; - fKeyPreviewCount: Byte; - fModal: Byte; - fAllBtnReturnClick: Boolean; - //-- внимание! порядок следующих 3х полей не должен меняться!!! - FormCurrentParent: PControl; - {* контрол, использующийся в качестве родительского, в функциях создания } - FormParams: PAnsiChar; - {* строка команд и параметров } - FormAddress: PPControl; - {* адрес поля Form в объекте формы MCK - нужен для вычисления адресов - контролов по смещению, для функции FormSetCurCtl } - FormObj: PObj; - FormAlphabet: PFormInitFuncArray; - {* алфавит процедур } - FormLastCreatedChild: PControl; - {* контрол, созданный последним } - {$IFDEF UNION_FIELDS} - ); - 4:( // ListView - {$ENDIF} - fColumn: Integer; // for listview only (column to sort) - fOnDeleteAllLVItems: TOnEvent; - fCtlImageListSml: PImageList; - {* ImageList object (with small icons 16x16) to use with a control (e.g., - with ListView control). - If not set, but control has a list of image list objects, last added - image list with small icons is used automatically. } - fCtlImageListNormal: PImageList; - {* ImageList object (with big icons 32x32) to use with a control. - If not set, last added image list with big icons is used. } - fCtlImgListState: PImageList; - {* ImageList object to use as a state image list (for ListView control). } - fLVColCount: Integer; - fLVTextBkColor: TColor; - fLVItemHeight: Integer; - fLVOptions: TListViewOptions; - fLVStyle: TListViewStyle; - {$IFDEF UNION_FIELDS} - ); - 5:( // Rich Edit -- 11 dwords - {$ENDIF} - {$IFNDEF NOT_USE_RICHEDIT} - {$IFDEF STATIC_RICHEDIT_DATA} - fRECharFormatRec: TCharFormat; - fREParaFmtRec: TParaFormat2; - {$ELSE} - fRECharFormatRec: PCharFormat; - fREParaFmtRec: PParaFormat2; - {$ENDIF} - fCharFmtDeltaSz: Integer; - fParaFmtDeltaSz: Integer; - fREError: Integer; - fREStream: PStream; - fREStrLoadLen: DWORD; - fREUrl: PKOLChar; - fTmpFont: PGraphicTool; // for RichEdit - fREUpdCount: SmallInt; - fReOvrDisable: Boolean; - fREOvr: Boolean; - fREScrolling: Boolean; - fRECharArea: TRichFmtArea; - FSupressTab: Boolean; - fRETransparent: Boolean; - {$ENDIF NOT_USE_RICHEDIT} - {$IFDEF UNION_FIELDS} - ); - 6:( // Label Effect + Graphic edit control - {$ENDIF} - fShadowDeep: Integer; - fEditCtl: PControl; - fEditOptions: TEditOptions; - {$IFDEF UNION_FIELDS} - ); - 7:( // BitBtn - {$ENDIF} - fGlyphBitmap : HBitmap; - fGlyphCount : Integer; - fGlyphWidth, fGlyphHeight: Integer; - fRepeatInterval: Integer; - fTextShiftX, fTextShiftY: Integer; - fBitBtnDrawMnemonic: Boolean; - fBitBtnOptions : TBitBtnOptions; - fGlyphLayout : TGlyphLayout; - fButtonIcon: HIcon; // for Graphic button control though... - FBitBtnGetCaption: function( Self_: PControl; const S: KOLString ): KOLString; - FBitBtnExtDraw: procedure( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect; - const CapText, CapTxtOrig: KOLString; Color: TColor ); - {$IFDEF UNION_FIELDS} - ); - 8:( // Splitter - {$ENDIF} - fSplitStartPos: TPoint; - fSplitStartPos2: TPoint; - fSplitStartSize: Integer; - fSplitMinSize1, fSplitMinSize2: Integer; - fSecondControl: PControl; - fSplitLastPos: TPoint; - {$IFDEF UNION_FIELDS} - ); - 9:( // Gradient panel - {$ENDIF} - fColor1: TColor; - fColor2: TColor; - fGradientStyle: TGradientStyle; - fGradientLayout: TGradientLayout; - {$IFDEF UNION_FIELDS} - ); - 10:( // Tree view only - {$ENDIF} - fTVRightClickSelect: Boolean; - {$IFDEF UNION_FIELDS} - ); - 11:( // Scroll Bar - {$ENDIF} - FScrollLineDist: array[ 0..1 ] of Integer; - fSBMinMax: TPoint; - fSBPageSize: Integer; - fSBPosition: Integer; - {$IFDEF UNION_FIELDS} - ); - 100:( // for custom controls - {$ENDIF} - //fCustom6: Integer; - //fCustEvent2: TOnEvent; - fCustom5: Integer; - fCustom4: Integer; - fCustEvent1: TOnEvent; - fCustom3: Integer; - fCustom2: Integer; - fCustEvent0: TOnEvent; - fCustom1: Integer; - fCustom0: Integer; - fCustFlag7: Boolean; - fCustFlag6: Boolean; - fCustFlag5: Boolean; - fCustFlag4: Boolean; - fCustFlag3: Byte; - fCustFlag2: Byte; - fCustFlag1: Byte; - fCustFlag0: Byte; - {$IFDEF UNION_FIELDS} - ); - {$ENDIF} - end; - -{ ---------------------------------------------------------------------- - TControl - object to implement any visual control ------------------------------------------------------------------------ } -//[TControl DEFINITION] - TControl = object( TObj ) - {*! TControl is the basic visual object of KOL. And now, all visual - objects have the same type PControl, differing only in "constructor", - which during creating of object adjusts it so it can play role of - desired control. Idea of incapsulating of all visual objects having - the most common set of properties, is belonging to Vladimir Kladov, - (C) 2000. - |
    Since all visual objects are represented - in KOL by this single object type, not all methods, properties and - events defined in TControl, are applicable to different visual objects. - See also notes about certain control kinds, located together with its - | - |constructing functions definitions. } - public - procedure SetAnchor(const Index: Integer; const Value: Boolean); - protected - function GetAnchor(const Index: Integer): Boolean; - function Get_StatusWnd: HWND; - function Get_Prop_Int(PropName: PKOLChar): Integer; - procedure Set_Prop_Int(PropName: PKOLChar; const Value: Integer); - function GetHelpContext: Integer; - function Get_Ctl3D: Boolean; - function Get_OnMouseEvent(const Index: Integer): TOnMouse; - public - procedure SetOnMouseEvent(const Index: Integer; const Value: TOnMouse); - protected - {$IFDEF EVENTS_DYNAMIC} - function Get_TOnEvent(const Index: Integer): TOnEvent; - function Get_OnMessage: TOnMessage; - function Get_OnHelp: TOnHelp; - function Get_OnBitBtnDraw: TOnBitBtnDraw; - function Get_OnMeasureItem: TOnMeasureItem; - function Get_OnShow: TOnEvent; - function Get_OnHide: TOnEvent; - function Get_OnClose: TOnEventAccept; - function Get_OnQueryEndSession: TOnEventAccept; - function Get_OnPaint: TOnPaint; - function Get_OnPrePaint: TOnPaint; - function Get_OnPostPaint: TOnPaint; - function Get_OnEraseBkgnd: TOnPaint; - function Get_OnClick: TOnEvent; - function Get_OnResize: TOnEvent; - function Get_OnMove: TOnEvent; - function Get_OnMoving: TOnEventMoving; - function Get_OnSplit: TOnSplit; - function Get_OnKeyDown: TOnKey; - function Get_OnKeyUp: TOnKey; - function Get_OnChar: TOnChar; - function Get_OnDeadChar: TOnChar; - function Get_OnMouseUp: TOnMouse; - function Get_OnMouseDown: TOnMouse; - function Get_OnMouseMove: TOnMouse; - function Get_OnMouseDblClk: TOnMouse; - function Get_OnMouseWheel: TOnMouse; - function Get_OnMouseEnter: TOnEvent; - function Get_OnMouseLeave: TOnEvent; - function Get_OnTestMouseOver: TOnTestMouseOver; - function Get_OnEndEditLVItem: TOnEditLVItem; - function Get_OnDeleteLVItem: TOnDeleteLVItem; - function Get_OnLVData: TOnLVData; - function Get_OnCompareLVItems: TOnCompareLVItems; - function Get_OnColumnClick: TOnLVColumnClick; - function Get_OnLVStateChange: TOnLVStateChange; - function Get_OnDrawItem: TOnDrawItem; - function Get_OnLVCustomDraw: TOnLVCustomDraw; - function Get_OnTVBeginDrag: TOnTVBeginDrag; - function Get_OnTVBeginEdit: TOnTVBeginEdit; - function Get_OnTVEndEdit: TOnTVEndEdit; - function Get_OnTVExpanding: TOnTVExpanding; - function Get_OnTVExpanded: TOnTVExpanded; - function Get_OnTVDelete: TOnTVDelete; - function Get_OnTVSelChanging: TOnTVSelChanging; - function Get_OnDTPUserString: TDTParseInputEvent; - function Get_OnSBBeforeScroll: TOnSBBeforeScroll; - function Get_OnSBScroll: TOnSBScroll; - function Get_OnScroll: TOnScroll; - function Get_OnDropFiles: TOnDropFiles; - public - procedure Set_TOnEvent(const Index: Integer; const Value: TOnEvent); - procedure Set_OnMessage(const Value: TOnMessage); - procedure Set_OnHelp(const Value: TOnHelp); - procedure Set_OnBitBtnDraw(const Value: TOnBitBtnDraw); - procedure Set_OnPrePaint(const Value: TOnPaint); - procedure Set_OnPostPaint(const Value: TOnPaint); - procedure Set_OnEraseBkgnd(const Value: TOnPaint); - procedure Set_OnSplit(const Value: TOnSplit); - procedure Set_OnCompareLVItems(const Value: TOnCompareLVItems); - procedure Set_OnTVBeginDrag(const Value: TOnTVBeginDrag); - procedure Set_OnTVBeginEdit(const Value: TOnTVBeginEdit); - procedure Set_OnTVEndEdit(const Value: TOnTVEndEdit); - procedure Set_OnTVExpanding(const Value: TOnTVExpanding); - procedure Set_OnTVExpanded(const Value: TOnTVExpanded); - procedure Set_OnTVSelChanging(const Value: TOnTVSelChanging); - procedure Set_OnDTPUserString(const Value: TDTParseInputEvent); - procedure Set_OnSBBeforeScroll(const Value: TOnSBBeforeScroll); - procedure Set_OnSBScroll(const Value: TOnSBScroll); - {$ENDIF EVENTS_DYNAMIC} - protected - procedure SetTBAutoSizeButtons(const Value: Boolean); - function GetTBAutoSizeButtons: Boolean; - function GetTVEditing: Boolean; - function GetDroppedDown: Boolean; - {$IFDEF USE_FLAGS} - function Get_Dragging: Boolean; - function GetTabStop: Boolean; - procedure SetTabStop(const Value: Boolean); - function GetWordWrap: Boolean; - procedure SetWordWrap(const Value: Boolean); - function GetCannotDoubleBuf: Boolean; - procedure SetCannotDoubleBuf(const Value: Boolean); - function GetDoubleBuffered: Boolean; - function GetTransparent: Boolean; - function GetIsForm: Boolean; - function GetSizeGrip: Boolean; - procedure SetSizeGrip(const Value: Boolean); - function GetIsApplet: Boolean; - function GetIsControl: Boolean; - function GetIsMDIChild: Boolean; - function GetCreateVisible: Boolean; - procedure SetCreateVisible(const Value: Boolean); - function GetIsButton: Boolean; - function GetFlat: Boolean; - function GetMouseInCtl: Boolean; - function GetEraseBackground: Boolean; - procedure SetEraseBackground(const Value: Boolean); - function Get3ButtonPress: Boolean; - function GetKeyPreview: Boolean; - procedure SetKeyPreview(const Value: Boolean); - function GetIgnoreDefault: Boolean; - procedure SetIgnoreDefault(const Value: Boolean); - function GetWindowed: Boolean; - procedure SetWindowed(const Value: Boolean); - function Get_RightClick: Boolean; - function Get_SizeRedraw: Boolean; - procedure Set_SizeRedraw(const Value: Boolean); - {$ENDIF USE_FLAGS} - public //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - FormString: KOLString; - {* строка текущего параметра. Очищается после каждого вызова - FormExecuteCommands, так что специальная очистка не требуется. } - function FormGetIntParam: Integer; - {* извлекает очередной целочисленный параметр до ',' или до ';' } - function FormGetColorParam: Integer; - {* извлекает очередной целочисленный параметр до ',' или до ';' } - procedure FormGetStrParam; - {* извлекает очередной строковый параметр до ',' или до ';' -> FormString } - procedure FormCreateParameters( alphabet: PFormInitFuncArray; params: PAnsiChar ); - {* задает первоначальный алфавит и параметры с командами } - procedure FormExecuteCommands(AForm: PControl; ControlPtrOffsets: PSmallIntArray); - {* выполняет команды (с параметрами) до конца или до ';' } - {$IFDEF GDI} - protected - function GetDate: TDateTime; - function GetTime: TDateTime; - procedure SetDate(const Value: TDateTime); - procedure SetTime(const Value: TDateTime); - {$ENDIF GDI} - protected - {$IFDEF GDI} - function GetHelpPath: KOLString; - procedure SetHelpPath(const Value: KOLString); - public - procedure SetOnQueryEndSession(const Value: TOnEventAccept); - procedure SetOnMinMaxRestore(const Index: Integer; const Value: TOnEvent); - procedure SetOnMinimize( const Value: TOnEvent ); - procedure SetOnMaximize( const Value: TOnEvent ); - procedure SetOnRestore( const Value: TOnEvent ); - procedure SetOnScroll(const Value: TOnScroll); - protected - procedure SetConstraint(const Index: Integer; Value: SmallInt); - function GetOnMinMaxRestore(const Index: Integer): TOnEvent; - function GetConstraint(const Index: Integer): Integer; - function GetLVColalign(Idx: Integer): TTextAlign; - procedure SetLVColalign(Idx: Integer; const Value: TTextAlign); - - {$ENDIF GDI} - procedure SetParent( Value: PControl ); - function GetLeft: Integer; - procedure SetLeft( Value: Integer ); - function GetTop: Integer; - procedure SetTop( Value: Integer ); - function GetWidth: Integer; - procedure SetWidth( Value: Integer ); - function GetHeight: Integer; - procedure SetHeight( Value: Integer ); - function GetPosition: TPoint; - procedure Set_Position( Value: TPoint ); - function GetMembers(Idx: Integer): PControl; - function GetFont: PGraphicTool; - procedure FontChanged( Sender: PGraphicTool ); - {$IFDEF GDI} - function GetBrush: PGraphicTool; - procedure BrushChanged( Sender: PGraphicTool ); - function GetClientHeight: Integer; - function GetClientWidth: Integer; - procedure SetClientHeight(const Value: Integer); - procedure SetClientWidth(const Value: Integer); - function GetHasBorder: Boolean; - public procedure SetHasBorder(const Value: Boolean); - protected - - function GetHasCaption: Boolean; - procedure SetHasCaption(const Value: Boolean); - - function GetCanResize: Boolean; - procedure SetCanResize( const Value: Boolean ); - - function GetStayOnTop: Boolean; - public procedure SetStayOnTop(const Value: Boolean); - protected - function GetChecked: Boolean; - procedure Set_Checked(const Value: Boolean); - - function GetCheck3: TTriStateCheck; - procedure SetCheck3(value: TTriStateCheck); - - function GetSelStart: Integer; - procedure SetSelStart(const Value: Integer); - function GetSelLength: Integer; - procedure SetSelLength(const Value: Integer); - - function GetItems(Idx: Integer): KOLString; - procedure SetItems(Idx: Integer; const Value: KOLString); - - function GetItemsCount: Integer; - function GetItemSelected(ItemIdx: Integer): Boolean; - procedure SetItemSelected(ItemIdx: Integer; const Value: Boolean); - - public procedure SetCtl3D(const Value: Boolean); - protected - function GetCurIndex: Integer; - procedure SetCurIndex(const Value: Integer); - - {$ENDIF GDI} - function GetTextAlign: TTextAlign; - public procedure SetTextAlign(const Value: TTextAlign); - protected - function GetVerticalAlign: TVerticalAlign; - public procedure SetVerticalAlign(const Value: TVerticalAlign); - protected - function GetCanvas: PCanvas; - {$IFDEF _X_} - {$IFDEF GTK} - protected - {} fInBkPaint: Boolean; - {} fSetTextAlign: PROCEDURE( Self_: PControl ); - FUNCTION ProvideCanvasHandle( Sender: PCanvas ): HDC; - {$ENDIF GTK} - {$ENDIF _X_} - {$IFDEF GDI} - function Dc2Canvas( Sender: PCanvas ): HDC; - procedure SetShadowDeep(const Value: Integer); - public procedure SetDoubleBuffered(const Value: Boolean); - protected - - procedure SetStatusText(Index: Integer; const Value: KOLString); - function GetStatusText( Index: Integer ): KOLString; - function GetStatusPanelX(Idx: Integer): Integer; - procedure SetStatusPanelX(Idx: Integer; const Value: Integer); - - public procedure SetTransparent(const Value: Boolean); - protected - function GetImgListIdx(const Index: Integer): PImageList; - - procedure SetImgListIdx(const Index: Integer; const Value: PImageList); - function GetLVColText(Idx: Integer): KOLString; - procedure SetLVColText(Idx: Integer; const Value: KOLString); - {$IFDEF ENABLE_DEPRECATED} - {$DEFINE interface_2} - {$I KOL_deprecated.inc} - {$UNDEF interface_2} - {$ENDIF DISABLE_DEPRECATED} - protected - function LVGetItemText(Idx, Col: Integer): KOLString; - procedure LVSetItemText(Idx, Col: Integer; const Value: KOLString); - procedure SetLVOptions(const Value: TListViewOptions); - procedure SetLVStyle(const Value: TListViewStyle); - function GetLVColEx(Idx: Integer; const Index: Integer): Integer; - procedure SetLVColEx(Idx: Integer; const Index: Integer; - const Value: Integer); - {$ENDIF GDI} - function GetChildCount: Integer; - {$IFDEF GDI} - function LVGetItemPos(Idx: Integer): TPoint; - procedure LVSetItemPos(Idx: Integer; const Value: TPoint); - procedure LVSetColorByIdx(const Index: Integer; const Value: TColor); - {$IFDEF F_P} - function LVGetColorByIdx(const Index: Integer): TColor; - {$ENDIF F_P} - function GetIntVal(const Index: Integer): Integer; - procedure SetIntVal(const Index, Value: Integer); - function GetItemVal(Item: Integer; const Index: Integer): Integer; - procedure SetItemVal(Item: Integer; const Index, Value: Integer); - function TBGetButtonVisible(BtnID: Integer): Boolean; - procedure TBSetButtonVisible(BtnID: Integer; const Value: Boolean); - - function TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean; - procedure TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean); - function TBGetButtonText(BtnID: Integer): KOLString; - function TBGetButtonRect(BtnID: Integer): TRect; - - function TBGetRows: Integer; - procedure TBSetRows(const Value: Integer); - procedure SetProgressColor(const Value: TColor); - function TBGetBtnImgIdx(BtnID: Integer): Integer; - procedure TBSetBtnImgIdx(BtnID: Integer; const Value: Integer); - - procedure TBSetButtonText(BtnID: Integer; const Value: KOLString); - - function TBGetBtnWidth(BtnID: Integer): Integer; - procedure TBSetBtnWidth(BtnID: Integer; const Value: Integer); - procedure TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer); - {$IFDEF F_P} - function TBGetBtMinMaxWidth(const Idx: Integer): Integer; - {$ENDIF F_P} - procedure TBFreeTBevents; - function TBGetButtonLParam(const Idx: Integer): DWORD; - procedure TBSetButtonLParam(const Idx: Integer; const Value: DWORD); - public - procedure Set_Align(const Value: TControlAlign); - protected - function GetSelection: KOLString; - procedure SetSelection(const Value: KOLString); - procedure SetTabOrder(const Value: SmallInt); - function GetFocused: Boolean; - procedure SetFocused(const Value: Boolean); - {$IFNDEF NOT_USE_RICHEDIT} - function REGetFont: PGraphicTool; - procedure RESetFont(Value: PGraphicTool); - procedure RESetFontEx(const Index: Integer); - function REGetFontEffects(const Index: Integer): Boolean; - function REGetFontMask(const Index: Integer): Boolean; - procedure RESetFontEffect(const Index: Integer; const Value: Boolean); - function REGetFontAttr(const Index: Integer): Integer; - procedure RESetFontAttr(const Index, Value: Integer); - procedure RESetFontAttr1(const Index, Value: Integer); - function REGetFontSizeValid: Boolean; - function REGetCharformat: TCharFormat; - procedure RESetCharFormat(const Value: TCharFormat); - function REReadText(Format: TRETextFormat; SelectionOnly: Boolean): KOLString; - procedure REWriteText(Format: TRETextFormat; SelectionOnly: Boolean; - const Value: KOLString); - function REGetFontName: KOLString; - procedure RESetFontName(const Value: KOLString); - function REGetParaFmt: TParaFormat; - procedure RESetParaFmt(const Value: TParaFormat); - function REGetNumbering: Boolean; - function REGetParaAttr( const Index: Integer ): Integer; - function REGetParaAttrValid( const Index: Integer ): Boolean; - function REGetTabCount: Integer; - function REGetTabs(Idx: Integer): Integer; - function REGetTextAlign: TRichTextAlign; - procedure RESetNumbering(const Value: Boolean); - procedure RESetParaAttr(const Index, Value: Integer); - procedure RESetTabCount(const Value: Integer); - procedure RESetTabs(Idx: Integer; const Value: Integer); - procedure RESetTextAlign(const Value: TRichTextAlign); - function REGetStartIndentValid: Boolean; - function REGetAutoURLDetect: Boolean; - public procedure RESetAutoURLDetect(const Value: Boolean); - protected - procedure RESetZoom( const Value: TSmallPoint ); - function REGetZoom: TSmallPoint; - - function GetMaxTextSize: DWORD; - procedure SetMaxTextSize(const Value: DWORD); - function REGetUnderlineEx: TRichUnderline; - procedure RESetUnderlineEx(const Value: TRichUnderline); - - function GetTextSize: Integer; - function REGetTextSize(Units: TRichTextSize): Integer; - - function REGetNumStyle: TRichNumbering; - procedure RESetNumStyle(const Value: TRichNumbering); - function REGetNumBrackets: TRichNumBrackets; - procedure RESetNumBrackets(const Value: TRichNumBrackets); - function REGetNumTab: Integer; - procedure RESetNumTab(const Value: Integer); - function REGetNumStart: Integer; - procedure RESetNumStart(const Value: Integer); - function REGetSpacing(const Index: Integer): Integer; - procedure RESetSpacing(const Index, Value: Integer); - function REGetSpacingRule: Integer; - procedure RESetSpacingRule(const Value: Integer); - function REGetLevel: Integer; - function REGetBorder(Side: TBorderEdge; const Index: Integer): Integer; - procedure RESetBorder(Side: TBorderEdge; const Index: Integer; - const Value: Integer); - function REGetParaEffect(const Index: Integer): Boolean; - procedure RESetParaEffect(const Index: Integer; const Value: Boolean); - function REGetOverwite: Boolean; - procedure RESetOverwrite(const Value: Boolean); - procedure RESetOvrDisable(const Value: Boolean); - function REGetTransparent: Boolean; - public procedure RESetTransparent(const Value: Boolean); - protected - procedure RESetOnURL(const Index: Integer; const Value: TOnEvent); - procedure SetOnRE_URLClick( const Value: TOnEvent ); - procedure SetOnRE_OverURL( const Value: TOnEvent ); - function REGetOnURL(const Index: Integer): TOnEvent; - function REGetLangOptions(const Index: Integer): Boolean; - procedure RESetLangOptions(const Index: Integer; const Value: Boolean); - {$ENDIF NOT_USE_RICHEDIT} - public - procedure SetOnResize(const Value: TOnEvent); - protected - procedure DoSelChange; - function LVGetItemImgIdx(Idx: Integer): Integer; - procedure LVSetItemImgIdx(Idx: Integer; const Value: Integer); - public procedure SetFlat(const Value: Boolean); - procedure SetOnMouseEnter(const Value: TOnEvent); - procedure SetOnMouseLeave(const Value: TOnEvent); - protected - procedure EdSetTransparent(const Value: Boolean); - procedure SetOnTestMouseOver(const Value: TOnTestMouseOver); - function GetPages(Idx: Integer): PControl; - function TCGetItemText(Idx: Integer): KOLString; - procedure TCSetItemText(Idx: Integer; const Value: KOLString); - function TCGetItemImgIDx(Idx: Integer): Integer; - procedure TCSetItemImgIdx(Idx: Integer; const Value: Integer); - function TCGetItemRect(Idx: Integer): TRect; - function TVGetItemIdx(const Index: Integer): THandle; - procedure TVSetItemIdx(const Index: Integer; const Value: THandle); - function TVGetItemNext(Item: THandle; const Index: Integer): THandle; - function TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect; - function TVGetItemVisible(Item: THandle): Boolean; - procedure TVSetITemVisible(Item: THandle; const Value: Boolean); - function TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean; - procedure TVSetItemStateFlg(Item: THandle; const Index: Integer; - const Value: Boolean); - function TVGetItemImage(Item: THandle; const Index: Integer): Integer; - procedure TVSetItemImage(Item: THandle; const Index: Integer; - const Value: Integer); - function TVGetItemText(Item: THandle): KOLString; - procedure TVSetItemText(Item: THandle; const Value: KOLString); - function TV_GetItemHasChildren(Item: THandle): Boolean; - procedure TV_SetItemHasChildren(Item: THandle; const Value: Boolean); - function TV_GetItemChildCount(Item: THandle): Integer; - function TVGetItemData(Item: THandle): Pointer; - procedure TVSetItemData(Item: THandle; const Value: Pointer); - function GetToBeVisible: Boolean; - procedure SetAlphaBlend(const Value: Byte); - procedure SetMaxProgress(const Index, Value: Integer); - procedure SetDroppedWidth(const Value: Integer); - function LVGetItemState(Idx: Integer): TListViewItemState; - procedure LVSetItemState(Idx: Integer; const Value: TListViewItemState); - function LVGetSttImgIdx(Idx: Integer): Integer; - procedure LVSetSttImgIdx(Idx: Integer; const Value: Integer); - function LVGetOvlImgIdx(Idx: Integer): Integer; - procedure LVSetOvlImgIdx(Idx: Integer; const Value: Integer); - function LVGetItemData(Idx: Integer): DWORD; - procedure LVSetItemData(Idx: Integer; const Value: DWORD); - function LVGetItemIndent(Idx: Integer): Integer; - procedure LVSetItemIndent(Idx: Integer; const Value: Integer); - public - procedure SetOnDeleteAllLVItems(const Value: TOnEvent); - procedure SetOnDeleteLVItem(const Value: TOnDeleteLVItem); - procedure SetOnEndEditLVItem(const Value: TOnEditLVItem); - procedure SetOnLVData(const Value: TOnLVData); - procedure SetOnColumnClick(const Value: TOnLVColumnClick); - procedure SetOnDrawItem(const Value: TOnDrawItem); - procedure SetOnMeasureItem(const Value: TOnMeasureItem); - - procedure SetItemsCount(const Value: Integer); - protected - function GetItemData(Idx: Integer): DWORD; - procedure SetItemData(Idx: Integer; const Value: DWORD); - function GetLVCurItem: Integer; - procedure SetLVCurItem(const Value: Integer); - function GetLVFocusItem: Integer; - public - procedure SetOnDropFiles(const Value: TOnDropFiles); - procedure SetOnHide(const Value: TOnEvent); - procedure SetOnShow(const Value: TOnEvent); - procedure SetClientMargin(const Index: Integer; Value: ShortInt); - protected - {$IFDEF F_P} - function GetClientMargin(const Index: Integer): Integer; - {$ENDIF F_P} - {$ENDIF GDI} - protected - {$IFDEF _X_} - {$IFDEF GTK} - {} fExposeEvent: Integer; - {$ENDIF GTK} - {$ENDIF _X_} - public - procedure SetOnPaint(const Value: TOnPaint); - {$IFDEF GDI} - procedure SetOnEraseBkgnd(const Value: TOnPaint); - procedure SetTVRightClickSelect(const Value: Boolean); - procedure SetOnLVStateChange(const Value: TOnLVStateChange); - procedure SetOnMove(const Value: TOnEvent); - procedure SetOnMoving(const Value: TOnEventMoving); - procedure SetColor1(const Value: TColor); - procedure SetColor2(const Value: TColor); - procedure SetGradientLayout(const Value: TGradientLayout); - procedure SetGradientStyle(const Value: TGradientStyle); - protected - procedure SetDroppedDown(const Value: Boolean); - function get_ClassName: KOLString; - procedure set_ClassName(const Value: KOLString); - procedure SetClsStyle( Value: DWord ); - -{$IFDEF GRAPHCTL_XPSTYLES} - function GetEdgeStyle: TEdgeStyle; - procedure SetEdgeStyle( Value: TEdgeStyle ); -{$ENDIF} - - procedure SetStyle( Value: DWord ); - procedure SetExStyle( Value: DWord ); - - procedure SetCursor( Value: HCursor ); - - procedure SetIcon( Value: HIcon ); - procedure SetMenu( Value: HMenu ); - {$ENDIF GDI} - protected - {$IFDEF _X_} - {} fGetCaption: TGetCaption; - {} fSetCaption: TSetCaption; - {$ENDIF _X_} - function GetCaption: KOLString; - procedure SetCaption( const Value: KOLString ); - {$IFDEF GDI} - - public procedure SetWindowState( Value: TWindowState ); - protected - function GetWindowState: TWindowState; - procedure DoClick; - function TBAddInsButtons( Idx: Integer; const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer ): Integer; stdcall; - public procedure SetBitBtnDrawMnemonic(const Value: Boolean); - protected - function GetBitBtnImgIdx: Integer; - procedure SetBitBtnImgIdx(const Value: Integer); - function GetBitBtnImageList: THandle; - procedure SetBitBtnImageList(const Value: THandle); - - function GetModal: Boolean; - {$IFDEF USE_SETMODALRESULT} - procedure SetModalResult( const Value: Integer ); - {$ENDIF} - - {$ENDIF GDI} - protected - {$IFDEF GDI} - fHandle: HWnd; - {$ELSE} - {$IFDEF GTK} {} fHandle: PGtkWidget; - {} fCaptionHandle: PGtkWidget; - {} fEventboxHandle: PGtkWidget; - {} fGetClientArea: TGetClientArea; - {} fClient: PGtkWidget; - {} fChildPut: TChildSetPos; - {} fChildSetPos: TChildSetPos; - {$ENDIF} - {$IFDEF Q_T} fHandle: sometypehere ; {$ENDIF} - {$ENDIF} - {$IFDEF GDI} - fClsStyle: DWord; - fStyle: TStyle; - fExStyle: DWord; - {$ENDIF GDI} - {$IFDEF GDI} - fDefWndProc: Pointer; - {$ENDIF GDI} - FParent: PControl; - - {$IFDEF USE_FLAGS} //................... less memory usage with USE_FLAGS .. - fFlagsG1: T1Flags; - fFlagsG2: T2Flags; - fFlagsG3: T3Flags; - fFlagsG4: T4Flags; - fFlagsG5: T5Flags; - fFlagsG6: T6Flags; - {$ELSE} //.................................................................. - {} fEnabled: Boolean; // Caution!!! fVisible must follow fEnabled! ___ - {} fVisible: Boolean; //____________________________________________// - {} fTabstop: Boolean; - {} fWordWrap: Boolean; - {} fPreventResize: Boolean; - // fCursorShared: Boolean; - {} fIconShared: Boolean; - {} fIgnoreWndCaption: Boolean; - {} fSizeRedraw: Boolean; {YS} - {} fIsStaticControl: Byte; - {} fCannotDoubleBuf: Boolean; - {} fDoubleBuffered: Boolean; - {* True, if cannot set DoubleBuffered to True (RichEdit). } - {* True, if it is static control with a caption. (Mainly, to prevent - flicks in DoubleBuffered mode. } - {} fTransparent: Boolean; - {} fClassicTransparent : Boolean; - // FCreating: Boolean; - {* True, when creating of object is in progress. } - {} fDestroying: Boolean; - {* True, when destroying of the window is started. } - {} fBeginDestroying: Boolean; - {* true, when destroying of the window is initiated by the system, i.e. - message WM_DESTROY fired } - {} fChangedPosSz: Byte; - {* Flags of changing left (1), top (2), width (4) or height (8) } - {} fIsForm: Boolean; - {* True, if the object is form. } - {} fSizeGrip: Boolean; - {} fIsApplet: Boolean; - {* True, if the object represent application taskbar button. } - {} fIsControl: Boolean; - {* True, if it is a control on form. } - {} fIsMDIChild: Boolean; - {* TRUE, if the object is MDI child form. } - {} fCreateHidden: Boolean; - {} fVisibleWoParent: Boolean; - {} fNotUseAlign: Boolean; - {} fNotUpdate: Boolean; // was used for PreventResizeFlicks -- now abandoned - {} fCreateVisible: Boolean; - {} fIsButton: Boolean; - {} fIsBitBtn: Boolean; - {} fIsGroupBox: Boolean; - {} fIsSplitter: Boolean; - {} fIsCommonControl: Boolean; - {* True, if it is common control. } - {} fFlat: Boolean; - {} fMouseInControl: Boolean; - {} fChecked: Boolean; - {} fPushed: Boolean; - {} fHot: Boolean; - {} fFocused: Boolean; - {} fPressed : Boolean; - // fDropped: Boolean; - {} f3ButtonPress: Boolean; - // fEditing: Boolean; - {} fEraseUpdRgn: Boolean; - {} fKeyPreview: Boolean; - {} fKeyPreviewing: Boolean; - {} fIgnoreDefault: Boolean; - {} fDefaultBtn: Boolean; - {} fCancelBtn: Boolean; - {} fWindowed: Boolean; // - {* True, if control is windowed (or is a form). It is set to FALSE only for - graphic controls. } - {} fCtlClsNameChg: Boolean; // - {* True, if control class name changed and memory is allocated to store it. } // - {} fRightClick: Boolean; - {} fDragging: Boolean; - {$ENDIF not USE_FLAGS} //................................................................. - fTextAlign: TTextAlign; - fVerticalAlign: TVerticalAlign; - {$IFDEF STORE_EDGESTYLE} - {} fEdgeStyle : TEdgeStyle; - {$ENDIF} - fLookTabKeys: TTabKeys; - fTabOrder: SmallInt; - fAlphaBlend: Byte; - - // Caution!!! order of following 5 fields is important!!! - fDynHandlers: PList; - fChildren: PList; - {* List of children. } - //________________________________________________________// - {$IFDEF GDI} - - fTmpBrush: HBrush; - {* Brush handle to return in response to some color set messages. - Intended for internal use instead of Brush.Color if possible - to avoid using it. } - {$IFDEF STORE_fTmpBrushColorRGB} - {} fTmpBrushColorRGB: TColor; - {$ENDIF} - { } - public - {$IFDEF COMMANDACTIONS_OBJ} - fCommandActions: PCommandActionsObj; - {$ELSE} - fCommandActions: TCommandActions; - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - EV: PEvents; - protected - function ProvideUniqueEvents: PEvents; - procedure FreeEV; - {$ELSE} - protected - EV: TEvents; - {$ENDIF} - protected - PP: TProcedures; - fMenu: HMenu; - {* Usually used to store handle of attached main menu, but sometimes - is used to store control ID (for standard GUI controls only). } - {$ENDIF GDI} - fMenuObj: PObj; - {* PMenu pointer to TMenu object. Freed automatically with entire - chain of menu objects attached to a control (or form). } - {$IFDEF _X_} - {$IFDEF GTK} - //fMenuBar: PGtkWidget; - {$ENDIF GTK} - {$ENDIF _X_} - {$IFDEF GDI} -{$IFNDEF NEW_MENU_ACCELL} - fAccelTable: HAccel; - procedure DoDestroyAccelTable; -{$ENDIF} - {$ENDIF GDI} - protected - {$IFDEF GDI} - {* Handle of accelerator table created by menu(s). } - fImageList: PImageList; - {* Pointer to first private image list. Control can own several image, - lists, linked to a chain of image list objects. All these image lists - are released automatically, when control is destroyed. } - {$ENDIF GDI} - {$IFDEF GDI} - fUpdRgn: HRgn; - //fCollectUpdRgn: HRGN; - fPaintDC: HDC; - {$ENDIF GDI} - protected - fAutoPopupMenu: PObj; - //fHelpContext: Integer; - - {$IFDEF GTK} - fDeltaX, fDeltaY: Integer; - {$ENDIF GTK} - // Order of following fields is important: - //_______________________________________________________________________________________________ - //{$ENDIF GDI} - {$IFDEF GDI} - // // - {$ENDIF GDI} - fTextColor: TColor; // - {* Color of text. Used instead of fFont.Color internally to // - avoid usage of Font object if user is not accessing and changing it. } // - fColor: TColor; // - {* Color of control background. } // - fFont: PGraphicTool; // - fBrush: PGraphicTool; // - fMargin: ShortInt; // - fClientTop: ShortInt; - fClientBottom: ShortInt; - fClientLeft: ShortInt; - fClientRight: ShortInt; // - {* Store adjustment factor of ClientRect for some 'idiosincrasies' windows, // - such as Groupbox or Tabcontrol. } // - fCtl3D_child: Byte; // - fBoundsRect: TRect; // - fCursor: HCursor; - //_____________________________________________________________________________________________// - // this is the end of fiels set, which order is important - fCanvas: PCanvas; - {$IFDEF GDI} - fDblExcludeRgn: HDC; - - {$ENDIF GDI} - {$IFDEF GTK} - {} fClickedEvent: Integer; - {$ENDIF} - public - procedure SetOnClick( const Value: TOnEvent ); - protected - {$IFDEF GDI} - //fRadio1st: THandle; - //fRadioLast : THandle; - //fDropDownProc: procedure( Sender : PObj ); - //fPrevWndProc: Pointer; - - fCurIndex: Integer; - - //fOldDefWndProc: Pointer; - procedure SetSBMax(Value: Longint); - procedure SetSBMin(Value: Longint); - procedure SetSBPageSize(Value: Integer); - procedure SetSBPosition(Value: Integer); - procedure SetSBMinMax(const Value: TPoint); - protected - procedure SetOnLVCustomDraw(const Value: TOnLVCustomDraw); - {$ENDIF GDI} - protected - {$IFDEF GDI} - //fPaintMsg: TMsg; - - {$ENDIF GDI} - FMaxWidth: SmallInt; - FMinWidth: SmallInt; - FMaxHeight: SmallInt; - FMinHeight: SmallInt; - {$IFDEF GDI} - fStatusCtl: PControl; - //fStatusTxt: PKOLChar; - {$ENDIF GDI} - {$IFDEF GDI} - //fDragStartPos: TSmallPoint; - //fMouseStartPos: TSmallPoint; - {$IFDEF FIX_WIDTH_HEIGHT} - {} FFixWidth: Integer; - {} FFixHeight: Integer; - {$ENDIF} - {$ENDIF GDI} - //----- order of following 3 fields important: // - fCaption: KOLString; - fCustomData: Pointer; - fControlClassName: PKOLChar; // - {$IFDEF GDI} - //---------------------------------------------// - fCustomObj: PObj; - public - DF: TDataFields; - {* Data fields for certain controls. These are overlapped to - economy size of TControl object. } - //fCreateParamsExt: procedure( Self_: PControl; var Params: TCreateParams ); - protected - - {$IFDEF USE_MHTOOLTIP} - {$DEFINE var} - fHint: PMHHint; - {$UNDEF var} - - {$DEFINE function} - function GetHint: PMHHint; - {$UNDEF function} - {$ENDIF} - - {$ENDIF GDI} - - procedure Init; virtual; - {$IFDEF GDI} - procedure InitParented( AParent: PControl ); virtual; - {* Initialization of visual object. } - procedure InitOrthaned( AParentWnd: HWnd ); virtual; - {* Initialization of visual object. } - {$ENDIF GDI} - {$IFDEF _X_} - {$IFDEF GTK} - PROCEDURE InitParented( AParent: PControl; widget: PGtkWidget; - {}need_eventbox: Boolean ); VIRTUAL; - {* Initialization of visual object. } - {$ENDIF GTK} - {$ENDIF _X_} - {$IFDEF GDI} - procedure DestroyChildren; - {* Destroys children. Is called in destructor, and can be - called in descending classes as earlier as needed to - prevent problems of too late destroying of visuals. - |
- Note: since v 2.40, used only for case when a symbol NOT_USE_AUTOFREE4CONTROLS - is defined, otherwise all children are destroyed using common mechanism of - Add2AutoFree. } - - function GetParentWnd( NeedHandle: Boolean ): HWnd; - {* Returns handle of parent window. } - function GetParentWindow: HWnd; - {* } - procedure SetEnabled( Value: Boolean ); - {* Changes Enabled property value. Overriden here to change enabling - status of a window. } - function GetEnabled: Boolean; - {* Returns True, if Enabled. Overriden here to obtain real window - state. } - procedure SetVisible( Value: Boolean ); - {* Sets Visible property value. Overriden here to change visibility - of correspondent window. } - procedure Set_Visible( Value: Boolean ); - {* } - function GetVisible: Boolean; - {* Returns True, if correspondent window is Visible. Overriden - to get visibility of real window, not just value stored in object. } - function Get_Visible: Boolean; - {* Returns True, if correspondent window is Visible, for forms and applet, - or if fVisible flag is set, for controls. } - protected - {$ENDIF GDI} - procedure SetCtlColor( Value: TColor ); - {* Sets TControl's Color property value. } - procedure SetBoundsRect( const Value: TRect ); - {* Sets BoudsRect property value. } - function GetBoundsRect: TRect; - {* Returns bounding rectangle. } - {$IFDEF GDI} - function GetIcon: HIcon; - {* Returns Icon property. By default, if it is not set, - returns Icon property of an Applet. } - - procedure CreateSubclass( var Params: TCreateParams; ControlClassName: PKOLChar ); - {* Can be used in descending classes to subclass window with given - standard Windows ControlClassName - must be called after - creating Params but before CreateWindow. Usually it is called - in overriden method CreateParams after calling of the inherited one. } - - function UpdateWndStyles: PControl; - public - {* Updates fStyle, fExStyle, fClsStyle from window handle } - procedure SetOnChar(const Value: TOnChar); - {* } - {$IFDEF SUPPORT_ONDEADCHAR} - procedure SetOnDeadChar(const Value: TOnChar); - {* } - {$ENDIF SUPPORT_ONDEADCHAR} - procedure SetOnKeyDown(const Value: TOnKey); - {* } - procedure SetOnKeyUp(const Value: TOnKey); - {* } - {$ENDIF GDI} - {$IFDEF GDI} - procedure SetHelpContext( Value: Integer ); - {* } - procedure SetOnTVDelete( const Value: TOnTVDelete ); - {* } - public procedure SetDefaultBtn(const Index: Integer; const Value: Boolean); - protected - function GetDefaultBtn(const Index: Integer): Boolean; - function DefaultBtnProc( var Msg: TMsg; var Rslt: Integer ): Boolean; - {* } - - procedure SetDateTime( Value: TDateTime ); - function GetDateTime: TDateTime; - procedure SetDateTimeRange( Value: TDateTimeRange ); - function GetDateTimeRange: TDateTimeRange; - procedure SetDateTimePickerColor( Index: TDateTimePickerColor; Value: TColor ); - function GetDateTimePickerColor( Index: TDateTimePickerColor ): TColor; - procedure SetDateTimeFormat( const Value: KOLString ); - function Get_SystemTime: TSystemTime; - procedure Set_SystemTime(const Value: TSystemTime); - - procedure SetOnTBCustomDraw( const Value: TOnTBCustomDraw ); - - {$ENDIF GDI} - procedure DoAutoSize; - - public - {$IFDEF GDI} - constructor CreateParented( AParent: PControl ); - {* Creates new instance of TControl object, calling InitParented } - constructor CreateOrthaned( AParentWnd: HWnd ); - {* Creates new instance of TControl object, calling InitOrthaned } - {$ENDIF GDI} - {$IFDEF _X_} - {$IFDEF GTK} - CONSTRUCTOR CreateParented( AParent: PControl; widget: PGtkWidget; - {}need_eventbox: Boolean ); - {* Creates new instance of TControl object, calling InitParented } - {$ENDIF GTK} - {$ENDIF _X_} - {$IFDEF GDI} - destructor Destroy; virtual; - {* Destroyes object. First of all, destructors for all children - are called. } - - function GetWindowHandle: HWnd; - {* Returns window handle. If window is not yet created, - method CreateWindow is called. } - procedure CreateChildWindows; - {* Enumerates all children recursively and calls CreateWindow for all - of these. } - {$ENDIF GDI} - property Parent: PControl read fParent write SetParent; - {* Parent of TParent object. Also must be of TParent type or derived from TParent. } - //property Tag: Integer read FTag write FTag; //--------- moved to TObj -------- - {* User-defined pointer, which can contain any data or reference to - anywhere in memory (when used as a pointer). - } - function ChildIndex( Child: PControl ): Integer; - {* Returns index of given child. } - procedure MoveChild( Child: PControl; NewIdx: Integer ); - {* Moves given Child into new position. } - - {$IFDEF GDI} - property Enabled: Boolean read GetEnabled write SetEnabled; - {* Enabled usually used to decide if control can get keyboard focus - or been clicked by mouse. } - procedure EnableChildren( Enable, Recursive: Boolean ); - {* Enables (Enable = TRUE) or disables (Enable = FALSE) all the children - of the control. If Recursive = TRUE then all the children of all the - children are enabled or disabled recursively. } - property Visible: Boolean read Get_Visible write SetVisible; - {* Obvious. } - property ToBeVisible: Boolean read GetToBeVisible; - {* Returns True, if a control is supposed to be visible when its - form is showing. } - property CreateVisible: Boolean - read {$IFDEF USE_FLAGS} GetCreateVisible {$ELSE} fCreateVisible {$ENDIF} - write {$IFDEF USE_FLAGS} SetCreateVisible {$ELSE} fCreateVisible {$ENDIF}; - {* False by default. If You want your form to be created visible and - flick due creation, set it to True. This does not affect size of - executable anyway. } - {$ENDIF GDI} - property BoundsRect: TRect read GetBoundsRect write SetBoundsRect; - {* Bounding rectangle of the visual. Coordinates are relative - to top left corner of parent's ClientRect, or to top left corner - of screen (for TForm). } - property Left: Integer read GetLeft write SetLeft; - {* Left horizontal position. } - property Top: Integer read GetTop write SetTop; - {* Top vertical position. } - property Width: Integer read GetWidth write SetWidth; - {* Width of TVisual object. } - property Height: Integer read GetHeight write SetHeight; - {* Height of TVisual object. } - property Position: TPoint read GetPosition write Set_Position; - {* Represents top left position of the object. See also BoundsRect. } - {$IFDEF GDI} - property MinWidth: SmallInt index 0 - {$IFDEF F_P} read GetConstraint - {$ELSE DELPHI} read FMinWidth - {$ENDIF F_P/DELPHI} write SetConstraint; - {* Minimal width constraint. } - property MinHeight: SmallInt index 1 - {$IFDEF F_P} read GetConstraint - {$ELSE DELPHI} read FMinHeight - {$ENDIF F_P/DELPHI} write SetConstraint; - {* Minimal height constraint. } - property MaxWidth: SmallInt index 2 - {$IFDEF F_P} read GetConstraint - {$ELSE DELPHI} read FMaxWidth - {$ENDIF F_P/DELPHI} write SetConstraint; - {* Maximal width constraint. } - property MaxHeight: SmallInt index 3 - {$IFDEF F_P} read GetConstraint - {$ELSE DELPHI} read FMaxHeight - {$ENDIF F_P/DELPHI} write SetConstraint; - {* Maximal height constraint. } - - {$ENDIF GDI} - function ClientRect: TRect; - {* Client rectangle of TControl. Contrary to VCL, for some - classes (e.g. for graphic controls) can be relative - not to itself, but to top left corner of the parent's ClientRect - rectangle. } - {$IFDEF GDI} - property ClientWidth: Integer read GetClientWidth write SetClientWidth; - {* Obvious. Accessing this property, program forces window latent creation. } - property ClientHeight: Integer read GetClientHeight write SetClientHeight; - {* Obvious. Accessing this property, program forces window latent creation. } - - function ControlRect: TRect; - {* Absolute bounding rectangle relatively to nearest - Windowed parent client rectangle (at least to a form, but usually to - a Parent). - Useful while drawing on device context, provided by such - Windowed parent. For form itself is the same as BoundsRect. } - - function ControlAtPos( X, Y: Integer; IgnoreDisabled: Boolean ): PControl; - {* Searches control at the given position (relatively to top left - corner of the ClientRect). } - {$ENDIF GDI} - procedure Invalidate; - {* Invalidates rectangle, occupied by the visual (but only if Showing = - True). } - {$IFDEF GDI} - public - procedure InvalidateEx; - {* Invalidates the window and all its children. } - procedure InvalidateNC( Recursive: Boolean ); - {* Invalidates the window and all its children including non-client area. } - procedure Update; - {* Updates control's window and calls Update for all child controls. } - procedure BeginUpdate; - {* |<#treeview> - |<#listview> - |<#richedit> - |<#memo> - |<#listbox> - Call this method to stop visual updates of the control until correspondent - EndUpdate called (pairs BeginUpdate - EndUpdate can be nested). } - procedure EndUpdate; - {* See BeginUpdate. } - - property Windowed: Boolean - read {$IFDEF USE_FLAGS} GetWindowed {$ELSE} fWindowed {$ENDIF} - write {$IFDEF USE_FLAGS} SetWindowed {$ELSE} fWindowed {$ENDIF}; - {* Constantly returns True, if object is windowed (i.e. owns - correspondent window handle). Otherwise, returns False. - |
- By now, all the controls are windowed (there are no controls in KOL, which are - emulating window, acually belonging to Parent - like TGraphicControl - in VCL). - |
- Writing of this property provided only for internal purposes, - do not change it directly unless you understand well what you do. } - - function HandleAllocated: Boolean; - {* Returns True, if window handle is allocated. Has no sense for - non-Windowed objects (but now, the KOL has no non-Windowed controls). } - {$ENDIF GDI} - - property ChildCount: Integer read GetChildCount; - {* Returns number of commonly accessed child objects. } - property Children[ Idx: Integer ]: PControl read GetMembers; - {* Child items of TVisual object. Property is reintroduced here - to separate access to always visible Children[] from restricted - a bit Members[]. } - {$IFDEF GDI} - procedure PaintBackground( DC: HDC; Rect: PRect ); - {* Is called to paint background in given rectangle. This - method is filling clipped area of the Rect rectangle with - Color, but only if global event Global_OnPaintBkgnd is - not assigned. If assigned, this one is called instead here. - |
    - This method made public, so it can be called directly to - fill some device context's rectangle. But remember, that - independantly of Rect, top left corner of background piece - will be located so, if drawing is occure into ControlRect - rectangle. } - property WindowedParent: PControl read fParent; - {* Returns nearest windowed parent, the same as Parent. } - {$ENDIF GDI} - function ParentForm: PControl; - {* |<#form> - Returns parent form for a control (of @Self for form itself. } - function FormParentForm: PControl; - {* |<#form> - Returns parent form for a control (of @Self for form itself. For a frame, - returns frame panel instead. } - function MarkPanelAsForm: PControl; - {* Special function for MCK to mark panel as frame parent control. } - {$IFDEF GDI} - property ActiveControl: PControl read DF.fCurrentControl write DF.fCurrentControl; - {* } - function Client2Screen( const P: TPoint ): TPoint; - {* Converts the client coordinates of a specified point to screen coordinates. } - function Screen2Client( const P: TPoint ): TPoint; - {* Converts screen coordinates of a specified point to client coordinates. } - function CreateWindow: Boolean; virtual; - {* |<#form> - Creates correspondent window object. Returns True if success (if - window is already created, False is returned). If applied to a form, - all child controls also allocates handles that time. - |
    - Call this method to ensure, that a hanle is allocated for a form, - an application button or a control. (It is not necessary to do so in - the most cases, even if You plan to work with control's handle directly. - But immediately after creating the object, if You want to pass its - handle to API function, this can be helpful). } - {$ENDIF GDI} - {$IFDEF _X_} - procedure VisualizyWindow; // for _X_, makes actually visible a window and - // all its subwindows recursively, if they are having Visible = TRUE - {$ENDIF _X_} - {$IFDEF GDI} - procedure Close; - {* |<#appbutton> - |<#form> - Closes window. If a window is the main form, this closes application, - terminating it. Also it is possible to call Close method for Applet - window to stop application. } - - {$IFDEF USE_MHTOOLTIP} - {$DEFINE public} - property Hint: PMHHint read GetHint; - {$UNDEF public} - {$ENDIF} - - property Handle: HWnd read fHandle; //GetHandle; - {* Returns descriptor of system window object. If window is not yet - created, 0 is returned. To allocate handle, call CreateWindow method. } - - property ParentWindow: HWnd read GetParentWindow; - {* Returns handle of parent window (not TControl object, but system - window object handle). } - property ClsStyle: DWord read fClsStyle write SetClsStyle; - {* Window class style. Available styles are: - | - |&L= - |&N=
    - - Aligns the window's client area on the byte boundary - (in the x direction) to enhance performance during - drawing operations. - - Aligns a window on a byte boundary (in the x - direction). - - Allocates one device context to be shared by all - windows in the class. - - Sends double-click messages to the window - procedure when the user double-clicks the mouse while the - cursor is within a window belonging to the class. - - Allows an application to create a window of - the class regardless of the value of the hInstance parameter. - You can create a global class by creating - the window class in a dynamic-link library (DLL) and listing the - name of the DLL in the registry under specific keys. - - Redraws the entire window if a movement or - size adjustment changes the width of the client area. - - Disables the Close command on the System menu. - - Allocates a unique device context for each window - in the class. - - Sets the clipping region of the child window to - that of the parent window so that the child can draw on the parent. - - Saves, as a bitmap, the portion of the screen - image obscured by a window. Windows uses the saved bitmap to re-create - the screen image when the window is removed. - - Redraws the entire window if a movement or size - adjustment changes the height of the client area. - |
%1 - |&E=
For more info, see Win32.hlp (keyword 'WndClass'); - } - - -{$IFDEF GRAPHCTL_XPSTYLES} - property edgeStyle : TEdgeStyle - read {$IFnDEF STORE_EDGESTYLE} GetEdgeStyle {$ELSE} fEdgeStyle {$ENDIF} - write SetEdgeStyle; -{$ENDIF} - - property Style: DWord read fStyle.Value write SetStyle; - {* Window styles. Available styles are: - | - Creates a window that has a thin-line border. - Creates a window that has a title bar (includes the - WS_BORDER style). - Creates a child window. This style cannot be used with - the WS_POPUP style. - Same as the WS_CHILD style. - Excludes the area occupied by child windows - when drawing occurs within the parent window. This style is used - when creating the parent window. - Clips child windows relative to each other; - that is, when a particular child window receives a WM_PAINT message, - the WS_CLIPSIBLINGS style clips all other overlapping child windows - out of the region of the child window to be updated. If - WS_CLIPSIBLINGS is not specified and child windows overlap, it is - possible, when drawing within the client area of a child window, - to draw within the client area of a neighboring child window. - Creates a window that is initially disabled. A - disabled window cannot receive input from the user. - Creates a window that has a border of a style - typically used with dialog boxes. A window with this style cannot - have a title bar. - Specifies the first control of a group of controls. - The group consists of this first control and all controls defined - after it, up to the next control with the WS_GROUP style. - The first control in each group usually has the WS_TABSTOP - style so that the user can move from group to group. The user - can subsequently change the keyboard focus from one control in - the group to the next control in the group by using the direction - keys. - Creates a window that has a horizontal scroll bar. - Creates a window that is initially minimized. Same as - the WS_MINIMIZE style. - Creates a window that is initially maximized. - Creates a window that has a Maximize button. - Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU - style must also be specified. - Creates a window that is initially minimized. - Same as the WS_ICONIC style. - Creates a window that has a Minimize button. - Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU - style must also be specified. - Creates an overlapped window. An overlapped - window has a title bar and a border. Same as the WS_TILED style. - Creates an overlapped window with the - WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME, WS_MINIMIZEBOX, - and WS_MAXIMIZEBOX styles. Same as the WS_TILEDWINDOW style. - Creates a pop-up window. This style cannot be used with - the WS_CHILD style. - Creates a pop-up window with WS_BORDER, - WS_POPUP, and WS_SYSMENU styles. The WS_CAPTION and WS_POPUPWINDOW - styles must be combined to make the window menu visible. - Creates a window that has a sizing border. Same as the - WS_THICKFRAME style. - Creates a window that has a window-menu on its title - bar. The WS_CAPTION style must also be specified. - Specifies a control that can receive the keyboard focus - when the user presses the TAB key. Pressing the TAB key changes - the keyboard focus to the next control with the WS_TABSTOP style. - Creates a window that has a sizing border. - Same as the WS_SIZEBOX style. - Creates an overlapped window. An overlapped window has - a title bar and a border. Same as the WS_OVERLAPPED style. - Creates an overlapped window with the - WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME, - WS_MINIMIZEBOX, and WS_MAXIMIZEBOX styles. Same as the - WS_OVERLAPPEDWINDOW style. - Creates a window that is initially visible. - Creates a window that has a vertical scroll bar. - |
- See also Win32.hlp (topic CreateWindow). - } - property ExStyle: DWord read fExStyle write SetExStyle; - {* Extra window styles. Available flags are following: - | - Specifies that a window created with this style - accepts drag-drop files. - Forces a top-level window onto the taskbar - when the window is minimized. - Specifies that a window has a border with a - sunken edge. - Includes a question mark in the title bar of - the window. When the user clicks the question mark, the cursor - changes to a question mark with a pointer. If the user then clicks - a child window, the child receives a WM_HELP message. The child - window should pass the message to the parent window procedure, - which should call the WinHelp function using the HELP_WM_HELP - command. The Help application displays a pop-up window that - typically contains help for the child window.WS_EX_CONTEXTHELP - cannot be used with the WS_MAXIMIZEBOX or WS_MINIMIZEBOX styles. - Allows the user to navigate among the child - windows of the window by using the TAB key. - Creates a window that has a double border; - the window can, optionally, be created with a title bar by - specifying the WS_CAPTION style in the dwStyle parameter. - Window has generic "left-aligned" properties. This - is the default. - If the shell language is Hebrew, Arabic, or - another language that supports reading order alignment, the - vertical scroll bar (if present) is to the left of the client - area. For other languages, the style is ignored and not treated - as an error. - The window text is displayed using Left to - Right reading-order properties. This is the default. - Creates an MDI child window. - Specifies that a child window created - with this style does not send the WM_PARENTNOTIFY message to its - parent window when it is created or destroyed. - Combines the WS_EX_CLIENTEDGE and - WS_EX_WINDOWEDGE styles. - Combines the WS_EX_WINDOWEDGE, - WS_EX_TOOLWINDOW, and WS_EX_TOPMOST styles. - Window has generic "right-aligned" properties. - This depends on the window class. This style has an effect only - if the shell language is Hebrew, Arabic, or another language that - supports reading order alignment; otherwise, the style is - ignored and not treated as an error. - Vertical scroll bar (if present) is to the - right of the client area. This is the default. - If the shell language is Hebrew, Arabic, or - another language that supports reading order alignment, the - window text is displayed using Right to Left reading-order - properties. For other languages, the style is ignored and not - treated as an error. - Creates a window with a three-dimensional - border style intended to be used for items that do not accept - user input. - Creates a tool window; that is, a window - intended to be used as a floating toolbar. A tool window has - a title bar that is shorter than a normal title bar, and the - window title is drawn using a smaller font. A tool window does - not appear in the taskbar or in the dialog that appears when - the user presses ALT+TAB. - Specifies that a window created with this style - should be placed above all non-topmost windows and should stay - above them, even when the window is deactivated. To add or remove - this style, use the SetWindowPos function. - Specifies that a window created with this - style is to be transparent. That is, any windows that are - beneath the window are not obscured by the window. A window - created with this style receives WM_PAINT messages only after - all sibling windows beneath it have been updated. - Specifies that a window has a border with - a raised edge. - |
- See also Win32.hlp (topic CreateWindowEx). - } - - property Cursor: HCursor read fCursor write SetCursor; - {* Current cursor. For most of controls, sets initially to IDC_ARROW. See - also ScreenCursor. } - procedure CursorLoad( Inst: Integer; ResName: PKOLChar ); - {* Loads Cursor from the resource. See also comments for Icon property. } - - property Icon: HIcon read {$IFDEF SMALLEST_CODE} DF.fIcon {$ELSE} GetIcon {$ENDIF} - write SetIcon; - {* |<#appbutton> - |<#form> - Icon. By default, icon of the Applet is used. To load icon from the - resource, use IconLoad or IconLoadCursor method - this is more correct, because - in such case a special flag is set to prevent attempts to destroy - shared icon object in the destructor of the control. } - - procedure IconLoad( Inst: Integer; ResName: PKOLChar ); - {* |<#appbutton> - |<#form> - See Icon property. } - procedure IconLoadCursor( Inst: Integer; ResName: PKOLChar ); - {* |<#appbutton> - |<#form> - Loads Icon from the cursor resource. See also Icon property. } - - property Menu: HMenu read fMenu write SetMenu; - - {* Menu (or ID of control - for standard GUI controls). } - property HelpContext: Integer read GetHelpContext write SetHelpContext; - {* Help context. } - function AssignHelpContext( Context: Integer ): PControl; - {* Assigns HelpContext and returns @ Self (can be used in initialization - of a control in a chain of "transparent" calls). } - - procedure CallHelp( Context: Integer; CtxCtl: PControl {; CtlID: Integer} ); - {* Method of a form or Applet. Call it to show help with the given context - ID. If the Context = 0, help contents is displayed. By default, - WinHelp is used. To allow using HtmlHelp, call AssignHtmlHelp global - function. When WinHelp used, HelpPath variable can be assigned directly. - If HelpPath variable is not assigned, application name - (and path) is used, with extension replaced to '.hlp'. } - - property HelpPath: KOLString read GetHelpPath write SetHelpPath; - {* Property of a form or an Applet. Change it to provide custom path to - WinHelp format help file. If HtmlHelp used, call global procedure - AssignHtmlHelp instead. } - - property OnHelp: TOnHelp - read {$IFDEF EVENTS_DYNAMIC} Get_OnHelp {$ELSE} EV.fOnHelp {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnHelp {$ELSE} EV.fOnHelp {$ENDIF}; - {* An event of a form, it is called when F1 pressed or help topic requested - by any other way. To prevent showing help, nullify Sender. Set Popup to - TRUE to provide showing help in a pop-up window. It is also possible to - change Context dynamically. } - - {$ENDIF GDI} - property Caption: KOLString read GetCaption write SetCaption; - {* |<#appbutton> - |<#form> - |<#button> - |<#bitbtn> - |<#label> - |<#wwlabel> - |<#3dlabel> - Caption of a window. For standard Windows buttons, labels and so on - not a caption of a window, but text of the window. } - property Text: KOLString read GetCaption write SetCaption; - {* |<#edit> - |<#memo> - The same as Caption. To make more convenient with Edit controls. For - Rich Edit control, use property RE_Text. } - - {$IFDEF GDI} - property SelStart: Integer read GetSelStart write SetSelStart; - {* |<#edit> - |<#memo> - |<#richedit> - Start of selection (editbox - character position). } - property SelLength: Integer read GetSelLength write SetSelLength; - {* |<#edit> - |<#memo> - |<#richedit> - |<#listbox> - |<#listview> - Length of selection (editbox - number of characters selected, multiselect - listbox or listview - number of items selected). - |
- Note, that for combobox and single-select listbox it always returns 0 - (though for single-select listview, returns 1, if there is an item - selected). - |
- It is possible to set SelLength only for memo and richedit controls. } - - property Selection: KOLString read GetSelection write SetSelection; - {* |<#edit> - |<#memo> - |<#richedit> - Selected text (editbox, richedit) as string. Can be useful to replace - selection. For rich edit, use RE_Text[ reText, TRUE ], if you want to - read correctly characters from another locale then ANSI only. } - procedure SelectAll; - {* |<#edit> - |<#memo> - |<#richedit> - Makes all the text in editbox or RichEdit, or all items in listbox - selected. } - - procedure ReplaceSelection( const Value: KOLString; aCanUndo: Boolean ); - {* |<#edit> - |<#memo> - |<#richedit> - Replaces selection (in edit, RichEdit). Unlike assigning new value - to Selection property, it is possible to specify, if operation can - be undone. - |
- Use this method or assigning value to a Selection property to format - text initially in the rich edit. E.g.: - ! RichEdit1.RE_FmtBold := TRUE; - ! RichEdit1.Selection := 'bolded text'#13#10; - ! RichEdit1.RE_FmtBold := FALSE; - ! RichEdit1.RE_FmtItalic := TRUE; - ! RichEdit1.Selection := 'italized text'; - !... } - - procedure DeleteLines( FromLine, ToLine: Integer ); - {* |<#edit> - |<#memo> - |<#richedit> - Deletes lines from FromLine to ToLine (inclusively, i.e. 0 to 0 deletes - one line with index 0). Current selection is restored as possible. } - property CurIndex: Integer read GetCurIndex write SetCurIndex; - {* |<#listbox> - |<#combo> - |<#toolbar> - Index of current item (for listbox, combobox) or button index pressed - or dropped down (for toolbar button, and only in appropriate event - handler call). - |
- You cannot use it to set or remove a selection in a multiple-selection - list box, so you should set option loNoExtendSel to true. - |
- In OnClick event handler, CurIndex has not yet changed for listbox or combobox. - Use OnSelChange to respond to selection changes. } - - property Count: Integer read GetItemsCount write SetItemsCount; - {* |<#listbox> - |<#combo> - |<#listview> - |<#treeview> - |<#edit> - |<#memo> - |<#richedit> - |<#toolbar> - Number of items (listbox, combobox, listview) or lines (multiline - editbox, richedit control) or buttons (toolbar). It is possible to - assign a value to this property only for listbox control with loNoData - style and for list view control with lvoOwnerData style (virtual list - box and list view). } - - property Items[ Idx: Integer ]: KOLString read GetItems write SetItems; - {* |<#edit> - |<#listbox> - |<#combo> - |<#memo> - |<#richedit> - Obvious. Used with editboxes, listbox, combobox. With list view, use - property LVItems instead. } - - function Item2Pos( ItemIdx: Integer ): DWORD; - {* |<#edit> - |<#memo> - Only for edit controls: converts line index to character position. } - function Pos2Item( Pos: Integer ): DWORD; - {* |<#edit> - |<#memo> - Only for edit controls: converts character position to line index. } - - function SavePosition: TEditPositions; - {* |<#edit> - |<#memo> - Only for edit controls: saves current editor selection and scroll - positions. To restore position, use RestorePosition with a structure, - containing saved position as a parameter. } - procedure RestorePosition( const p: TEditPositions ); - {* |<#edit> - |<#memo> - Call RestorePosition with a structure, containing saved position - as a parameter (this structure filled in in SavePosition method). - If you set RestoreScroll to FALSE, only selection is restored, - without scroll position. } - procedure UpdatePosition( var p: TEditPositions; FromPos, - CountInsertDelChars, CountInsertDelLines: Integer ); - {* |<#edit> - |<#memo> - If you called SavePosition and then make some changes in the edit control, - calling RestorePosition will fail if chages are affecting selection size. - The problem can be solved updating saved position info using this method. - Pass a count of inserted characters and lines as a positive number and a - count of deleted characters as a negative number here. CountInsertDelLines - is optional paramters: if you do not specify it, only selection is fixed. - } - - function EditTabChar: PControl; - {* |<#edit> - |<#memo> - Call this method (once) to provide insertion of tab character (code #9) - when tab key is pressed on keyboard. } - - function IndexOf( const S: KOLString ): Integer; - {* |<#listbox> - |<#combobox> - |<#tabcontrol> - Works for the most of control types, though some of those - have its own methods to search given item. If a control is not - list box or combobox, item is finding by enumerating all - the Items one by one. See also SearchFor method. } - function SearchFor( const S: KOLString; StartAfter: Integer; Partial: Boolean ): Integer; - {* |<#listbox> - |<#combobox> - |<#tabcontrol> - Works for the most of control types, though some of those - have its own methods to search given item. If a control is not - list box or combobox, item is finding by enumerating all - the Items one by one. See also IndexOf method. } - - property ItemSelected[ ItemIdx: Integer ]: Boolean read GetItemSelected write SetItemSelected; - {* |<#edit> - |<#memo> - |<#listbox> - |<#combo> - |<#listview> - Returns True, if a line (in editbox) or an item (in listbox, combobox, - listview) is selected. - Can be set only for listboxes. For listboxes, which are not multiselect, and - for combo lists, it is possible only to set to True, to change selection. } - - property ItemData[ Idx: Integer ]: DWORD read GetItemData write SetItemData; - {* |<#listbox> - |<#combo> - Access to user-defined data, associated with the item of a list box and - combo box. } - property OnDropDown: TOnEvent index idx_FOnDropDown - read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnDropDown {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnDropDown {$ENDIF}; - {* |<#combo> - |<#toolbar> - Is called when combobox is dropped down (or drop-down button of - toolbar is pressed - see also OnTBDropDown). } - property OnCloseUp: TOnEvent index idx_FOnCloseUp - read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnCloseUp {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnCloseUp {$ENDIF}; - {* |<#combo> - Is called when combobox is closed up. When drop down list is closed - because user pressed "Escape" key, previous selection is restored. - To test if it is so, call GetKeyState( VK_ESCAPE ) and check, if - negative value is returned (i.e. Escape key is pressed when event - handler is calling). } - property DroppedWidth: Integer read DF.FDroppedWidth write SetDroppedWidth; - {* |<#combo> - Allows to change width of dropped down items list for combobox (only!) - control. } - property DroppedDown: Boolean read GetDroppedDown write SetDroppedDown; - {* |<#combo> - Dropped down state for combo box. Set it to TRUE or FALSE to change - dropped down state. } - procedure AddDirList( const Filemask: KOLString; Attrs: DWORD ); - {* |<#listbox> - |<#combo> - Can be used only with listbox and combobox - to add directory list items, - filtered by given Filemask (can contain wildcards) and Attrs. Following - flags can be combined in Attrs: - | - |&L=
%1 - Include archived files. - Includes subdirectories. Subdirectory names are - enclosed in square brackets ([ ]). - Includes drives. Drives are listed in the form [-x-], - where x is the drive letter. - Includes only files with the specified attributes. - By default, read-write files are listed even if DDL_READWRITE is - not specified. Also, this flag needed to list directories only, - etc. - Includes hidden files. - Includes read-only files. - Includes read-write files with no additional - attributes. - Includes system files. -
- If the listbox is sorted, directory items will be sorted (alpabetically). } - property OnBitBtnDraw: TOnBitBtnDraw - read {$IFDEF EVENTS_DYNAMIC} Get_OnBitBtnDraw {$ELSE} EV.fOnBitBtnDraw {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnBitBtnDraw {$ELSE} EV.fOnBitBtnDraw {$ENDIF}; - {* |<#bitbtn> - Special event for BitBtn. Using it, it is possible to provide - additional effects, such as highlighting button text (by changing - its Font and other properties). If the handler returns True, it is - supposed that it made all drawing and there are no further drawing - occure. } - property BitBtnDrawMnemonic: Boolean read DF.fBitBtnDrawMnemonic write SetBitBtnDrawMnemonic; - {* |<#bitbtn> - Set this property to TRUE to provide correct drawing of bit btn control - caption with '&' characters (to remove such characters, and underline - follow ones). } - property TextShiftX: Integer read DF.fTextShiftX write DF.fTextShiftX; - {* |<#bitbtn> - Horizontal shift for bitbtn text when the bitbtn is pressed. } - property TextShiftY: Integer read DF.fTextShiftY write DF.fTextShiftY; - {* |<#bitbtn> - Vertical shift for bitbtn text when the bitbtn is pressed. } - property BitBtnImgIdx: Integer read GetBitBtnImgIdx write SetBitBtnImgIdx; - {* |<#bitbtn> - BitBtn image index for the first image in list view, used as bitbtn - image. It is used only in case when BitBtn is created with bboImageList - option. } - property BitBtnImgList: THandle read GetBitBtnImageList write SetBitBtnImageList; - {* |<#bitbtn> - BitBtn Image list. Assign image list handle to change it. } - - function SetButtonIcon( aIcon: HIcon ): PControl; - {* |<#button> - Sets up button icon image and changes its styles. Returns button itself. } - function SetButtonBitmap( aBmp: HBitmap ): PControl; - {* |<#button> - Sets up button icon image and changes its styles. Returns button itself. } - - property OnMeasureItem: TOnMeasureItem - read {$IFDEF EVENTS_DYNAMIC} Get_OnMeasureItem {$ELSE} EV.fOnMeasureItem {$ENDIF} - write SetOnMeasureItem; - {* |<#combo> - |<#listbox> - |<#listview> - This event is called for owner-drawn controls, such as list box, combo box, - list view with appropriate owner-drawn style. For fixed item height controls - (list box with loOwnerDrawFixed style, combobox with coOwnerDrawFixed and - list view with lvoOwnerDrawFixed option) this event is called once. For - list box with loOwnerDrawVariable style and for combobox with coOwnerDrawVariable - style this event is called for every item. } - - property DefaultBtn: Boolean index 13 - {$IFDEF F_P} read GetDefaultBtn - {$ELSE DELPHI} read {$IFDEF USE_FLAGS} GetDefaultBtn {$ELSE} fDefaultBtn {$ENDIF} - {$ENDIF F_P/DELPHI} write SetDefaultBtn; - {* |<#button> - |<#bitbtn> - Set this property to true to make control clicked when ENTER key is pressed. - This property uses OnMessage event of the parent form, storing it into - fOldOnMessage field and calling in chain. So, assign default button - after setting OnMessage event for the form. } - property CancelBtn: Boolean index 27 - {$IFDEF F_P} read GetDefaultBtn - {$ELSE DELPHI} read {$IFDEF USE_FLAGS} GetDefaultBtn {$ELSE} fCancelBtn {$ENDIF} - {$ENDIF F_P/DELPHI} write SetDefaultBtn; - {* |<#button> - |<#bitbtn> - Set this property to true to make control clicked when escape key is pressed. - This property uses OnMessage event of the parent form, storing it into - fOldOnMessage field and calling in chain. So, assign cancel button - after setting OnMessage event for the form. } - function AllBtnReturnClick: PControl; - {* Call this method for a form or control to provide clicking - a focused button when ENTER pressed. By default, a button can be clicked - only by SPACE key from the keyboard, or by mouse. } - property IgnoreDefault: Boolean - read {$IFDEF USE_FLAGS} GetIgnoreDefault {$ELSE} fIgnoreDefault {$ENDIF} - write {$IFDEF USE_FLAGS} SetIgnoreDefault {$ELSE} fIgnoreDefault {$ENDIF}; - {* Change this property to TRUE to ignore default button reaction on - press ENTER key when a focus is grabbed of the control. Default - value is different for different controls. By default, DefaultBtn - ignored in memo, richedit (even if read-only). } - - {$ENDIF GDI} - property Color: TColor read fColor write SetCtlColor; - {* Property Color is one of the most common for all visual - elements (like form, control etc.) Please note, that standard GUI button - can not change its color and the most characteristics of the Font. Also, - standard button can not become Transparent. Use bitbtn for such purposes. - Also, changing Color property for some kinds of control has no effect (rich edit, - list view, tree view, etc.). To solve this, use native (for such controls) - color property, or call Perform method with appropriate message to set the - background color. } - property Font: PGraphicTool read GetFont; - {* If the Font property is not accessed, correspondent TGraphicTool object - is not created and its methods are not included into executable. Leaving - properties Font and Brush untouched can economy executable size a lot. } - {$IFDEF GDI} - property Brush: PGraphicTool read GetBrush; - {* If not accessed, correspondent TGraphicTool object is not created - and its methods are not referenced. See also note on Font property. } - - property Ctl3D: Boolean read Get_Ctl3D write SetCtl3D; - {* Inheritable from parent controls to child ones. } - - procedure Show; - {* |<#appbutton> - |<#form> - Makes control visible and activates it. } - function ShowModal: Integer; - {* |<#form> - Can be used only with a forms to show it modal. See also global function - ShowMsgModal. - |
- To use a form as a modal, it is possible to make it either auto-created - or dynamically created. For a first case, You (may be prefer to hide a - form after showing it as a modal: - ! - ! procedure TForm1.Button1Click( Sender: PObj ); - ! begin - ! Form2.Form.ShowModal; - ! Form2.Form.Hide; - ! end; - ! - Another way is to create modal form just before showing it (this economies - system resources): - ! - ! procedure TForm1.Button1Click( Sender: PObj ); - ! begin - ! NewForm2( Form2, Applet ); - ! Form2.Form.ShowModal; - ! Form2.Form.Free; // Never call Form2.Free or Form2.Form.Close - ! end; // but always Form2.Form.Free; (!) - ! - In samples above, You certainly can place any wished code before and after - calling ShowModal method. - |
- Do not forget that if You have more than a single form in your project, - separate Applet object should be used. - |
- See also ShowModalEx. - } - function ShowModalParented( const AParent: PControl ): Integer; - {* by Alexander Pravdin. The same as ShowModal, but with a certain - form as a parent. } - function ShowModalEx: Integer; - {* The same as ShowModal, but all the windows of current thread are - disabled while showing form modal. This is useful if KOL form from - a DLL is used modally in non-KOL application. } - property ModalResult: Integer read DF.fModalResult - write {$IFDEF USE_SETMODALRESULT} SetModalResult {$ELSE} DF.fModalResult {$ENDIF}; - {* |<#form> - Modal result. Set it to value<>0 to stop modal dialog. By agreement, - value 1 corresponds 'OK', 2 - 'Cancel'. But it is totally by decision - of yours how to interpret this value. } - property Modal: Boolean read GetModal; - {* |<#form> - TRUE, if the form is shown modal. } - property ModalForm: PControl read DF.fModalForm write DF.fModalForm; - {* |<#form> - |<#appbutton> - Form currently shown modal from this form or from Applet. } - - procedure Hide; - {* |<#appbutton> - |<#form> - Makes control hidden. } - property OnShow: TOnEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnShow {$ELSE} EV.FOnShow {$ENDIF} - write SetOnShow; - {* Is called when a control or form is to be shown. This event is not fired - for a form, if its WindowState initially is set to wsMaximized or - wsMinimized. This behaviour is by design (the window does not receive - WM_SHOW message in such case). } - property OnHide: TOnEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnHide {$ELSE} EV.FOnHide {$ENDIF} - write SetOnHide; - {* Is called when a control or form becomes hidden. } - property WindowState: TWindowState read GetWindowState write SetWindowState; - {* |<#form> - Window state. } - - {$ENDIF GDI} - property Canvas: PCanvas read GetCanvas; - {* |<#paintbox> - Placeholder for Canvas: PCanvas. But in KOL, it is possible to - create applets without canvases at all. To do so, avoid using - Canvas and use DC directly (which is passed in OnPaint event). } - {$IFDEF GDI} - function CallDefWndProc( var Msg: TMsg ): Integer; - {* Function to be called in WndProc method to redirect message handling - to default window procedure. } - function DoSetFocus: Boolean; - {* Sets focus for Enabled window. Returns True, if success. } - - procedure MinimizeNormalAnimated; - {* |<#form> - Apply this method to a main form (not to another form or Applet, - even when separate Applet control is not used and main form matches it!). - This provides normal animated visual minimization for the application. - It therefore has no effect, if animation during minimize/resore is - turned off by user. - |
- Applying this method also provides for the main form (only for it) - correct restoring the form maximized if it was maximized while - minimizing the application. See also RestoreNormalMaximized method. } - procedure RestoreNormalMaximized; - {* |<#form> - Apply to any form for which it is important to restore it maximized - when the application was minimizing while such form was maximized. - If the method MinimizeNormalAnimated was called for the main form, - then the correct behaviour is already provided for the main form, so - in such case it is no more necessary to call also this method, but - calling it therefore is not an error. } - - property OnMessage: TOnMessage - read {$IFDEF EVENTS_DYNAMIC} Get_OnMessage {$ELSE} EV.fOnMessage {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnMessage {$ELSE} EV.fOnMessage {$ENDIF}; - {* |<#appbutton> - |<#form> - Is called for every message processed by TControl object. And for - Applet window, this event is called also for all messages, handled by - all its child windows (forms). } - - {$ENDIF GDI} - function IsMainWindow: Boolean; - {* |<#appbutton> - |<#form> - Returns True, if a window is the main in application (created first - after the Applet, or matches the Applet). } - property IsApplet: Boolean read {$IFDEF USE_FLAGS} GetIsApplet {$ELSE} FIsApplet {$ENDIF}; - {* Returns true, if the control is created using NewApplet (or CreateApplet). - } - property IsForm: Boolean read {$IFDEF USE_FLAGS} GetIsForm {$ELSE} fIsForm {$ENDIF}; - {* Returns True, if the object is form window. } - property IsMDIChild: Boolean read {$IFDEF USE_FLAGS} GetIsMDIChild {$ELSE} fIsMDIChild {$ENDIF}; - {* Returns TRUE, if the object is MDI child form. In such case, IsForm also - returns TRUE. } - property IsControl: Boolean read {$IFDEF USE_FLAGS} GetIsControl {$ELSE} fIsControl {$ENDIF}; - {* Returns True, is the control is control (not form or applet). } - property IsButton: Boolean read {$IFDEF USE_FLAGS} GetIsButton {$ELSE} fIsButton {$ENDIF}; - {* Returns True, if the control is button-like or containing buttons (button, - bitbtn, checkbox, radiobox, toolbar). } - - {$IFDEF GDI} - function ProcessMessage: Boolean; - {* |<#appbutton> - Processes one message. See also ProcessMessages. } - - procedure ProcessMessages; - {* |<#appbutton> - Processes pending messages during long cycle of calculation, - allowing to window to be repainted if needed and to respond to other - messages. But if there are no such messages, your application can be - stopped until such one appear in messages queue. To prevent such - situation, use method ProcessPendingMessages instead. } - - procedure ProcessMessagesEx; - {* Version of ProcessMessages, which works always correctly, even if - the application is minimized or background. } - - procedure ProcessPendingMessages; - {* |<#appbutton> - Similar to ProcessMessages, but without waiting of - message in messages queue. I.e., if there are no pending - messages, this method immediately returns control to your - code. This method is better to call during long cycle of - calculation (then ProcessMessages). } - procedure ProcessPaintMessages; - {* } - function WndProc( var Msg: TMsg ): Integer; virtual; //{$IFNDEF DEBUG_MCK} virtual; {$ENDIF} - {* Responds to all Windows messages, posted (sended) to the - window, before all other proceeding. You can override it in - derived controls, but in KOL there are several other ways - to control message flow of existing controls without deriving - another costom controls for only such purposes. See OnMessage, - AttachProc. } - property HasBorder: Boolean read GetHasBorder write SetHasBorder; - {* |<#form> - Obvious. Form-aware. } - - property HasCaption: Boolean read GetHasCaption write SetHasCaption; - {* |<#form> - Obvious. Form-aware. } - property CanResize: Boolean read GetCanResize write SetCanResize; - {* |<#form> - Obvious. Form-aware. } - property StayOnTop: Boolean read GetStayOnTop write SetStayOnTop; - {* |<#form> - Obvious. Form-aware, but can be applied to controls. } - property Border: ShortInt read fMargin write fMargin; - {* |<#form> - Distance between edges and child controls and between child - controls by default (if methods PlaceRight, PlaceDown, PlaceUnder, - ResizeParent, ResizeParentRight, ResizeParentBottom are called). - |
- Originally was named Margin, now I recommend to use the name 'Border' to - avoid confusion with MarginTop, MarginBottom, MarginLeft and - MarginRight properties. - |
- Initial value is always 2. Border property is used in realigning - child controls (when its Align property is not caNone), and value - of this property determines size of borders between edges of children - and its parent and between aligned controls too. - |
- See also properties MarginLeft, MarginRight, MarginTop, MarginBottom. } - function SetBorder( Value: Integer ): PControl; - {* Assigns new Border value, and returns @ Self. } - - property Margin: ShortInt read fMargin write fMargin; - {* |<#form> - Old name for property Border. } - - property MarginTop: ShortInt index 1 - {$IFDEF F_P} read GetClientMargin - {$ELSE DELPHI} read fClientTop - {$ENDIF F_P/DELPHI} write SetClientMargin; - {* Additional distance between true window client top and logical top of - client rectangle. This value is added to Top of rectangle, returning - by property ClientRect. Together with other margins and property Border, - this property allows to change view of form for case, that Align property - is used to align controls on parent (it is possible to provide some - distance from child controls to its parent, and between child controls. - |
- Originally this property was introduced to compensate incorrect - ClientRect property, calculated for some types of controls. - |
- See also properties Border, MarginBottom, MarginLeft, MarginRight. } - property MarginBottom: ShortInt index 2 - {$IFDEF F_P} read GetClientMargin - {$ELSE DELPHI} read fClientBottom - {$ENDIF F_P/DELPHI} write SetClientMargin; - {* The same as MarginTop, but a distance between true window Bottom of - client rectangle and logical bottom one. Take in attention, that this value - should be POSITIVE to make logical bottom edge located above true edge. - |
- See also properties Border, MarginTop, MarginLeft, MarginRight. } - property MarginLeft: ShortInt index 3 - {$IFDEF F_P} read GetClientMargin - {$ELSE DELPHI} read fClientLeft - {$ENDIF F_P/DELPHI} write SetClientMargin; - {* The same as MarginTop, but a distance between true window Left of - client rectangle and logical left edge. - |
- See also properties Border, MarginTop, MarginRight, MarginBottom. } - property MarginRight: ShortInt index 4 - {$IFDEF F_P} read GetClientMargin - {$ELSE DELPHI} read fClientRight - {$ENDIF F_P/DELPHI} write SetClientMargin; - {* The same as MarginLeft, but a distance between true window Right of - client rectangle and logical bottom one. Take in attention, that this value - should be POSITIVE to make logical right edge located left of true edge. - |
- See also properties Border, MarginTop, MarginLeft, MarginBottom. } - - property Tabstop: Boolean - {$IFDEF USE_FLAGS} - read GetTabStop write SetTabStop - {$ELSE} - read fTabstop write fTabstop - {$ENDIF} - ; - {* True, if control can be focused using tabulating between controls. - Set it to False to make control unavailable for keyboard, but only - for mouse. } - - property TabOrder: SmallInt read fTabOrder write SetTabOrder; - {* Order of tabulating of controls. Initially, TabOrder is equal to - creation order of controls. If TabOrder changed, TabOrder of - all controls with not less value of one is shifted up. To place - control before another, assign TabOrder of one to another. - For example: - ! Button1.TabOrder := EditBox1.TabOrder; - In code above, Button1 is placed just before EditBox1 in tabulating - order (value of TabOrder of EditBox1 is incremented, as well as - for all follow controls). } - - property Focused: Boolean read GetFocused write SetFocused; - {* True, if the control is current on form (but check also, what form - itself is focused). For form it is True, if the form is active (i.e. - it is foreground and capture keyboard). Set this value to True to make - control current and focused (if applicable). } - - function BringToFront: PControl; - {* Changes z-order of the control, bringing it to the topmost level. } - function SendToBack: PControl; - {* Changes z-order of the control, sending it to the back of siblings. } - {$ENDIF GDI} - property TextAlign: TTextAlign read GetTextAlign write SetTextAlign; - {* |<#label> - |<#panel> - |<#button> - |<#bitbtn> - |<#edit> - |<#memo> - Text horizontal alignment. Applicable to labels, buttons, - multi-line edit boxes, panels. } - property VerticalAlign: TVerticalAlign read GetVerticalAlign write SetVerticalAlign; - {* |<#button> - |<#label> - |<#panel> - Text vertical alignment. Applicable to buttons, labels and panels. } - {$IFDEF GDI} - property WordWrap: Boolean - {$IFDEF USE_FLAGS} - read GetWordWrap write SetWordWrap - {$ELSE} - read fWordWrap write fWordWrap - {$ENDIF USE_FLAGS}; - {* TRUE, if this is a label, created using NewWordWrapLabel. } - property ShadowDeep: Integer read DF.FShadowDeep write SetShadowDeep; - {* |<#3dlabel> - Deep of a shadow (for label effect only, created calling NewLabelEffect). } - - property CannotDoubleBuf: Boolean - {$IFDEF USE_FLAGS} - read GetCannotDoubleBuf write SetCannotDoubleBuf - {$ELSE} - read fCannotDoubleBuf write fCannotDoubleBuf - {$ENDIF}; - {* } - property DoubleBuffered: Boolean - read {$IFDEF USE_FLAGS} GetDoubleBuffered - {$ELSE} fDoubleBuffered {$ENDIF} - write SetDoubleBuffered; - {* Set it to true for some controls, which are flickering in repainting - (like label effect). Slow, and requires additional code. This property - is inherited by all child controls. - |
    - Note: RichEdit control can not become DoubleBuffered. } - function DblBufTopParent: PControl; - {* Returns the topmost DoubleBuffered Parent control. } - property Transparent: Boolean - read {$IFDEF USE_FLAGS} GetTransparent {$ELSE} fTransparent {$ENDIF} - write SetTransparent; - {* Set it to true to get special effects. Transparency also uses - DoubleBuffered and inherited by child controls. - |
    - Please note, that some controls can not be shown properly, when - Transparent is set to True for it. If You want to make edit control - transparent (e.g., over gradient filled panel), handle its OnChanged - property and call there Invalidate to provide repainting of edit - control content. Note also, that for RichEdit control property - Transparent has no effect (as well as DoubleBuffered). But special - property RE_Transparent is designed especially for RichEdit control - (it works fine, but with great number of flicks while resizing - of a control). Another note is about Edit control. To allow editing - of transparent edit box, it is necessary to invalidate it for - every pressed character. Or, use Ed_Transparent property instead. } - property Ed_Transparent: Boolean - read {$IFDEF USE_FLAGS} GetTransparent {$ELSE} fTransparent {$ENDIF} - write EdSetTransparent; - {* |<#edit> - |<#memo> - Use this property for editbox to make it really Transparent. Remember, - that though Transparent property is inherited by child controls from - its parent, this is not so for Ed_Transparent. So, it is necessary to - set Ed_Transparent to True for every edit control explicitly. } - property AlphaBlend: Byte read fAlphaBlend write SetAlphaBlend; - {* |<#form> - If assigned to 0..254, makes window (form or control) semi-transparent - (Win2K only). - |
- Depending on value assigned, it is possible to adjust transparency - level ( 0 - totally transparent, 255 - totally opaque). - |
Note: from XP, any control can be alpha blended! } - function MouseTransparent: PControl; - {* Call this method to set up mouse transparent control (which always - returns HTTRANSPARENT in responce to WM_NCHITTEST). This function - returns a pointer to a control itself. } - - property LookTabKeys: TTabKeys read fLookTabKeys write fLookTabKeys; - {* Set of keys which can be used as tabulation keys in a control. } - procedure GotoControl( Key: DWORD ); - {* |<#form> - Emulates tabulation key press w/o sending message to current control. - Can be applied to a form or to any its control. If VK_TAB is used, - state of shift kay is checked in: if it is pressed, tabulate is in - backward direction. } - property SubClassName: KOLString read get_ClassName write set_ClassName; - {* Name of window class - unique for every window class - in every run session of a program. } - - public - procedure SetOnClose( const AOnClose: TOnEventAccept ); - procedure SetFormOnClick( const AOnClick: TOnEvent ); - public - property OnClose: TOnEventAccept - read {$IFDEF EVENTS_DYNAMIC} Get_OnClose {$ELSE} EV.fOnClose {$ENDIF} - write SetOnClose; - {* |<#form> - |<#applet> - Called before closing the window. It is possible to set Accept - parameter to False to prevent closing the window. This event events - is not called when windows session is finishing (to handle this - event, handle WM_QUERYENDSESSION message, or assign OnQueryEndSession - event to another or the same event handler). } - - property OnQueryEndSession: TOnEventAccept - read {$IFDEF EVENTS_DYNAMIC} Get_OnQueryEndSession {$ELSE} EV.fOnQueryEndSession {$ENDIF} - write SetOnQueryEndSession; - {* |<#form> - |<#applet> - Called when WM_QUERYENDSESSION message come in. It is possible to set Accept - parameter to False to prevent closing the window (in such case session ending - is halted). It is possible to check CloseQueryReason property to find out, - why event occur. - |
- To provide normal application close while handling OnQueryEndSession, - call in your code PostQuitMessage( 0 ) or call method Close for the main form, - this is enough to provide all OnClose and OnDestroy handlers to be called. } - property CloseQueryReason: TCloseQueryReason read DF.fCloseQueryReason; - {* Reason why OnClose or OnQueryEndSession called. } - property OnMinimize: TOnEvent index 0 read - {$IFDEF F_P} GetOnMinMaxRestore {$ELSE DELPHI} - {$IFDEF EVENTS_DYNAMIC} GetOnMinMaxRestore - {$ELSE} EV.fOnMinimize {$ENDIF} - {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore; - {* |<#form> - Called when window is minimized. } - property OnMaximize: TOnEvent index 8 read - {$IFDEF F_P} GetOnMinMaxRestore {$ELSE DELPHI} - {$IFDEF EVENTS_DYNAMIC} GetOnMinMaxRestore - {$ELSE} EV.fOnMaximize {$ENDIF} - {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore; - {* |<#form> - Called when window is maximized. } - property OnRestore: TOnEvent index 16 read - {$IFDEF F_P} GetOnMinMaxRestore {$ELSE DELPHI} - {$IFDEF EVENTS_DYNAMIC} GetOnMinMaxRestore - {$ELSE} EV.fOnMaximize {$ENDIF} - {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore; - {* |<#form> - Called when window is restored from minimized or maximized state. } - - property UpdateRgn: HRgn read fUpdRgn; - {* A handle of update region. Valid only in OnPaint method. You - can use it to improve painting (for speed), if necessary. When - UpdateRgn is obtained in response to WM_PAINT message, value - of the property EraseBackground is used to pass it to the API - function GetUpdateRgn. If UpdateRgn = 0, this means that entire - window should be repainted. Otherwise, You (e.g.) can check - if the rectangle is in clipping region using API function - RectInRegion. } - - property EraseBackground: Boolean - read {$IFDEF USE_FLAGS} GetEraseBackground {$ELSE} fEraseUpdRgn {$ENDIF} - write {$IFDEF USE_FLAGS} SetEraseBackground {$ELSE} fEraseUpdRgn {$ENDIF}; - {* This value is used to pass it to the API function GetUpdateRgn, - when UpadateRgn property is obtained first in responce to WM_PAINT - message. If EraseBackground is set to True, system is responsible - for erasing background of update region before painting. If not - (default), the entire region invalidated should be painted by your - event handler. } - {$ENDIF GDI} - property OnPaint: TOnPaint - read {$IFDEF EVENTS_DYNAMIC} Get_OnPaint {$ELSE} EV.fOnPaint {$ENDIF} - write SetOnPaint; - {* Event to set to override standard control painting. Can be applied - to any control (though originally was designed only for paintbox - control). When an event handler is called, it is possible to use - UpdateRgn to examine what parts of window require painting to - improve performance of the painting operation. } - {$IFDEF GDI} - property OnPrePaint: TOnPaint - read {$IFDEF EVENTS_DYNAMIC} Get_OnPrePaint {$ELSE} EV.fOnPrePaint {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnPrePaint {$ELSE} EV.fOnPrePaint {$ENDIF}; - {* Only for graphic controls. If you assign it, call Invalidate also. } - property OnPostPaint: TOnPaint - read {$IFDEF EVENTS_DYNAMIC} Get_OnPostPaint {$ELSE} EV.fOnPostPaint {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnPostPaint {$ELSE} EV.fOnPostPaint {$ENDIF}; - {* Only for graphic controls. If you assign it, call Invalidate also. } - - property OnEraseBkgnd: TOnPaint - read {$IFDEF EVENTS_DYNAMIC} Get_OnEraseBkgnd {$ELSE} EV.fOnEraseBkgnd {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnEraseBkgnd {$ELSE} SetOnEraseBkgnd {$ENDIF}; - {* This event allows to override erasing window background in response - to WM_ERASEBKGND message. This allows to add some decorations to - standard controls without overriding its painting in total. - Note: When erase background, remember, that property ClientRect can - return not true client rectangle of the window - use GetClientRect - API function instead. For example: - ! - !var BkBmp: HBitmap; - ! - !procedure TForm1.KOLForm1FormCreate(Sender: PObj); - !begin - ! Toolbar1.OnEraseBkgnd := DecorateToolbar; - ! BkBmp := LoadBitmap( hInstance, 'BK1' ); - !end; - ! - !procedure TForm1.DecorateToolbar(Sender: PControl; DC: HDC); - !var CR: TRect; - !begin - ! GetClientRect( Sender.Handle, CR ); - ! Sender.Canvas.Brush.BrushBitmap := BkBmp; - ! Sender.Canvas.FillRect( CR ); - !end; - ! - } - - {$ENDIF GDI} - property OnClick: TOnEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnClick {$ELSE} EV.fOnClick {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} SetOnClick {$ELSE} - {$IFDEF GDI} EV.fOnClick - {$ELSE _X_} SetOnClick {$ENDIF _X_}{$ENDIF}; - {* |<#button> - |<#checkbox> - |<#radiobox> - |<#toolbar> - Called on click at control. For buttons, checkboxes and radioboxes - is called regadless if control clicked by mouse or keyboard. For toolbar, - the same event is used for all toolbar buttons and toolbar itself. - To determine which toolbar button is clicked, check CurIndex property. - And note, that all the buttons including separator buttons are enumerated - starting from 0. Though images are stored (and prepared) only for - non-separator buttons. And to determine, if toolbar button was clicked - with right mouse button, check RightClick property. - |
- This event does not work on a Form, still it is fired in responce to - WM_COMMAND window message mainly rather direct to mouse down. But, if - you want to have OnClick event to be fired on a Form, use (following) - property OnFormClick to assign it. } - {$IFDEF GDI} - property OnFormClick: TOnEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnClick {$ELSE} EV.fOnClick {$ENDIF} - write SetFormOnClick; - {* |<#form> - Assign you OnClick event handler using this property, if you want it to - be fired in result of mouse click on a form surface. Use to assign the - event only for forms (to avoid doublicated firing the handler). - |
- Note: for a form, in case of WM_xDOUBLECLK event, this event is fired - for both clicks. So if you install both OnFormClick and OnMouseDblClk, - handlers will be called in the following sequence for each double click: - OnFormClick; OnMouseDblClk; OnFormClick. } - property RightClick: Boolean read {$IFDEF USE_FLAGS} Get_RightClick {$ELSE} fRightClick {$ENDIF}; - {* |<#toolbar> - |<#listview> - Use this property to determine which mouse button was clicked - (applicable to toolbar in the OnClick event handler). } - property OnEnter: TOnEvent index idx_fOnEnter - read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnEnter {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnEnter {$ENDIF}; - {* Called when control receives focus. } - property OnLeave: TOnEvent index idx_fOnLeave - read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnLeave {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnLeave{$ENDIF}; - {* Called when control looses focus. } - property OnChange: TOnEvent index idx_fOnChangeCtl - read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnChangeCtl {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnChangeCtl {$ENDIF}; - {* |<#edit> - |<#memo> - |<#listbox> - |<#combo> - |<#tabcontrol> - Called when edit control is changed, or selection in listbox or - current index in combobox is changed (but if OnSelChanged assigned, - the last is called for change selection). To respond to check/uncheck - checkbox or radiobox events, use OnClick instead. } - property OnSelChange: TOnEvent index idx_fOnSelChange - read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnSelChange {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnSelChange{$ENDIF}; - {* |<#richedit> - |<#listbox> - |<#combo> - |<#treeview> - Called for rich edit control, listbox, combobox or treeview when current selection - (range, or current item) is changed. If not assigned, but OnChange is - assigned, OnChange is called instead. } - property OnResize: TOnEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnResize {$ELSE} EV.FOnResize {$ENDIF} - write SetOnResize; - {* Called whenever control receives message WM_SIZE (thus is, if - control is resized. } - property OnMove: TOnEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnMove {$ELSE} EV.FOnMove {$ENDIF} - write SetOnMove; - {* Called whenever control receives message WM_MOVE (i.e. when control is - moved over its parent). } - property OnMoving: TOnEventMoving - read {$IFDEF EVENTS_DYNAMIC} Get_OnMoving {$ELSE} EV.FOnMoving {$ENDIF} - write SetOnMoving; - {* Called whenever control receives message WM_MOVE (i.e. when control is - moved over its parent). } - - property MinSizePrev: Integer read DF.fSplitMinSize1 write DF.fSplitMinSize1; - {* |<#splitter> - Minimal allowed (while dragging splitter) size of previous control - for splitter (see NewSplitter). } - property SplitMinSize1: Integer read DF.fSplitMinSize1 write DF.fSplitMinSize1; - {* The same as MinSizePrev } - property MinSizeNext: Integer read DF.fSplitMinSize2 write DF.fSplitMinSize2; - {* |<#splitter> - Minimal allowed (while dragging splitter) size of the rest of parent - of splitter or of SecondControl (see NewSplitter). } - property SplitMinSize2: Integer read DF.fSplitMinSize2 write DF.fSplitMinSize2; - {* The same as MinSizeNext. } - property SecondControl: PControl read DF.fSecondControl write DF.fSecondControl; - {* |<#splitter> - Second control to check (while dragging splitter) if its size not less - than SplitMinSize2 (see NewSplitter). By default, second control is - not necessary, and needed only in rare case when SecondControl can not - be determined automatically to restrict splitter right (bottom) position. } - property OnSplit: TOnSplit - read {$IFDEF EVENTS_DYNAMIC} Get_OnSplit {$ELSE} EV.fOnSplit {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnSplit {$ELSE} EV.fOnSplit{$ENDIF}; - {* |<#splitter> - Called when splitter control is dragging - to allow for - your event handler to decide if to accept new size of - left (top) control, and new size of the rest area of parent. } - property Dragging: Boolean read {$IFDEF USE_FLAGS} Get_Dragging {$ELSE} FDragging{$ENDIF}; - {* |<#splitter> - True, if splitter control is dragging now by user with left - mouse button. Also, this property can be used to detect if the control - is dragging with mouse (after calling DragStartEx method). } - procedure DragStart; - {* Call this method for a form or control to drag it with left mouse button, - when mouse left button is already down. Dragging is stopped when left mouse - button is released. See also DragStartEx, DragStopEx. } - procedure DragStartEx; - {* Call this method to start dragging the form by mouse. To stop - dragging, call DragStopEx method. (Tip: to detect mouse up event, - use OnMouseUp event of the dragging control). This method can be used - to move any control with the mouse, not only entire form. State of - mouse button is not significant. Determine dragging state of the control - checking its Dragging property. } - procedure DragStopEx; - {* Call this method to stop dragging the form (started by DragStopEx). } - procedure DragItem( OnDrag: TOnDrag ); - {* Starts dragging something with mouse. During the process, - callback function OnDrag is called, which allows to control - drop target, change cursor shape, etc. } - - property OnKeyDown: TOnKey - read {$IFDEF EVENTS_DYNAMIC} Get_OnKeyDown {$ELSE} EV.fOnKeyDown {$ENDIF} - write SetOnKeyDown; - {* Obvious. } - property OnKeyUp: TOnKey - read {$IFDEF EVENTS_DYNAMIC} Get_OnKeyUp {$ELSE} EV.fOnKeyUp {$ENDIF} - write SetOnKeyUp; - {* Obvious. } - property OnChar: TOnChar - read {$IFDEF EVENTS_DYNAMIC} Get_OnChar {$ELSE} EV.fOnChar {$ENDIF} - write SetOnChar; - {* Deprecated event, use OnKeyChar. } - property OnKeyChar: TOnChar - read {$IFDEF EVENTS_DYNAMIC} Get_OnChar {$ELSE} EV.fOnChar {$ENDIF} - write SetOnChar; - {* Obviuos. } - {$IFDEF SUPPORT_ONDEADCHAR} - property OnKeyDeadChar: TOnChar - read {$IFDEF EVENTS_DYNAMIC} Get_OnDeadChar {$ELSE} EV.fOnDeadChar {$ENDIF} - write SetOnDeadChar; - {* Obviuos. } - {$ENDIF SUPPORT_ONDEADCHAR} - - {$ENDIF GDI} - property OnMouseUp: TOnMouse index idx_fOnMouseUp - read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseUp {$ENDIF} - write SetOnMouseEvent; - {* Obvious. } - property OnMouseDown: TOnMouse index idx_fOnMouseDown - read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseDown {$ENDIF} - write SetOnMouseEvent; - {* Obvious. } - property OnMouseMove: TOnMouse index idx_fOnMouseMove - read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseMove {$ENDIF} - write SetOnMouseEvent; - {* Obvious. } - property OnMouseDblClk: TOnMouse index idx_fOnMouseDblClk - read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseDblClk {$ENDIF} - write SetOnMouseEvent; - {* Obvious. } - property ThreeButtonPress: Boolean - read {$IFDEF USE_FLAGS} Get3ButtonPress {$ELSE} f3ButtonPress {$ENDIF}; - {* GDK (*nix) only. TRUE, if 3 button press detected. Check this flag in - OnMouseDblClk event handler. If 3rd button click is done for a short - period of time after the double click, the control receives OnMouseDblClk - the second time and this flag is set. (Applicable to the GDK and other - Linux systems). } - property OnMouseWheel: TOnMouse index idx_fOnMouseWheel - read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseWheel {$ENDIF} - write SetOnMouseEvent; - {* Mouse wheel (up or down) event. In Windows, only focused controls and - controls having scrollbars (or a scrollbar iteself) receive such - message. To get direction and amount of wheel, use typecast: - SmallInt( HiWord( Mouse.Shift ) ). Value 120 corresponds to one wheel - step (-120 - for step back). } - {$IFDEF GDI} - - property OnMouseEnter: TOnEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEnter {$ELSE} EV.fOnMouseEnter {$ENDIF} - write SetOnMouseEnter; - {* Is called when mouse is entered into control. See also OnMouseLeave. } - property OnMouseLeave: TOnEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseLeave {$ELSE} EV.fOnMouseLeave {$ENDIF} - write SetOnMouseLeave; - {* Is called when mouse is leaved control. If this event is assigned, - then mouse is captured on mouse enter event to handle all other - mouse events until mouse cursor leaves the control. } - property OnTestMouseOver: TOnTestMouseOver - read {$IFDEF EVENTS_DYNAMIC} Get_OnTestMouseOver {$ELSE} EV.fOnTestMouseOver {$ENDIF} - write SetOnTestMouseOver; - {* |<#bitbtn> - Special event, which allows to extend OnMouseEnter / OnMouseLeave - (and also Flat property for BitBtn control). If a handler is assigned - to this event, actual testing whether mouse is in control or not, - is occuring in the handler. So, it is possible to simulate more - careful hot tracking for controls with non-rectangular shape (such - as glyphed BitBtn control). } - - property MouseInControl: Boolean - read {$IFDEF USE_FLAGS} GetMouseInCtl {$ELSE} fMouseInControl {$ENDIF}; - {* |<#bitbtn> - This property can return True only if OnMouseEnter / OnMouseLeave - event handlers are set for a control (or, for BitBtn, property Flat - is set to True. Otherwise, False is returned always. } - - property Flat: Boolean read {$IFDEF USE_FLAGS} GetFlat {$ELSE} fFlat {$ENDIF} - write SetFlat; - {* |<#bitbtn> - Set it to True for BitBtn, to provide either flat border for a button - or availability of "highlighting" (correspondent to glyph index 4). - |
- Note: this can work incorrectly a bit under win95 without comctl32.dll - updated. Therefore, application will launch. To enforce correct working - even under Win95, use your own timer, which event handler checks for - mouse over bitbtn control, e.g.: - ! procedure TForm1.Timer1Timer(Sender: PObj); - ! var P: TPoint; - ! begin - ! if not BitBtn1.MouseInControl then Exit; - ! GetCursorPos( P ); - ! P := BitBtn1.Screen2Client( P ); - ! if not PtInRect( BitBtn1.ClientRect, P ) then - ! begin - ! BitBtn1.Flat := FALSE; - ! BitBtn1.Flat := TRUE; - ! end; - ! end; - } - property RepeatInterval: Integer read DF.fRepeatInterval write DF.fRepeatInterval; - {* |<#bitbtn> - If this property is set to non-zero, it is interpreted (for BitBtn - only) as an interval in milliseconds between repeat button down events, - which are generated after first mouse or button click and until - button is released. Though, if the button is pressed with keyboard (with - space key), RepeatInterval value is ignored and frequency of repeatitive - clicking is determined by user keyboard settings only. } - function LikeSpeedButton: PControl; - {* |<#button> - |<#bitbtn> - Transparent method (returns control itself). Makes button not focusable. } - - function Add( const S: KOLString ): Integer; - {* |<#listbox> - |<#combo> - Only for listbox and combobox. } - - function Insert( Idx: Integer; const S: KOLString ): Integer; - {* |<#listbox> - |<#combo> - Only for listbox and combobox. } - procedure Delete( Idx: Integer ); - {* |<#listbox> - |<#combo> - |<#listview> - |<#treeview> - Only listed controls. } - procedure Clear; - {* Clears object content. Has different sense for different controls. - E.g., for label, editbox, button and other simple controls it - assigns empty string to Caption property. For listbox, combobox, - listview it deletes all items. For toolbar, it deletes all buttons. - Et so on. } - - property Progress: Integer index ((PBM_SETPOS or $8000) shl 16) or PBM_GETPOS - read GetIntVal write SetIntVal; - {* |<#progressbar> - Only for ProgressBar. } - property MaxProgress: Integer index ((PBM_SETRANGE32 or $8000) shl 16) or PBM_GETRANGE - read GetIntVal write SetMaxProgress; - {* |<#progressbar> - Only for ProgressBar. 100 is the default value. } - property ProgressColor: TColor read fTextColor write SetProgressColor; - {* |<#progressbar> - Only for ProgressBar. } - property ProgressBkColor: TColor read fColor write SetCtlColor; //SetProgressBkColor; - {* |<#progressbar> - Obsolete. Now the same as Color. } - - property StatusText[ Idx: Integer ]: KOLString read GetStatusText write SetStatusText; - {* |<#form> - Only for forms to set/retrieve status text to/from given status panel. - Panels are enumerated from 0 to 254, 255 is to indicate simple - status bar. Size grip in right bottom corner of status window is - displayed only if form still CanResize. - |
- When a status text is set first time, status bar window is created - (always aligned to bottom), and form is resizing to preset client height. - While status bar is showing, client height value is returned without - height of status bar. To remove status bar, call RemoveStatus method for - a form. - |
- By default, text is left-aligned within the specified part of a status - window. You can embed tab characters (#9) in the text to center or - right-align it. Text to the right of a single tab character is centered, - and text to the right of a second tab character is right-aligned. - |
- If You use separate status bar onto several panels, these automatically - align its widths to the same value (width divided to number of panels). - To adjust status panel widths for every panel, use property StatusPanelRightX. - } - property SimpleStatusText: KOLString index 255 read GetStatusText write SetStatusText; - {* |<#form> - Only for forms to set/retrive status text to/from simple status bar. - Size grip in right bottom corner of status window is displayed only - if form CanResize. - |
- When status text set first time, (simple) status bar window is created - (always aligned to bottom), and form is resizing to preset client height. - While status bar is showing, client height value is returned without - height of status bar. To remove status bar, call RemoveStatus method for - a form. - |
- By default, text is left-aligned within the specified part of a status - window. You can embed tab characters (#9) in the text to center or - right-align it. Text to the right of a single tab character is centered, - and text to the right of a second tab character is right-aligned. - } - property StatusCtl: PControl read fStatusCtl; - {* Pointer to Status bar control. To "create" child controls on - the status bar, first create it as a child of form, for instance, and - then change its property Parent, e.g.: - ! var Progress1: PControl; - ! ... - ! Progress1 := NewProgressBar( Form1 ); - ! Progress1.Parent := Form1.StatusCtl; - (If you use MCK, code should be another a bit, and in this case it is - possible to create and adjust the control at design-time, and at run-time - change its parent control. E.g. (Progress1 is created at run-time here too): - ! Progress1 := NewProgressBar( Form ); - ! Progress1.Parent := Form.StatusCtl; - ). - Do not forget to provide StatusCtl to be existing first (e.g. assign - one-space string to SimpleStatusText property of the form, for MCK do - so using Object Inspector). - - Please note that not only a form can have status bar - but any other control too! - } - property SizeGrip: Boolean - read {$IFDEF USE_FLAGS} GetSizeGrip {$ELSE} fSizeGrip {$ENDIF} - write {$IFDEF USE_FLAGS} SetSizeGrip {$ELSE} fSizeGrip {$ENDIF}; - {* Size grip for status bar. Has effect only before creating window. } - - procedure RemoveStatus; - {* |<#form> - Call it to remove status bar from a form (created in result of assigning - value(s) to StatusText[], SimpleStatusText properties). When status bar is - removed, form is resized to preset client height. } - function StatusPanelCount: Integer; - {* |<#form> - Returns number of status panels defined in status bar. } - property StatusPanelRightX[ Idx: Integer ]: Integer read GetStatusPanelX write SetStatusPanelX; - {* |<#form> - Use this property to adjust status panel right edges (if the status bar is - divided onto several subpanels). If the right edge for the last panel is - set to -1 (by default) it is expanded to the right edge of a form window. - Otherwise, status bar can be shorter then form width. } - property StatusWindow: HWND read Get_StatusWnd; - {* |<#form> - Provided for case if You want to use API direct message sending to - status bar. } - - property Color1: TColor read DF.fColor1 write SetColor1; - {* |<#gradient> - Top line color for GradientPanel. } - property Color2: TColor read DF.fColor2 write SetColor2; - {* |<#gradient> - |<#3Dlabel> - Bottom line color for GradientPanel, or shadow color for LabelEffect. - (If clNone, shadow color for LabelEffect is calculated as a mix bitween - TextColor and clBlack). } - property GradientStyle: TGradientStyle read DF.fGradientStyle write SetGradientStyle; - {* |<#gradient> - Styles other then gsVertical and gsHorizontal has effect only for - gradient panel, created by NewGradientPanelEx. } - property GradientLayout: TGradientLayout read DF.fGradientLayout write SetGradientLayout; - {* |<#gradient> - Has only effect for gradient panel, created by NewGradientPanelEx. - Ignored for styles gsVertical and gsHorizontal. } - - //======== Image lists (for ListView, TreeView, ToolBar and TabControl): - property ImageListSmall: PImageList index 16 read GetImgListIdx write SetImgListIdx; - {* |<#listview> - Image list with small icons used with List View control. If not set, - last added (i.e. created with a control as an owner) image list with - small icons is used. } - property ImageListNormal: PImageList index 32 read GetImgListIdx write SetImgListIdx; - {* |<#listview> - |<#treeview> - |<#tabcontrol> - |<#bitbtn> - Image list with normal size icons used with List View control (or with - icons for BitBtn, TreeView or TabControl). If not set, - last added (i.e. created with a control as an owner) image list is used. - } - property ImageListState: PImageList index 0 read GetImgListIdx write SetImgListIdx; - {* |<#listview> - |<#treeview> - Image list used as a state images list for ListView or TreeView control. } - - //======== - function SetUnicode( Unicode: Boolean ): PControl; - {* |<#listview> - |<#treeview> - |<#tabcontrol> - Sets control as Unicode or not. The control itself is returned as for - other "transparent" functions. A conditional define UNICODE_CTRLS must - be added to a project to provide handling unicode messages. } - - //======== TabControl-specific properties and methods: - property Pages[ Idx: Integer ]: PControl read GetPages; - {* |<#tabcontrol> - Returns controls, which can be used as parent for controls, placed on - different pages of a tab control. Use it like in follows example: - | Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' ); - To find number of pages available, check out Count property of the tab - control. Pages are enumerated from 0 to Count - 1, as usual. } - property TC_Pages[ Idx: Integer ]: PControl read GetPages; - {* |<#tabcontrol> - The same as above. } - function TC_Insert( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer ): PControl; - {* |<#tabcontrol> - Inserts new tab before given, returns correspondent page control - (which can be used as a parent for controls to place on the page). } - procedure TC_Delete( Idx: Integer ); - {* |<#tabcontrol> - Removes tab from tab control, destroying all its child controls. } -{$IFNDEF OLD_ALIGN} - procedure TC_InsertControl( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer; Page: PControl); - {* |<#tabcontrol> - Inserts new tab before given, but not construt this Page - (this control must be created before inserting, and may be not a Panel). } - function TC_Remove( Idx: Integer ):PControl; - {* |<#tabcontrol> - Only removes tab from tab control, and return this Page as Result. } -{$ENDIF} - property TC_Items[ Idx: Integer ]: KOLString read TCGetItemText write TCSetItemText; - {* |<#tabcontrol> - Text, displayed on tab control tabs. } - property TC_Images[ Idx: Integer ]: Integer read TCGetItemImgIDx write TCSetItemImgIdx; - {* |<#tabcontrol> - Image index for a tab in tab control. } - property TC_ItemRect[ Idx: Integer ]: TRect read TCGetItemRect; - {* |<#tabcontrol> - Item rectangle for a tab in tab control. } - procedure TC_SetPadding( cx, cy: Integer ); - {* |<#tabcontrol> - Sets space padding around tab text in a tab of tab control. } - function TC_TabAtPos( x, y: Integer ): Integer; - {* |<#tabcontrol> - Returns index of tab, found at the given position (relative to - a client rectangle of tab control). If no tabs found at the - position, -1 is returned. } - function TC_DisplayRect: TRect; - {* |<#tabcontrol> - Returns rectangle, occupied by a page rather then tab. } - function TC_IndexOf(const S: KOLString): Integer; - {* |<#tabcontrol> - By Mr Brdo. Index of page by its Caption. } - function TC_SearchFor(const S: KOLString; StartAfter: Integer; Partial: Boolean): Integer; - {* |<#tabcontrol> - By Mr Brdo. Index of page by its Caption. } - - //======== ListView style and options: - property LVStyle: TListViewStyle read DF.fLVStyle write SetLVStyle; - {* |<#listview> - ListView style of view. Can be changed at run time. } - - property LVOptions: TListViewOptions read DF.fLVOptions write SetLVOptions; - {* |<#listview> - ListView options. Can be changed at run time. } - - property LVTextColor: TColor index LVM_GETTEXTCOLOR - {$IFDEF F_P} read LVGetColorByIdx - {$ELSE DELPHI} read fTextColor - {$ENDIF F_P/DELPHI} write LVSetColorByIdx; - {* |<#listview> - ListView text color. Use it instead of Font.Color. } - property LVTextBkColor: TColor index LVM_GETTEXTBKCOLOR - {$IFDEF F_P} read LVGetColorByIdx - {$ELSE DELPHI} read DF.fLVTextBkColor - {$ENDIF F_P/DELPHI} write LVSetColorByIdx; - {* |<#listview> - ListView background color for text. } - property LVBkColor: TColor read fColor write SetCtlColor; //LVSetBkColor; - {* |<#listview> - ListView background color. Use it instead of Color. } - - //======== List View columns handling: - property LVColCount: Integer read DF.fLVColCount; - {* |<#listview> - ListView (additional) column count. Value 0 means that there are - no columns (single item text / icon is used). If You want - to provide several columns, first call LVColAdd to "insert" column 0, - i.e. to provide header text for first column (with index 0). - If there are no column, nothing will be shown in lvsDetail / - lvsDetailNoHeader view style. } - procedure LVColAdd( const aText: KOLString; aalign: TTextAlign; aWidth: Integer ); - {* |<#listview> - Adds new column. Pass 'width' <= 0 to provide default column width. - 'text' is a column header text. } - procedure LVColInsert( ColIdx: Integer; const aText: KOLString; aAlign: TTextAlign; aWidth: Integer ); - {* |<#listview> - Inserts new column at the Idx position (1-based column index). } - procedure LVColDelete( ColIdx: Integer ); - {* |<#listview> - Deletes column from List View } - property LVColWidth[ Item: Integer ]: Integer index LVM_GETCOLUMNWIDTH - read GetItemVal write SetItemVal; - {* |<#listview> - Retrieves or changes column width. For lvsList view style, the same width - is returned for all columns (ColIdx is ignored). It is possible to use - special values to assign to a property: - |
LVSCW_AUTOSIZE - Automatically sizes the column - |
LVSCW_AUTOSIZE_USEHEADER - Automatically sizes the column to fit - the header text - |
- To set coumn width in lvsList view mode, column index must be -1 - (and Width to set must be in range 0..32767 always). } - property LVColText[ Idx: Integer ]: KOLString read GetLVColText write SetLVColText; - {* |<#listview> - Allows to get/change column header text at run time. } - property LVColAlign[ Idx: Integer ]: TTextAlign read GetLVColalign write SetLVColalign; - {* |<#listview> - Column text aligning. } - property LVColImage[ Idx: Integer ]: Integer index LVCF_IMAGE or (24 shl 16) read GetLVColEx write SetLVColEx; - {* |<#listview> - Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to - set an image for list view column itself from the ImageListSmall. - } - property LVColOrder[ Idx: Integer ]: Integer index LVCF_ORDER or (28 shl 16) read GetLVColEx write SetLVColEx; - {* |<#listview> - Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to - set visual order of the list view column from the ImageListSmall. - This value does not affect the index, by which the column is still - accessible in the column array. - } - - //======== List View items handling: - property LVCount: Integer read GetItemsCount write SetItemsCount; - {* |<#listview> - Returns item count for ListView control. It is possible to use Count - property instead when obtaining of item count is needed only. But this this - property allows also to set actual count of list view items when a list - view is virtual. } - - property LVCurItem: Integer read GetLVCurItem write SetLVCurItem; - {* |<#listview> - Returns first selected item index in a list view. See also LVNextSelected, - LVNextItem and LVFocusItem functions. } - - property LVFocusItem: Integer read GetLVFocusItem; - {* |<#listview> - Returns focused item index in a list view. See also LVCurItem. } - - function LVNextItem( IdxPrev: Integer; Attrs: DWORD ): Integer; - {* |<#listview> - Returns an index of the next after IdxPrev item with given attributes in - the list view. Attributes can be: - LVNI_ALL - Searches for a subsequent item by index, the default value. - |

- Searchs by physical relationship to the index of the item where the - search is to begin. - LVNI_ABOVE - Searches for an item that is above the specified item. - LVNI_BELOW - Searches for an item that is below the specified item. - LVNI_TOLEFT - Searches for an item to the left of the specified item. - LVNI_TORIGHT - Searches for an item to the right of the specified item. - |

- The state of the item to find can be specified with one or a combination - of the following values: - LVNI_CUT - The item has the LVIS_CUT state flag set. - LVNI_DROPHILITED - The item has the LVIS_DROPHILITED state flag set - LVNI_FOCUSED - The item has the LVIS_FOCUSED state flag set. - LVNI_SELECTED - The item has the LVIS_SELECTED state flag set.} - function LVNextSelected( IdxPrev: Integer ): Integer; - {* |<#listview> - Returns an index of next (after IdxPrev) selected item in a list view. } - - function LVAdd( const aText: KOLString; ImgIdx: Integer; State: TListViewItemState; - StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer; - {* |<#listview> - Adds new line to the end of ListView control. Only content of item itself - is set (aText, ImgIdx). To change other column text and attributes of - item added, use appropriate properties / methods (). - |
- Returns an index of added item. - |
- There is no Unicode version defined, use LVItemAddW instead. } - function LVItemAdd( const aText: KOLString ): Integer; - {* |<#listview> - Adds an item to the end of list view. Returns an index of the item added. } - function LVInsert( Idx: Integer; const aText: KOLString; ImgIdx: Integer; - State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer; - {* |<#listview> - Inserts new line before line with index Idx in ListView control. Only - content of item itself is set (aText, ImgIdx). To change other column - text and attributes of item added, use appropriate properties / methods (). - if ImgIdx = I_IMAGECALLBACK, event handler OnGetLVItemImgIdx is responsible - for returning image index for an item ( /// not implemented yet /// ) - Pass StateImgIdx and OverlayImgIdx = 0 (ignored in that case) or 1..15 to - use correspondent icon from ImageListState image list. - |
Returns an index of item inserted. - |
There is no unicode version of this method, use LVItemInsertW. } - function LVItemInsert( Idx: Integer; const aText: KOLString ): Integer; - {* |<#listview> - Inserts an item to Idx position. } - - procedure LVDelete( Idx: Integer ); - {* |<#listview> - Deletes item of ListView with subitems (full row - in lvsDetail view style. } - procedure LVSetItem( Idx, Col: Integer; const aText: KOLString; ImgIdx: Integer; - State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ); - {* |<#listview> - Use this method to set item data and item columns data for ListView control. - It is possible to pass I_SKIP as ImgIdx, StateImgIdx, OverlayImgIdx values to - skip setting this fields. But all other are set always. Like in LVInsert / - LVAdd, ImgIdx can be I_IMAGECALLBACK to determine that image will be - retrieved in OnGetItemImgIdx event handler when needed. - |
- If this method is called to set data for column > 0, parameters ImgIdx and - Data are ignored anyway. - |
There is no unicode version of this method, use other methods - to set up listed properties separately using correspondent W-functions. } - - property LVItemState[ Idx: Integer ]: TListViewItemState read LVGetItemState write LVSetItemState; - {* |<#listview> - Access to list view item states set [lvisBlend, lvisHighlight, lvisFocus, - lvisSelect]. When assign new value to the property, it is possible to use - special index value -1 to change state for all items for a list view - (but only when lvoMultiselect style is applied to the list view, otherwise - index -1 is referring to the last item of the list view). } - - property LVItemIndent[ Idx: Integer ]: Integer read LVGetItemIndent write LVSetItemIndent; - {* Item indentation. Indentation is calculated as this value multiplied to - image list ImgWidth value (Image list must be applied to list view). - Note: indentation supported only if IE3.0 or higher installed. } - property LVItemStateImgIdx[ Idx: Integer ]: Integer read LVGetSttImgIdx write LVSetSttImgIdx; - {* |<#listview> - Access to state image of the item. Use index -1 to assign the same state - image index to all items of the list view at once (fast). - Option lvoCheckBoxes just means, that control itself creates special inner - image list for two state images. Later it is possible to examine checked - state for items or set checked state programmatically by changing - LVItemStateImgIdx[ ] property. Value 1 corresponds to unchecked state, - 2 to checked. Value 0 allows to remove checkbox at all. So, to check all - added items by default (e.g.), do following: - ! ListView1.LVItemStateImgIdx[ -1 ] := 2; - |
Use 1-based index of the image - in image list ImageListState. Value 0 reserved to use as "no state image". - Values 1..15 can be used only - this is the Windows restriction on - state images. } - property LVItemOverlayImgIdx[ Idx: Integer ]: Integer read LVGetOvlImgIdx write LVSetOvlImgIdx; - {* |<#listview> - Access to overlay image of the item. Use index -1 to assign the same - overlay image to all items of the list view at once (fast). } - property LVItemData[ Idx: Integer ]: DWORD read LVGetItemData write LVSetItemData; - {* |<#listview> - Access to user defined data, assiciated with the item of the list view. } - procedure LVSelectAll; - {* |<#listview> - Call this method to select all the items of the list view control. } - property LVSelCount: Integer read GetSelLength; // write SetSelLength; - {* |<#listview> - Returns number of items selected in listview. } - property LVItemImageIndex[ Idx: Integer ]: Integer read LVGetItemImgIdx write LVSetItemImgIdx; - {* |<#listview> - Image index of items in listview. When an item is created (using LVItemAdd - or LVItemInsert), image index 0 is set by default (not -1 like in VCL!). } - property LVItems[ Idx, Col: Integer ]: KOLString read LVGetItemText write LVSetItemText; - {* |<#listview> - Access to List View item text. } - function LVItemRect( Idx: Integer; Part: TGetLVItemPart ): TRect; - {* |<#listview> - Returns rectangle occupied by given item part(s) in ListView window. - Empty rectangle is returned, if the item is not viewing currently. } - function LVSubItemRect( Idx, ColIdx: Integer ): TRect; - {* |<#listview> - Returns rectangle occupied by given item's subitem in ListView window, - in lvsDetail or lvsDetailNoHeader style. Empty rectangle (0,0,0,0) is - returned if the item is not viewing currently. Left or/and right bounds - of the rectangle returned can be outbound item rectangle if only a part - of the subitem is visible or the subitem is not visible in the item, - which is visible itself. } - property LVItemPos[ Idx: Integer ]: TPoint read LVGetItemPos write LVSetItemPos; - {* |<#listview> - Position of List View item (can be changed in icon or small icon view). } - function LVItemAtPos( X, Y: Integer ): Integer; - {* |<#listview> - Return index of item at the given position. } - function LVItemAtPosEx( X, Y: Integer; var Where: TWherePosLVItem ): Integer; - {* |<#listview> - Retrieves index of item and sets in Where, what part of item is under - given coordinates. If there are no items at the specified position, - -1 is returned. } - procedure LVMakeVisible( Item: Integer; PartiallyOK: Boolean ); - {* |<#listview> - Makes listview item visible. Ignred when Item passed < 0. } - procedure LVEditItemLabel( Idx: Integer ); - {* |<#listview> - Begins in-place editing of item label (first column text). } - procedure LVSort; - {* |<#listview> - Initiates sorting of list view items. This sorting procedure is available only - for Win2K, WinNT4 with IE5, Win98 or Win95 with IE5. See also LVSortData. } - procedure LVSortData; - {* |<#listview> - Initiates sorting of list view items. This sorting procedure is always available - in Windows95/98, NT/2000. But OnCompareLVItems procedure receives not indexes of - items compared but its Data field associated instead. } - procedure LVSortColumn( Idx: Integer ); - {* |<#listview> - This is a method to simplify sort by column. Just call it in your OnColumnClick - event passing column index and enjoy with your list view sorted automatically - when column header is clicked. Requieres Windows2000 or Winows98, not supported - under WinNT 4.0 and below and under Windows95. - |
- Either lvoSortAscending or lvoSortDescending option must be set in - LVOptions, otherwise no sorting is performed. } - function LVIndexOf( const S: KOLString ): Integer; - {* Returns first list view item index with caption matching S. - The same as LVSearchFor( S, -1, FALSE ). } - function LVSearchFor( const S: KOLString; StartAfter: Integer; Partial: Boolean ): Integer; - {* Searches an item with Caption equal to S (or starting from S, if Partial = TRUE). - Searching is started after an item specified by StartAfter parameter. } - - //======== List view page: - property LVTopItem: Integer index LVM_GETTOPINDEX read GetIntVal; //LVGetTopItem; - {* |<#listview> - Returns index of topmost visible item of ListView in lvsList view style. } - property LVPerPage: Integer index LVM_GETCOUNTPERPAGE read GetIntVal; //LVGetPerPage; - {* |<#listview> - Returns the number of fully-visible items if successful. If the current - view is icon or small icon view, the return value is the total number - of items in the list view control. } - - //======== List View specific events: - property OnEndEditLVItem: TOnEditLVItem - read {$IFDEF EVENTS_DYNAMIC} Get_OnEndEditLVItem {$ELSE} EV.fOnEndEditLVItem {$ENDIF} - write SetOnEndEditLVItem; - {* |<#listview> - Called when edit of an item label in ListView control finished. Return - True to accept new label text, or false - to not accept it (item label - will not be changed). If handler not set to an event, all changes are - accepted. } - - property OnLVDelete: TOnDeleteLVItem - read {$IFDEF EVENTS_DYNAMIC} Get_OnDeleteLVItem {$ELSE} EV.fOnDeleteLVItem {$ENDIF} - write SetOnDeleteLVItem; - {* |<#listview> - This event is called when an item is deleted in the listview. - Do not add, delete, or rearrange items in the list view while processing - this notification. } - property OnDeleteLVItem: TOnDeleteLVItem - read {$IFDEF EVENTS_DYNAMIC} Get_OnDeleteLVItem {$ELSE} EV.fOnDeleteLVItem {$ENDIF} - write SetOnDeleteLVItem; - {* |<#listview> - Called for every deleted list view item. } - property OnDeleteAllLVItems: TOnEvent read DF.fOnDeleteAllLVItems write SetOnDeleteAllLVItems; - {* |<#listview> - Called when all the items of the list view control are to be deleted. If after - returning from this event handler event OnDeleteLVItem is yet assigned, - an event OnDeleteLVItem will be called for every deleted item. } - property OnLVData: TOnLVData - read {$IFDEF EVENTS_DYNAMIC} Get_OnLVData {$ELSE} EV.fOnLVData {$ENDIF} - write SetOnLVData; - {* |<#listview> - Called to provide virtual list view with actual data. To use list view as - virtaul list view, define also lvsOwnerData style and set Count property - to actual row count of the list view. This manner of working with list view - control can greatly improve performance of an application when working with - huge data sets represented in listview control. } - - property OnCompareLVItems: TOnCompareLVItems - read {$IFDEF EVENTS_DYNAMIC} Get_OnCompareLVItems {$ELSE} EV.fOnCompareLVItems {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnCompareLVItems {$ELSE} EV.fOnCompareLVItems {$ENDIF}; - {* |<#listview> - Event to compare two list view items during sort operation (initiated by - LVSort method call). Do not send any messages to the list view control - while it is sorting - results can be unpredictable! } - property OnColumnClick: TOnLVColumnClick - read {$IFDEF EVENTS_DYNAMIC} Get_OnColumnClick {$ELSE} EV.fOnColumnClick {$ENDIF} - write SetOnColumnClick; - {* |<#listview> - This event handler is called when column of the list view control is clicked. - You can use this event to initiate sorting of list view items by this column. } - property OnLVStateChange: TOnLVStateChange - read {$IFDEF EVENTS_DYNAMIC} Get_OnLVStateChange {$ELSE} EV.FOnLVStateChange {$ENDIF} - write SetOnLVStateChange; - {* |<#listview> - This event occure when an item or items range in list view control are - changing its state (e.g. selected or unselected). } - property OnDrawItem: TOnDrawItem - read {$IFDEF EVENTS_DYNAMIC} Get_OnDrawItem {$ELSE} EV.fOnDrawItem {$ENDIF} - write SetOnDrawItem; - {* |<#listview> - |<#listbox> - |<#combo> - This event can be used to implement custom drawing for list view, list box, dropped - list of a combobox. For a list view, custom drawing using this event is possible - only in lvsDetail and lvsDetailNoHeader styles, and OnDrawItem is called to draw - entire row at once only. See also OnLVCustomDraw event. } - - property OnLVCustomDraw: TOnLVCustomDraw - read {$IFDEF EVENTS_DYNAMIC} Get_OnLVCustomDraw {$ELSE} EV.FOnLVCustomDraw {$ENDIF} - write SetOnLVCustomDraw; - {* |<#listview> - Custom draw event for listview. For every item to be drawn, this event - can be called several times during a single drawing cycle - depending on - a result, returned by an event handler. Stage can have one of following - values: - |
-       CDDS_PREERASE
-       CDDS_POSTERASE
-       CDDS_ITEMPREERASE
-       CDDS_PREPAINT
-       CDDS_ITEMPREPAINT
-       CDDS_ITEM
-       CDDS_SUBITEM + CDDS_ITEMPREPAINT
-       CDDS_SUBITEM + CDDS_ITEMPOSTPAINT
-       CDDS_ITEMPOSTPAINT
-       CDDS_POSTPAINT
-
- When called, see on Stage to get know, on what stage the event is - activated. And depend on the stage and on what you want to paint, - return a value as a result, which instructs the system, if to use - default drawing on this (and follows) stage(s) for the item, and if - to notify further about different stages of drawing the item during - this drawing cycle. Possible values to return are: - |
-       CDRF_DODEFAULT - perform default drawing. Do not notify further for this
-                      item (subitem) (or for entire listview, if called with
-                      flag CDDS_ITEM reset - ?);
-       CDRF_NOTIFYITEMDRAW - return this value, when the event is called the
-                      first time in a cycle of drawing, with ItemIdx = -1 and
-                      flag CDDS_ITEM reset in Stage parameter;
-       CDRF_NOTIFYPOSTERASE - usually can be used to provide default erasing,
-                      if you want to perform drawing immediately after that;
-       CDRF_NOTIFYPOSTPAINT - return this value to provide calling the event
-                      after performing default drawing. Useful when you wish
-                      redraw only a part of the (sub)item;
-       CDRF_SKIPDEFAULT - return this value to inform the system that all
-                      drawing is done and system should not peform any more
-                      drawing for the (sub)item during this drawing cycle.
-       CDRF_NEWFONT - informs the system, that font is changed and default
-                      drawing should be performed with changed font;
-       |
- If you want to get notifications for each subitem, do not use option - lvoOwnerDrawFixed, because such style prevents system from notifying - the application for each subitem to be drawn in the listview and only - notifications will be sent about entire items. - |
- See also NM_CUSTOMDRAW in API Help. - } - - procedure Set_LVItemHeight(Value: Integer); - function SetLVItemHeight(Value: Integer): PControl; - property LVItemHeight: Integer read DF.fLVItemHeight write Set_LVItemHeight; - {* |<#listview> - |<#listbox> - |#combo> - It is possible to assign a value to LVItemHeight property only to - control with "owner-draw" style (lvoOwnerDrawFixed for listview, - loOwnerDrawFixed or loOwnerDrawVariable for listbox and - coOwnerDrawFixed or coOwnerDrawVariable for combobox. At least, the - control should have such option while creating it (after showing it - the first time it is possible to change its options to avoid owner - drawing later). } - - //======== TreeView specific properties and methods: - function TVInsert( nParent, nAfter: THandle; const Txt: KOLString ): THandle; - {* |<#treeview> - Inserts item to a tree view. If nParent is 0 or TVI_ROOT, the item is - inserted at the root of tree view. It is possible to pass following special - values as nAfter parameter: - |
-       TVI_FIRST        Inserts the item at the beginning of the list.
-       TVI_LAST	        Inserts the item at the end of the list.
-       TVI_SORT	        Inserts the item into the list in alphabetical order.
-       |
} - procedure TVDelete( Item: THandle ); - {* |<#treeview> - Removes an item from the tree view. If value TVI_ROOT is passed, all items - are removed. } - - property TVSelected: THandle index TVGN_CARET read TVGetItemIdx write TVSetItemIdx; - {* |<#treeview> - Returns or sets currently selected item handle in tree view. } - - property TVDropHilighted: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx; - {* |<#treeview> - Returns or sets item, which is currently highlighted as a drop target. } - property TVDropHilited: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx; - {* The same as TVDropHilighted. } - property TVFirstVisible: THandle index TVGN_FIRSTVISIBLE read TVGetItemIdx write TVSetItemIdx; - {* |<#treeview> - Returns or sets given item to top of tree view. } - - property TVIndent: Integer index TVM_GETINDENT read GetIntVal write SetIntVal; - {* |<#treeview> - The amount, in pixels, that child items are indented relative to their - parent items. } - property TVVisibleCount: Integer index TVM_GETVISIBLECOUNT read GetIntVal; - {* |<#treeview> - Returns number of fully (not partially) visible items in tree view. } - - property TVRoot: THandle index TVGN_ROOT read TVGetItemIdx; - {* |<#treeview> - Returns handle of root item in tree view (or 0, if tree is empty). } - property TVItemChild[ Item: THandle ]: THandle index TVGN_CHILD read TVGetItemNext; - {* |<#treeview> - Returns first child item for given one. } - property TVItemHasChildren[ Item: THandle ]: Boolean read TV_GetItemHasChildren write TV_SetItemHasChildren; - {* |<#treeview> - TRUE, if an Item has children. Set this value to true if you want to - force [+] sign appearing left from the node, even if there are no - subnodes added to the node yet. } - property TVItemChildCount[ Item: THandle ]: Integer read TV_GetItemChildCount; - {* |<#treeview> - Returns number of node child items in tree view. - } - property TVItemNext[ Item: THandle ]: THandle index TVGN_NEXT read TVGetItemNext; - {* |<#treeview> - Returns next sibling item handle for given one (or 0, if passed item is - the last child for its parent node). } - property TVItemPrevious[ Item: THandle ]: THandle index TVGN_PREVIOUS read TVGetItemNext; - {* |<#treeview> - Returns previous sibling item (or 0, if the is no such item). } - property TVItemNextVisible[ Item: THandle ]: THandle index TVGN_NEXTVISIBLE read TVGetItemNext; - {* |<#treeview> - Returns next visible item (passed item must be visible too, to determine, - if it is really visible, use property TVItemRect or TVItemVisible. } - property TVItemPreviousVisible[ Item: THandle ]: THandle index TVGN_PREVIOUSVISIBLE read TVGetItemNext; - {* |<#treeview> - Returns previous visible item. } - property TVItemParent[ Item: THandle ]: THandle index TVGN_PARENT read TVGetItemNext; - {* |<#treeview> - Returns parent item for given one (or 0 for root item). } - - property TVItemText[ Item: THandle ]: KOLString read TVGetItemText write TVSetItemText; - {* |<#treeview> - Text of tree view item. } - function TVItemPath( Item: THandle; Delimiter: KOLChar ): KOLString; - {* |<#treeview> - Returns full path from the root item to given item. Path is calculated - as a concatenation of all parent nodes text strings, separated by - given delimiter character. - |
Please note, that returned path has no trailing delimiter, this - character is only separating different parts of the path. - |
If Item is not specified ( =0 ), path is returned - for Selected item. } - - property TVItemRect[ Item: THandle; TextOnly: Boolean ]: TRect read TVGetItemRect; - {* |<#treeview> - Returns rectangle, occupied by an item in tree view. } - - property TVItemVisible[ Item: THandle ]: Boolean read TVGetItemVisible write TVSetITemVisible; - {* |<#treeview> - Returs True, if item is visible in tree view. It is also possible to - assign True to this property to ensure that a tree view item is visible - (if False is assigned, this does nothing). } - function TVItemAtPos( x, y: Integer; var Where: DWORD ): THandle; - {* |<#treeview> - Returns handle of item found at specified position (relative to upper left - corener of client area of the tree view). If no item found, 0 is returned. - Variable Where receives additional flags combination, describing more - detailed, on which part of item or tree view given point is located, - such as: - |
-       TVHT_ABOVE              Above the client area
-       TVHT_BELOW              Below the client area
-       TVHT_NOWHERE            In the client area, but below the last item
-       TVHT_ONITEM	       On the bitmap or label associated with an item
-       TVHT_ONITEMBUTTON       On the button associated with an item
-       TVHT_ONITEMICON	       On the bitmap associated with an item
-       TVHT_ONITEMINDENT       In the indentation associated with an item
-       TVHT_ONITEMLABEL	       On the label (string) associated with an item
-       TVHT_ONITEMRIGHT	       In the area to the right of an item
-       TVHT_ONITEMSTATEICON    On the state icon for a tree-view item that is in a user-defined state
-       TVHT_TOLEFT	       To the right of the client area
-       TVHT_TORIGHT	       To the left of the client area
-       |
} - - property TVRightClickSelect: Boolean read DF.fTVRightClickSelect write SetTVRightClickSelect; - {* |<#treeview> - Set this property to True to allow change selection to an item, clicked with right mouse button. } - property TVEditing: Boolean read GetTVEditing; - {* |<#treeview> - Returns True, if tree view control is editing its item label. } - property TVItemBold[ Item: THandle ]: Boolean index TVIS_BOLD read TVGetItemStateFlg write TVSetItemStateFlg; - {* |<#treeview> - True, if item is bold. } - property TVItemCut[ Item: THandle ]: Boolean index TVIS_CUT read TVGetITemStateFlg write TVSetItemStateFlg; - {* |<#treeview> - True, if item is selected as part of "cut and paste" operation. } - property TVItemDropHighlighted[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg; - {* |<#treeview> - True, if item is selected as drop target. } - property TVItemDropHilited[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg; - {* The same as TVItemDropHighlighted. } - property TVItemExpanded[ Item: THandle ]: Boolean index TVIS_EXPANDED read TVGetITemStateFlg; // write TVSetItemStateFlg; - {* |<#treeview> - True, if item's list of child items is currently expanded. To change - expanded state, use method TVExpand. } - property TVItemExpandedOnce[ Item: THandle ]: Boolean index TVIS_EXPANDEDONCE read TVGetITemStateFlg; // write TVSetItemStateFlg; - {* |<#treeview> - True, if item's list of child items has been expanded at least once. } - property TVItemSelected[ Item: THandle ]: Boolean index TVIS_SELECTED read TVGetITemStateFlg write TVSetItemStateFlg; - {* |<#treeview> - True, if item is selected. } - - procedure TVExpand( Item: THandle; Flags: DWORD ); - {* |<#treeview> - Call it to expand/collapse item's child nodes. Possible values for Flags - parameter are: - 
-       TVE_COLLAPSE         Collapses the list.
-       TVE_COLLAPSERESET    Collapses the list and removes the child items. Note
-                            that TVE_COLLAPSE must also be specified.
-       TVE_EXPAND	    Expands the list.
-       TVE_TOGGLE	    Collapses the list if it is currently expanded or
-                            expands it if it is currently collapsed.
-
- } - procedure TVSort( N: THandle ); - {* |<#treeview> - By Alex Mokrov. Sorts treeview. If N = 0, entire treeview is sorted. - Otherwise, children of the given node only. - } - - property TVItemImage[ Item: THandle ]: Integer index TVIF_IMAGE read TVGetItemImage write TVSetItemImage; - {* |<#treeview> - Image index for an item of tree view. To tell that there are no image - set, use index -2 (value -1 is reserved for callback image). } - property TVItemSelImg[ Item: THandle ]: Integer index TVIF_SELECTEDIMAGE read TVGetItemImage write TVSetItemImage; - {* |<#treeview> - Image index for an item of tree view in selected state. Use value -2 to - provide no image, -1 used for callback image. } - property TVItemOverlay[ Item: THandle ]: Integer index TVIS_OVERLAYMASK or $80000 - read TVGetItemImage write TVSetItemImage; - {* |<#treeview> - Overlay image index for an item in tree view. - Values 1..15 can be used only - this is the Windows restriction on - overlay images. } - property TVItemStateImg[ Item: THandle ]: Integer index TVIS_STATEIMAGEMASK or $C0000 - read TVGetItemImage write TVSetItemImage; - {* |<#treeview> - State image index for an item in tree view. Use 1-based index of the image - in image list ImageListState. Value 0 reserved to use as "no state image". - } - - property TVItemData[ Item: THandle ]: Pointer read TVGetItemData write TVSetItemData; - {* |<#treeview> - Stores any program-defined pointer with the item. } - procedure TVEditItem( Item: THandle ); - {* |<#treeview> - Begins editing given item label in tree view. } - procedure TVStopEdit( Cancel: Boolean ); - {* |<#treeview> - Ends editing item label, started by user or explicitly by TVEditItem method. } - - property OnTVBeginDrag: TOnTVBeginDrag - read {$IFDEF EVENTS_DYNAMIC} Get_OnTVBeginDrag {$ELSE} EV.fOnTVBeginDrag {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnTVBeginDrag {$ELSE} EV.fOnTVBeginDrag {$ENDIF}; - {* |<#treeview> - Is called for tree view, when its item is to be dragging. } - property OnTVBeginEdit: TOnTVBeginEdit - read {$IFDEF EVENTS_DYNAMIC} Get_OnTVBeginEdit {$ELSE} EV.fOnTVBeginEdit {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnTVBeginEdit {$ELSE} EV.fOnTVBeginEdit {$ENDIF}; - {* |<#treeview> - Is called for tree view, when its item label is to be editing. - Return TRUE to allow editing of the item. } - property OnTVEndEdit: TOnTVEndEdit - read {$IFDEF EVENTS_DYNAMIC} Get_OnTVEndEdit {$ELSE} EV.fOnTVEndEdit {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnTVEndEdit {$ELSE} EV.fOnTVEndEdit {$ENDIF}; - {* |<#treeview> - Is called when item label is edited. It is possible to cancel - edit, returning False as a result. } - property OnTVExpanding: TOnTVExpanding - read {$IFDEF EVENTS_DYNAMIC} Get_OnTVExpanding {$ELSE} EV.fOnTVExpanding {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnTVExpanding {$ELSE} EV.fOnTVExpanding {$ENDIF}; - {* |<#treeview> - Is called just before expanding/collapsing item. It is possible to - return TRUE to prevent expanding item, otherwise FALSE should be returned. } - property OnTVExpanded: TOnTVExpanded - read {$IFDEF EVENTS_DYNAMIC} Get_OnTVExpanded {$ELSE} EV.fOnTVExpanded {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnTVExpanded {$ELSE} EV.fOnTVExpanded {$ENDIF}; - {* |<#treeview> - Is called after expanding/collapsing item children. } - property OnTVDelete: TOnTVDelete - read {$IFDEF EVENTS_DYNAMIC} Get_OnTVDelete {$ELSE} EV.fOnTVDelete {$ENDIF} - write SetOnTVDelete; - {* |<#treeview> - Is called just before deleting item. You may use this event to free - resources, associated with an item (see TVItemData property). } - //----------------- by Sergey Shisminzev: - property OnTVSelChanging: TOnTVSelChanging - read {$IFDEF EVENTS_DYNAMIC} Get_OnTVSelChanging {$ELSE} EV.fOnTVSelChanging {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnTVSelChanging {$ELSE} EV.fOnTVSelChanging {$ENDIF}; - {* |<#treeview> - Is called before changing the selection. The handler can return FALSE - to prevent changing the selection. } - //-------------------------------------- - - //======== Toolbar specific methods: - procedure TBAddBitmap( Bitmap: HBitmap ); - {* |<#toolbar> - Adds bitmaps to a toolbar. You can pass special values as Bitmap to - add one of predefined system button images bitmaps: - |
THandle(-1) to add standard small icons, - |
THandle(-2) to add standard large icons, - |
THandle(-5) to add standard small view icons, - |
THandle(-6) to add standard large view icons, - |
THandle(-9) to add standard small history icons, - |
THandle(-10) to add standard large history icons, - (in that case use following values as indexes to the standard and view - bitmaps: - |
- STD_COPY, STD_CUT, STD_DELETE, STD_FILENEW, STD_FILEOPEN, STD_FILESAVE, - STD_FIND, STD_HELP, STD_PASTE, STD_PRINT, STD_PRINTPRE, STD_PROPERTIES, - STD_REDO, STD_REPLACE, STD_UNDO, - |
- VIEW_LARGEICONS, VIEW_SMALLICONS, - VIEW_LIST, VIEW_DETAILS, VIEW_SORTNAME, VIEW_SORTSIZE, VIEW_SORTDATE, - VIEW_SORTTYPE (use it as parameters BtnImgIdxArray in TBAddButtons or - TBInsertButtons methods, and in assigning value to TBButtonImage[ ] - property). - Added bitmaps have indeces starting from previous count of images - (as these are appended to existing - if any). - |
- Note, that if You add your own (custom) bitmap, it is not transparent. - Do not assume that clSilver is always equal to clBtnFace. Use API - function CreateMappedBitmap to load bitmap from resource and map - desired colors as you wish (e.g., convert clTeal to clBtnFace). Or, - call defined in KOL function LoadMappedBitmap to do the same more easy. - Unfortunately, resource identifier for bitmap to pass it to LoadMappedBitmap - or to CreateMappedBitmap seems must be integer, so it is necessary to - create rc-file manually and compile using Borland Resource Compiler to - figure it out. } - - function TBAddButtons( const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer ): Integer; - {* |<#toolbar> - Adds buttons to toolbar. Last string in Buttons array *must* be empty - ('' or nil), so to add buttons without text, pass ' ' string (one space - char). It is not necessary to provide image indexes for all - buttons (it is sufficient to assign index for first button only). - But in place, correspondent to separator button (defined by string '-'), - any integer must be passed to assign follow image indexes correctly. - See example. - |*Toolbar adding buttons sample. - Code below shows how to call TBAddButtons method to add two buttons with - a separator between these buttons. idxNew and idxOld are integer - expressions assigning image indexes to buttons 'New' and 'Old'. This - indexes are zero-based and refer to bitmap images, added earlier (either - in creating toolbar by call of NewToolbar or later in call of TBAddBitmap). - ! - ! TBAddButtons( [ '&New', '-', '&Old', '' ], [ idxNew, 0, idxOld ] ); - ! - |* - To add check buttons, use prefix '+' or '-' in button definition - string. If next character is '!', such buttons are grouped to a - radio-group. Also, it is possible to use '^' prefix (must be first) to - define button with small drop-down section (use also OnTBDropDown event - to respond to clicking drop down section of such buttons). - |
- This function returns command id for first added button (other - id's can be calculated incrementing the result by one for each - button, except separators, which have no command id). - |
- Note: for static toolbar (single in application and created - once) ids are started from value 100. } - - function TBInsertButtons( BeforeIdx: Integer; Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer ): Integer; - {* |<#toolbar> - Inserts buttons before button with given index on toolbar. Returns - command identifier for first button inserted (other can be calculated - incrementing returned value needed times. See also TBAddButtons. } - - procedure TBDeleteButton( BtnID: Integer ); - {* |<#toolbar> - Deletes single button given by its command id. To delete separator, - use TBDeleteBtnByIdx instead. } - - procedure TBDeleteBtnByIdx( Idx: Integer ); - {* |<#toolbar> - Deletes single button given by its index in toolbar (not by command ID). } - - procedure TBClear; - {* |<#toolbar> - Deletes all buttons. Dufa } - - procedure TBAssignEvents( BtnID: Integer; Events: array of TOnToolbarButtonClick ); - {* |<#toolbar> - Allows to assign separate OnClick events for every toolbar button. - BtnID should be toolbar button ID or index of the first button to - assign event. If it is an ID, events are assigned to buttons in - creation order. Otherwise, events are assigned in placement order. - Anyway, separator buttons are not skipped, so pass at least nil for such - button as an event. - |
- Please note, that though not all buttons should exist before - assigning events to it, therefore at least the first button - (specified by BtnID) must be already added before calling TBAssignEvents. } - - procedure TBResetImgIdx( BtnID, BtnCount: Integer ); - {* |<#toolbar> - Resets image index for BtnCount buttons starting from BtnID. } - - //property CurItem: Integer read DF.fTBCurItem; - {* |<#toolbar> - For toolbar, in OnClick event this property can be used to determine - which button was clicked (100-based button id in toolbar). It is also - possible to use CurIndex property (zero-based) for this purpose as - well, but do not assume, that CurItem always equal to CurIndex+100. - At least, it is possible to call TBItem2Index function to convert - button ID to its index in toolbar. - } - property TBCurItem: Integer read DF.fTBCurItem; - {* |<#toolbar> - Same as CurItem. } - - property TBButtonCount: Integer read GetItemsCount; //TBGetButtonCount; - {* |<#toolbar> - Returns count of buttons on toolbar. The same as Count. } - - property TBBtnImgWidth: Integer read DF.fTBBtnImgWidth write DF.fTBBtnImgWidth; - {* |<#toolbar> - Custom toolbar buttons width. Set it before assigning buttons bitmap. - Changing this property after assigning the bitmap has no effect. } - - function TBItem2Index( BtnID: Integer ): Integer; - {* |<#toolbar> - Converts button command id to button index for tool bar. } - - function TBIndex2Item( Idx: Integer ): Integer; - {* |<#toolbar> - Converts toolbar button index to its command ID. } - - procedure TBConvertIdxArray2ID( const IdxVars: array of PDWORD ); - {* |<#toolbar> - Converts toolbar button indexes to its command IDs for an array - of indexes (each item in the array passed is a pointer to - Integer, containing button index when the procedure is callled, - then all these indexes are relaced with a correspondent button ID).} - - property TBButtonEnabled[ BtnID: Integer ]: Boolean index TB_ENABLEBUTTON - read TBGetBtnStt write TBSetBtnStt; - {* |<#toolbar> - Obvious. } - - property TBButtonVisible[ BtnID: Integer ]: Boolean read TBGetButtonVisible - write TBSetButtonVisible; - {* |<#toolbar> - Allows to hide/show some of toolbar buttons. } - - property TBButtonChecked[ BtnID: Integer ]: Boolean index TB_CHECKBUTTON - read TBGetBtnStt write TBSetBtnStt; - {* |<#toolbar> - Allows to determine 'checked' state of a button (e.g., radio-button), - and to check it programmatically. } - - property TBButtonMarked[ BtnID: Integer ]: Boolean index TB_MARKBUTTON - read TBGetBtnStt write TBSetBtnStt; - {* |<#toolbar> - Returns True if toolbar button is marked (highlighted). Allows to - highlight buttons assigning True to this value. } - - property TBButtonPressed[ BtnID: Integer ]: Boolean index TB_PRESSBUTTON - read TBGetBtnStt write TBSetBtnStt; - {* |<#toolbar> - Allows to detrmine if toolbar button (given by its command ID) pressed, - and press/unpress it programmatically. } - - property TBButtonText[ BtnID: Integer ]: KOLString read TBGetButtonText write TBSetButtonText; - {* |<#toolbar> - Obtains toolbar button text and allows to change it. Be sure that text - is not empty for all buttons, if You want for it to be shown (if at least - one button has empty text, no text labels will be shown at all). At - least set it to ' ' for buttons, which You do not want to show labels, - if You want from other ones to have it. } - - property TBButtonImage[ BtnID: Integer ]: Integer read TBGetBtnImgIdx write TBSetBtnImgIdx; - {* |<#toolbar> - Allows to access/change button image. Do not read this property for - separator buttons, returning value is not proper. If you do not know, - is the button a separator, using function below. } - - function TBButtonSeparator( BtnID: Integer ): Boolean; - {* |<#toolbar> - Returns TRUE, if a toolbar button is separator. } - - property TBButtonRect[ BtnID: Integer ]: TRect read TBGetButtonRect; - {* |<#toolbar> - Obtains rectangle occupied by toolbar button in toolbar window. - (It is not possible to obtain rectangle for buttons, currently - not visible). See also function ToolbarButtonRect. } - - property TBButtonWidth[ BtnID: Integer ]: Integer read TBGetBtnWidth write TBSetBtnWidth; - {* |<#toolbar> - Allows to obtain / change toolbar button width. } - - property TBButtonLParam[const Idx: Integer]: DWORD read TBGetButtonLParam write TBSetButtonLParam; - {* |<#toolbar> - Allows to access/change LParam. Dufa } - - property TBButtonsMinWidth: Integer index 0 - {$IFDEF F_P} read TBGetBtMinMaxWidth - {$ELSE DELPHI} read DF.fTBBtMinWidth - {$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth; - {* |<#toolbar> - Allows to set minimal width for all toolbar buttons. } - property TBButtonsMaxWidth: Integer index 1 - {$IFDEF F_P} read TBGetBtMinMaxWidth - {$ELSE DELPHI} read DF.fTBBtMaxWidth - {$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth; - {* |<#toolbar> - Allows to set maximal width for all toolbar buttons. } - - function TBButtonAtPos( X, Y: Integer ): Integer; - {* |<#toolbar> - Returns command ID of button at the given position on toolbar, - or -1, if there are no button at the position. Value 0 is returned - for separators. } - - function TBBtnIdxAtPos( X, Y: Integer ): Integer; - {* |<#toolbar> - Returns index of button at the given position on toolbar. - This also can be index of separator button. -1 is returned if - there are no buttons found at the position. } - - function TBBtnEvent( Idx: Integer ): TOnToolbarButtonClick; - {* Returns toolbar event handler assigned to a toolbar button - (by its index). } - - function TBMoveBtn( FromIdx, ToIdx: Integer ): Boolean; - {* |<#toolbar> - By TR"]F. Moves button from one position to another. } - - property TBRows: Integer read TBGetRows write TBSetRows; - {* |<#toolbar> - Returns number of rows for toolbar and allows to try to set - desired number of rows (but system can set another number of - rows in some cases). This property has no effect if tboWrapable - style not present in Options when toolbar is created. } - - procedure TBSetTooltips( BtnID1st: Integer; const Tooltips: array of PKOLChar ); - {* |<#toolbar> - Allows to assign tooltips to several buttons. Until this procedure - is not called, tooltips list is not created and no code is added - to executable. This method of tooltips maintainance for toolbar buttons - is useful both for static and dynamic toolbars (meaning "dynamic" - - toolbars with buttons, deleted and inserted at run-time). } - - function TBBtnTooltip( BtnID: Integer ): KOLString; - {* |<#toolbar> Returns tooltip assigned to a toolbar button. } - - property TBAutoSizeButtons: Boolean read GetTBAutoSizeButtons write SetTBAutoSizeButtons; - - property OnTBDropDown: TOnEvent index idx_FOnDropDown - read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnDropDown {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnDropDown {$ENDIF}; - {* |<#toolbar> - This event is called for drop down buttons, when user click drop part - of drop down button. To determine for which button event is called, - look at CurItem or CurIndex property. It is also possible to use - common (with combobox) property OnDropDown. } - - property OnTBClick: TOnEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnClick {$ELSE} EV.fOnClick {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} SetOnClick {$ELSE} EV.fOnClick{$ENDIF}; - {* |<#toolbar> - The same as OnClick. } - - property OnTBCustomDraw: TOnTBCustomDraw read DF.fOnTBCustomDraw write SetOnTBCustomDraw; - {* |<#toolbar> - An event (mainly) to customize toolbar background. } - //---------------------------------------------------------------------- - // DateTimePicker - property OnDTPUserString: TDTParseInputEvent - read {$IFDEF EVENTS_DYNAMIC} Get_OnDTPUserString {$ELSE} EV.FOnDTPUserString {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnDTPUserString {$ELSE} EV.FOnDTPUserString{$ENDIF}; - {* Special event to parse input from the application. Option dtpoParseInput - must be set when control is created. } - property DateTime: TDateTime read GetDateTime write SetDateTime; - {* DateTime for DateTimePicker control only. } - property Date: TDateTime read GetDate write SetDate; - {* Date only for DateTimePicker control only. } - property Time: TDateTime read GetTime write SetTime; - {* Time only for DateTimePicker control only. } - property SystemTime: TSystemTime read Get_SystemTime write Set_SystemTime; - {* Date and Time as TSystemTime. When assing, use year 0 to set "no value". } - property DateTimeRange: TDateTimeRange read GetDateTimeRange - write SetDateTimeRange; - {* DateTimePicker range. If first date in the agrument assigned is NAN, - minimum system allowed value is used as the left bound, and if the second is - NAN, maximum system allowed is used as the right one. } - property DateTimePickerColors[ Index: TDateTimePickerColor ]: TColor - read GetDateTimePickerColor write SetDateTimePickerColor; - property DateTimeFormat: KOLString write SetDateTimeFormat; - - //---------------------------------------------------------------------- - - //---------------------------------------------------------------------- - // ScrollBar - property SBMin: Longint read DF.fSBMinMax.X write SetSBMin; - {* Minimum scrolling area position. } - property SBMax: Longint read DF.fSBMinMax.Y write SetSBMax; - {* Maximum scrolling area position (size of the text or image to be scrolling). - For case when SCROLL_OLD defined, this value should be set as scrolling - object size without SBPageSize. } - property SBMinMax: TPoint read DF.fSBMinMax write SetSBMinMax; - {* The property to adjust SBMin and SBMax for a single call (set X to a minimum - and Y to a maximum value). } - property SBPosition: Integer read DF.fSBPosition write SetSBPosition; - {* Current scroll position. When set, should be between SBMin and - SBMax - max(0, SBPageSize-1) } - property SBPageSize: Integer read DF.fSBPageSize write SetSBPageSize; - {* } - - property OnSBBeforeScroll: TOnSBBeforeScroll - read {$IFDEF EVENTS_DYNAMIC} Get_OnSBBeforeScroll {$ELSE} EV.FOnSBBeforeScroll {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnSBBeforeScroll {$ELSE} EV.FOnSBBeforeScroll {$ENDIF}; - {* } - property OnSBScroll: TOnSBScroll - read {$IFDEF EVENTS_DYNAMIC} Get_OnSBScroll {$ELSE} EV.FOnSBScroll {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_OnSBScroll {$ELSE} EV.FOnSBScroll {$ENDIF}; - {* } - - function SBSetScrollInfo(const SI: TScrollInfo): Integer; - function SBGetScrollInfo(var SI: TScrollInfo): Boolean; - function GetSBMinMax: TPoint; - function GetSBPageSize: Integer; - function GetSBPosition: Integer; - //---------------------------------------------------------------------- - - // "Through", or "transparent" methods to simplify initial - // adjustment of controls and make non-visual designing of - // forms more easy. All these functions return @Self as a - // result, so, it is possible to use such methods immediately - // in constructing statement, concatenating it with dots, e.g.: - // - // NewButton( MyForm, 'Click here' ).PlaceUnder.ResizeParentBottom; - // - {$ENDIF GDI} - function PlaceRight: PControl; - {* Places control right (to previously created on the same parent). } - function PlaceDown: PControl; - {* Places control below (to previously created on the same parent). - Left position is not changed (thus is, kept equal to Parent.Margin). } - function PlaceUnder: PControl; - {* Places control below (to previously created one, aligning its - Left position to Left position of previous control). } - function SetSize( W, H: Integer ): PControl; - {* Changes size of a control. If W or H less or equal to 0, - correspondent size is not changed. } - {$IFDEF GDI} - function Size( W, H: Integer ): PControl; - {* Like SetSize, but provides automatic resizing of parent control - (recursively). Especially useful for aligned controls. } - function SetClientSize( W, H: Integer ): PControl; - {* Like SetSize, but works setting W = ClientWidth, H = ClientHeight. - Use this method for forms, which can not be resized (dialogs). } - - {$ENDIF GDI} - function AutoSize( AutoSzOn: Boolean ): PControl; - {$IFDEF GDI} - function MakeWordWrap: PControl; - - {* Determines if to autosize control (like label, button, etc.) } - function IsAutoSize: Boolean; - {* TRUE, if a control is autosizing. } - function AlignLeft( P: PControl ): PControl; - {* assigns Left := P.Left } - function AlignTop( P: PControl ): PControl; - {* assigns Top := P.Top } - function ResizeParent: PControl; - {* Resizes parent, calling ResizeParentRight and ResizeParentBottom. } - function ResizeParentRight: PControl; - {* Resizes parent right edge (Margin of parent is added to right - coordinate of a control). If called second time (for the same - parent), resizes only for increasing of right edge of parent. } - - function ResizeParentBottom: PControl; - {* Resizes parent bottom edge (Margin of parent is added to - bottom coordinate of a control). } - function CenterOnParent: PControl; - {* Centers control on parent, or if applied to a form, centers - form on screen. } - function CenterOnForm( Form1: PControl ): PControl; - {* Centers form on another form. If Form1 not present, centers on screen. } - - function Shift( dX, dY : Integer ): PControl; - {* Moves control respectively to current position (Left := Left + dX, - Top := Top + dY). } - {$ENDIF GDI} - function SetPosition( X, Y: Integer ): PControl; - {* Moves control directly to the specified position. } - {$IFDEF GDI} - - function Tabulate: PControl; - {* Call it once for form/applet to provide tabulation between controls on - form/on all forms using TAB / SHIFT+TAB and arrow keys. } - function TabulateEx: PControl; - {* Call it once for form/applet to provide tabulation between controls on - form/on all forms using TAB / SHIFT+TAB and arrow keys. Arrow keys are - used more smart, allowing go to nearest control in certain direction. } - - function SetAlign( AAlign: TControlAlign ): PControl; - {* Assigns passed value to property Align, aligning control on parent, - and returns @Self (so it is "transparent" function, which can be - used to adjust control at the creation, e.g.: - ! MyLabel := NewLabel( MyForm, 'Label1' ).SetAlign( caBottom ); - See also property Align. } - //{-2.95}//function PreventResizeFlicks: PControl; - { * - If called, prevents resizing flicks for child controls, aligned to - right and bottom (but with a lot of code added to executable - about 3,5K). - There is sensible to set DoubleBuffered to True also to eliminate the - most of flicks. - |
    - This method been applied to a form, prevents, resizing flicks for - form and all controls on the form. If it is called for applet window, - all forms are affected. And if You want, You can apply it for certain - control only - in such case only given control and its children will - be resizing without flicks (e.g., using splitter control). } //{-2.95} - - property Checked: Boolean read GetChecked write Set_Checked; - {* |<#checkbox> - |<#radiobox> - |<#bitbtn> - For checkbox and radiobox - if it is checked. Do not assign - value for radiobox - use SetRadioChecked instead. } - function SetChecked(const Value: Boolean): PControl; - {* |<#checkbox> - Use it to check/uncheck check box control or push button. - Do not apply it to check radio buttons - use SetRadioChecked - method below. } - function SetRadioChecked : PControl; - {* |<#radiobox> - Use it to check radio button item correctly (unchecking all - alternative ones). Actually, method Click is called, and control - itself is returned. } - property Check3: TTriStateCheck read GetCheck3 write SetCheck3; - {* |<#checkbox> - State of checkbox with BS_AUTO3STATE style. } - procedure Click; - {* |<#button> - |<#checkbox> - |<#radiobox> - Emulates click on control programmatically, sending WM_COMMAND - message with BN_CLICKED code. This method is sensible only for - buttons, checkboxes and radioboxes. } - - function Perform( msgcode: DWORD; wParam, lParam: Integer): Integer; stdcall; - {* Sends message to control's window (created if needed). } - function Postmsg( msgcode: DWORD; wParam, lParam: Integer): Boolean; stdcall; - {* Sends message to control's window (created if needed). } - procedure AttachProc( Proc: TWindowFunc ); - {* It is possible to attach dynamically any message handler to window - procedure using this method. Last attached procedure is called first. - If procedure returns True, further processing of a message is stopped. - Attached procedure can be detached using DetachProc (but do not - attach/detach procedures during handling of attached procedure - - this can hang application). } - procedure AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean ); - {* The same as AttachProc, but a handler is executed even after terminating - the main message loop processing (i.e. after assigning true to - AppletTerminated global variable. } - function IsProcAttached( Proc: TWindowFunc ): Boolean; - {* Returns True, if given procedure is already in chain of attached - ones for given control window proc. } - procedure DetachProc( Proc: TWindowFunc ); - {* Detaches procedure attached earlier using AttachProc. } - - property OnDropFiles: TOnDropFiles - read {$IFDEF EVENTS_DYNAMIC} Get_OnDropFiles {$ELSE} EV.FOnDropFiles {$ENDIF} - write SetOnDropFiles; - {* Assign this event to your handler, if You want to accept drag and drop - files from other applications such as explorer onto your control. When - this event is assigned to a control or form, this has effect also for - all its child controls too. } - - property CustomData: Pointer read fCustomData write fCustomData; - {* Can be used to exend the object when new type of control added. Memory, - pointed by this pointer, released automatically in the destructor. } - property CustomObj: PObj read fCustomObj write fCustomObj; - {* Can be used to exend the object when new type of control added. Object, - pointed by this pointer, released automatically in the destructor. } - procedure SetAutoPopupMenu( PopupMenu: PObj ); - {* To assign a popup menu to the control, call SetAutoPopupMenu method of - the control with popup menu object as a parameter. } - - function SupportMnemonics: PControl; - {* This method provides supporting mnemonic keys in menus, buttons, checkboxes, - toolbar buttons. } - property OnScroll: TOnScroll - read {$IFDEF EVENTS_DYNAMIC} Get_OnScroll {$ELSE} EV.FOnScroll {$ENDIF} - write SetOnScroll; - {* } - public - {$IFDEF USE_DROPDOWNCOUNT} - property DropDownCount: Cardinal read DF.fDropDownCount write DF.fDropDownCount; - {$ENDIF} - protected - {$IFDEF USE_GRAPHCTLS} - {} fKeyboardProcess: TOnMessage; // for graphic controls ??? - {} fSetFocus: procedure(Ctl: PControl); - {} fPushedBtn: PControl; - {} fSaveCursor: HCursor; - function DoGraphCtlPrepaint: TRect; - procedure GraphicLabelPaint( DC: HDC ); - procedure GraphicCheckBoxPaint( DC: HDC ); - procedure GraphicCheckBoxMouse( var Msg: TMsg ); - procedure GraphicRadioBoxPaint( DC: HDC ); - procedure GraphicButtonPaint( DC: HDC ); - procedure GraphicButtonMouse( var Msg: TMsg ); - function GraphButtonKeyboardProcess( var Msg: TMsg; var Rslt: Integer ): Boolean; - procedure LeaveGraphButton( Sender: PObj ); - procedure GraphicEditPaint( DC: HDC ); - procedure GraphicEditMouse( var Msg: TMsg ); - procedure DestroyGraphEdit( Sender: PObj ); - procedure LeaveGraphEdit( Sender: PObj ); - procedure ChangeGraphEdit( Sender: PObj ); - procedure GraphCtlDrawFocusRect( DC: HDC; const R: TRect ); - {$IFDEF GRAPHCTL_HOTTRACK} - procedure MouseLeaveFromParentOfGraphCtl( Sender: PObj ); - {$ENDIF GRAPHCTL_HOTTRACK} - procedure GroupBoxPaint( DC: HDC ); - {$ENDIF USE_GRAPHCTLS} - {$IFDEF KEY_PREVIEW} - public - property KeyPreview: Boolean - read {$IFDEF USE_FLAGS} GetKeyPreview {$ELSE} fKeyPreview {$ENDIF} - write {$IFDEF USE_FLAGS} SetKeyPreview {$ELSE} fKeyPreview {$ENDIF}; - //property KeyPreviewing: Boolean read fKeyPreviewing write fKeyPreviewing; - {$ENDIF KEY_PREVIEW} - protected - fOldWidth: Word; - fOldHeight: Word; - fClickDisabled: Byte; - fAnchors: Byte; - fNestedMsgHandling: SmallInt; - {* level of nested message handling for a control. Only when it is 0 at - the end of message handling and fBeginDestroying set, the control is - destroyed. } - fUpdateCount: SmallInt; - public - property AnchorLeft: Boolean index ANCHOR_LEFT read GetAnchor write SetAnchor; //+Sormart - property AnchorTop: Boolean index ANCHOR_TOP read GetAnchor write SetAnchor; //+Sormart - property AnchorRight: Boolean index ANCHOR_RIGHT read GetAnchor write SetAnchor; - property AnchorBottom: Boolean index ANCHOR_BOTTOM read GetAnchor write SetAnchor; - function Anchor( aLeft, aTop, aRight, aBottom: Boolean ): PControl; - public - {$IFDEF USE_CONSTRUCTORS} - //------------------------------------------------------------ - // constructors here: - constructor CreateWindowed( AParent: PControl; AClassName: PKOLChar; ACtl3D: Boolean ); - constructor CreateApplet( const ACaption: AnsiString ); - constructor CreateForm( AParent: PControl; const ACaption: AnsiString ); - constructor CreateControl( AParent: PControl; AClassName: PAnsiChar; AStyle: DWORD; - {} ACtl3D: Boolean; Actions: PCommandActions ); - constructor CreateButton( AParent: PControl; const ACaption: AnsiString ); - constructor CreateBitBtn( AParent: PControl; const ACaption: AnsiString; - {} AOptions: TBitBtnOptions; ALayout: TGlyphLayout; AGlyphBitmap: HBitmap; - {} AGlyphCount: Integer); - constructor CreateLabel( AParent: PControl; const ACaption: AnsiString ); - constructor CreateWordWrapLabel( AParent: PControl; const ACaption: AnsiString ); - constructor CreateLabelEffect( AParent: PControl; ACaption: AnsiString; AShadowDeep: Integer ); - constructor CreatePaintBox( AParent: PControl ); - constructor CreateGradientPanel( AParent: PControl; AColor1, AColor2: TColor ); - constructor CreateGradientPanelEx( AParent: PControl; AColor1, AColor2: TColor; - {} AStyle: TGradientStyle; ALayout: TGradientLayout ); - constructor CreateGroupbox( AParent: PControl; const ACaption: AnsiString ); - constructor CreateCheckbox( AParent: PControl; const ACaption: AnsiString ); - constructor CreateRadiobox( AParent: PControl; const ACaption: AnsiString ); - constructor CreateEditbox( AParent: PControl; AOptions: TEditOptions ); - constructor CreatePanel( AParent: PControl; AStyle: TEdgeStyle ); - constructor CreateSplitter( AParent: PControl; AMinSizePrev, AMinSizeNext: Integer; - {} EdgeStyle: TEdgeStyle ); - constructor CreateListbox( AParent: PControl; AOptions: TListOptions ); - constructor CreateCombobox( AParent: PControl; AOptions: TComboOptions ); - constructor CreateCommonControl( AParent: PControl; AClassName: PAnsiChar; AStyle: DWORD; - {} ACtl3D: Boolean; Actions: PCommandActions ); - constructor CreateRichEdit( AParent: PControl; AOptions: TEditOptions ); - constructor CreateRichEdit1( AParent: PControl; AOptions: TEditOptions ); - constructor CreateProgressbar( AParent: PControl ); - constructor CreateProgressbarEx( AParent: PControl; AOptions: TProgressbarOptions ); - constructor CreateListView( AParent: PControl; AStyle: TListViewStyle; AOptions: TListViewOptions; - {} AImageListSmall, AImageListNormal, AImageListState: PImageList ); - constructor CreateTreeView( AParent: PControl; AOptions: TTreeViewOptions; - {} AImgListNormal, AImgListState: PImageList ); - constructor CreateTabControl( AParent: PControl; ATabs: array of String; - {}AOptions: TTabControlOptions; AImgList: PImageList; AImgList1stIdx: Integer ); - constructor CreateToolbar( AParent: PControl; AAlign: TControlAlign; AOptions: TToolbarOptions; - {} ABitmap: HBitmap; AButtons: array of PChar; - {} ABtnImgIdxArray: array of Integer ); - {$ENDIF USE_CONSTRUCTORS} - - {$IFDEF USE_CUSTOMEXTENSIONS} - {$I CUSTOM_TCONTROL_EXTENSION.inc} - {$ENDIF} - // If an option USE_CUSTOMEXTENSIONS is enabled (at the beginning of this - // unit), You can freely extend TControl definition by your own fields, - // methods and properties. This provides You with capability to extend - // TControl implementing another kinds of visual controls without deriving - // new descendant objects from TControl. This way is provided to avoid too - // large grow of executable size. You also can derive your own controls - // from TControl using standard OOP capabilities. In such case an option - // USE_CONSTRUCTORS should be turned on (see it at the start of this unit). - // If You choose this "flat" model of extending the TControl with your - // own properties, fieds, methods, events, etc. You should provide three - // inc-files: CUSTOM_TCONTROL_EXTENSION.inc, containing such definitions - // for TControl, CUSTOM_KOL_EXTENSION.inc, containing needed global - // declarations, and CUSTOM_CODE_EXTENSION.inc, the implementation of those - // two. - // Because KOL is always grow and constantly is extending by me, I also can - // add my own complements for TControl. To avoid naming conflicts, I suggest - // to use the same naming rule for all of You. Name your fields, properies, etc. - // using a form idx_SomeName, where idx is a prefix, containing several - // (at least one) letters and digits. E.g. ZK65_OnSomething. - - protected // rare used fields are moved here from top to make code smaller a bit - //fFocusHandle: HWnd; // to store handle of focused control of form ? - FParentWnd: HWnd; // <<-- ++ for InitOrthaned !! - fParentCoordX: SmallInt; - fParentCoordY: SmallInt; - {$IFDEF USE_MDI} - fMDIClient: PControl; - fCreateWindowProc: function( - lpClassName, lpWindowName: PKOLChar; - dwStyle: DWORD; X, Y, nWidth, nHeight: Integer; - hwndParent: HWnd; hInstance: HInst; lParam: Integer ): HWnd; - stdcall; - {* MDI client window control } - {$ENDIF} - //fMDIChildren: PList; - //{* List of MDI children. It is filled for MDI client window. } - - {$IFDEF USE_fNCDestroyed} - {} fNCDestroyed: Boolean; - {$ENDIF USE_fNCDestroyed} - public - {$IFDEF USE_MDI} - property MDIClient: PControl read fMDIClient; //Get_MDIClient; - {* For MDI forms only: returns MDI client window control, containng all MDI - children. Use this window to send specific messages to rule MDI children. } - {$ENDIF} - {$IFDEF OBSOLETE_FIELDS} - {} fPaintLater: Boolean; - {$ENDIF OBSOLETE_FIELDS} - // last changes (1-Jul-06) from ECM [Michalichenko Eugeny, rest in peace, friend]: - //======== ListBox - private - function GetLBTopIndex: Integer; - procedure SetLBTopIndex(const Value: Integer); - public - function LBItemAtPos(X,Y: Integer): Integer; - {* |<#listbox> - Return index of item at the given position. } - property LBTopIndex: Integer read GetLBTopIndex write SetLBTopIndex; - {* |<#listbox> - Index of the first visible item in a list box} - public - //================== RichEdit specific: ================== - {$IFNDEF NOT_USE_RICHEDIT} - property MaxTextSize: DWORD read GetMaxTextSize write SetMaxTextSize; - {* |<#richedit> - This property valid also for simple edit control, not only for RichEdit. - But for usual edit control, maximum text size available is 32K. For - RichEdit, limit is 4Gb. By default, RichEdit is limited to - 32767 bytes (to set maximum size available to 2Gb, assign MaxInt value - to a property). Also, to get current text size of RichEdit, use property - TextSize or RE_TextSize[ ]. } - property TextSize: Integer read GetTextSize; - {* |<#richedit> - Common for edit and rich edit controls property, which returns size of - text in edit control. Also, for any other control (or form, or applet - window) returns size (in characters) of Caption or Text (what is, the - same property actually). } - property RE_TextSize[ Units: TRichTextSize ]: Integer read REGetTextSize; - {* |<#richedit> - For RichEdit control, it returns text size, measured in desired units - (rtsChars - characters, including OLE objects, counted as a single - character; rtsBytes - presize length of text image (if it would be stored - in file or stream). Please note, that for RichEdit1.0, only size in - characters can be obtained. } - function RE_TextSizePrecise: Integer; - {* |<#richedit> - By Savva. Returns length of rich edit text. } - - property RE_CharFmtArea: TRichFmtArea read DF.fRECharArea write DF.fRECharArea; - {* |<#richedit> - By default, this property is raSelection. Changing it, You determine in - for which area characters format is applyed, when changing - character formatting properties below (not paragraph formatting). - |&A=%0 - } - property RE_CharFormat: TCharFormat read REGetCharformat write RESetCharFormat; - {* |<#richedit> - In differ to follow properties, which allow to control certain formatting - attributes, this property provides low level access for formatting current - character area (see RE_CharFmtArea). It returns TCharFormat structure, - filled in with formatting attributes, and by assigning another value to - this property You can change desired attributes as You wish. Even if - RichEdit1.0 is used, TCharFormat2 is returned (but extended fields are - ignored for RichEdit1.0). } - property RE_Font: PGraphicTool read REGetFont write RESetFont; - {* |<#richedit> - Font of the first character in current selection (when retrieve). - When set (or subproperties of RE_Font are set), all font attributes are - applied to entire . To apply only needed attributes, use another - properties: RE_FmtBold, RE_FmtItalic, RE_FmtStrikeout, RE_FmtUnderline, - RE_FmtName, etc. - |
- Note, that font size is measured in twips, which is about 1/10 of pixel. } - property RE_FmtBold: Boolean index CFM_BOLD read REGetFontEffects write RESetFontEffect; - {* |<#richedit> - Formatting flag. When retrieve, returns True, if fsBold style RE_Font.FontStyle - is valid for a first character in the selection. When set, changes fsBold - style (True - set, False - reset) for all characters in . } - property RE_FmtBoldValid: Boolean index CFM_BOLD read REGetFontMask; - {* } - property RE_FmtItalic: Boolean index CFM_ITALIC read REGetFontEffects write RESetFontEffect; - {* |<#richedit> - Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsItalic - style valid for the first character of the selection, and when set, changes - only fsItalic style for an . } - property RE_FmtItalicValid: Boolean index CFM_ITALIC read REGetFontMask; - {* } - property RE_FmtStrikeout: Boolean index CFM_STRIKEOUT read REGetFontEffects write RESetFontEffect; - {* |<#richedit> - Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsStrikeout - style valid for the first selected character, and when set, changes only - fsStrikeout style for an . } - property RE_FmtStrikeoutValid: Boolean index CFM_STRIKEOUT read REGetFontMask; - {* } - property RE_FmtUnderline: Boolean index CFM_UNDERLINE read REGetFontEffects write RESetFontEffect; - {* |<#richedit> - Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsUnderline - style valid for the first selected character, and when set, changes - fsUnderline style for an . } - property RE_FmtUnderlineValid: Boolean index CFM_UNDERLINE read REGetFontMask; - {* } - property RE_FmtUnderlineStyle: TRichUnderline - read REGetUnderlineEx write RESetUnderlineEx; - {* |<#richedit> - Extended underline style. To check, if this property is valid for - entire selection, examine RE_FmtUnderlineValid value. } - property RE_FmtProtected: Boolean index CFM_PROTECTED read REGetFontEffects write RESetFontEffect; - {* |<#richedit> - Formatting flag. When retrieving, shows, is the first character of the selection - is protected from changing it by user (True) or not (False). To get know, - if retrived value is valid for entire selection, check the property - RE_FmtProtectedValid. When set, makes all characters in protected ( - True) or not (False). } - property RE_FmtProtectedValid: Boolean index CFM_PROTECTED read REGetFontMask; - {* |<#richedit> - True, if property RE_FmtProtected is valid for entire selection, when - retrieving it. } - property RE_FmtHidden: Boolean index CFM_HIDDEN read REGetFontEffects write RESetFontEffect; - {* |<#richedit> - For RichEdit3.0, makes text hidden (not displayed). } - property RE_FmtHiddenValid: Boolean index CFM_HIDDEN read REGetFontMask; - {* |<#richedit> - Returns True, if RE_FmtHidden style is valid for entire selection. } - - property RE_FmtLink: Boolean index $20 {CFM_LINK} read REGetFontEffects write RESetFontEffect; - {* |<#richedit> - Returns True, if the first selected character is a part of link (URL). } - // by Sergey Shisminzev - - property RE_FmtLinkValid: Boolean index $20 {CFM_LINK} read REGetFontMask; - {* } - property RE_FmtFontSize: Integer index (12 shl 16) or CFM_SIZE read REGetFontAttr write RESetFontAttr; - {* |<#richedit> - Formatting value: font size, in twips (1/1440 of an inch, or 1/20 of a - printer's point, or about 1/10 of pixel). When retrieving, returns - RE_Font.FontHeight. - When set, changes font size for entire (but does not change - other font attributes). } - property RE_FmtFontSizeValid: Boolean read REGetFontSizeValid; - {* |<#richedit> - Returns True, if property RE_FmtFontSize is valid for entire selection, - when retrieving it. } - property RE_FmtAutoBackColor: Boolean index CFM_BACKCOLOR read REGetFontEffects write RESetFontEffect; - {* |<#richedit> - True, when automatic back color is used. } - property RE_FmtAutoBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask; - {* } - property RE_FmtFontColor: Integer index (20 shl 16) or CFM_COLOR read REGetFontAttr write RESetFontAttr1; - {* |<#richedit> - Formatting value (font color). When retrieving, returns RE_Font.Color. - When set, changes font color for entire (but does not change - other font attributes). } - property RE_FmtFontColorValid: Boolean index CFM_COLOR read REGetFontMask; - {* |<#richedit> - Returns True, if property RE_FmtFontColor valid for entire selection, - when retrieving it. } - property RE_FmtAutoColor: Boolean index CFM_COLOR read REGetFontEffects write RESetFontEffect; - {* |<#richedit> - True, when automatic text color is used (in such case, RE_FmtFontColor - assignment is ignored for current area). } - property RE_FmtAutoColorValid: Boolean index CFM_COLOR read REGetFontMask; - {* } - property RE_FmtBackColor: Integer index ((64 - {$IFDEF UNICODE_CTRLS} + 32 {$ENDIF} - ) shl 16) or CFM_BACKCOLOR read REGetFontAttr write RESetFontAttr1; - {* |<#richedit> - Formatting value (back color). Only available for Rich Edit 2.0 and higher. - When set, changes background color for entire (but does not change - other font attributes). } - property RE_FmtBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask; - {* } - property RE_FmtFontOffset: Integer index (16 shl 16) or CFM_OFFSET read REGetFontAttr write RESetFontAttr; - {* |<#richedit> - Formatting value (font vertical offset from baseline, positive values - correspond to subscript). When retrieving, returns offset for first - character in the selection. When set, changes font offset for entire - . To get know, is retrieved value valid for entire selction, - check RE_FmtFontOffsetValid property. } - property RE_FmtFontOffsetValid: Boolean index CFM_OFFSET read REGetFontMask; - {* |<#richedit> - Returns True, if property RE_FmtFontOffset is valid for entire selection, - when retrieving it. } - property RE_FmtFontCharset: Integer index (25 shl 16) or CFM_CHARSET read REGetFontAttr write RESetFontAttr; - {* |<#richedit> - Returns charset for first character in current selection, when retrieved - (and to get know, if this value is valid for entire selection, check - property RE_FmtFontCharsetValid). When set, changes charset for all - characters in , but does not alter other formatting attributes. } - property RE_FmtFontCharsetValid: Boolean index CFM_CHARSET read REGetFontMask; - {* |<#richedit> - Returns True, only if rerieved property RE_FmtFontCharset is valid for - entire selection. } - property RE_FmtFontName: KOLString read REGetFontName write RESetFontName; - {* |<#richedit> - Returns font face name for first character in the selection, when retrieved, - and sets font name for entire , wnen assigned to (without - changing of other formatting attributes). To get know, if retrived - font name valid for entire selection, examine property RE_FmtFontNameValid. } - property RE_FmtFontNameValid: Boolean index CFM_FACE read REGetFontMask; - {* |<#richedit> - Returns True, only if the font name is the same for entire selection, - thus is, if rerieved property value RE_FmtFontName is valid for entire - selection. } - - property RE_ParaFmt: TParaFormat read REGetParaFmt write RESetParaFmt; - {* |<#richedit> - Allows to retrieve or set paragraph formatting attributes for currently - selected paragraph(s) in RichEdit control. See also following properties, - which allow to do the same for certain paragraph format attributes - separately. } - property RE_TextAlign: TRichTextAlign read REGetTextAlign write RESetTextAlign; - {* |<#richedit> - Returns text alignment for current selection and allows to change it - (without changing other formatting attributes). } - property RE_TextAlignValid: Boolean index PFM_ALIGNMENT read REGetParaAttrValid; - {* |<#richedit> - Returns True, if property RE_TextAlign is valid for entire selection. If - False, it is concerning only start of selection. } - property RE_Numbering: Boolean read REGetNumbering write RESetNumbering; - {* |<#richedit> - Returns True, if selected text is numbered (or has style of list with - bullets). To get / change numbering style, see properties - RE_NumStyle and RE_NumBrackets. } - property RE_NumStyle: TRichNumbering read REGetNumStyle write RESetNumStyle; - {* |<#richedit> - Advanced numbering style, such as rnArabic etc. If You use it, do not - change RE_Numbering property simultaneously - this can cause changing - style to rnBullets only. } - property RE_NumStart: Integer read REGetNumStart write RESetNumStart; - {* |<#richedit> - Starting number for advanced numbering style. If this property is not - set, numbering is starting by default from 0. For rnLRoman and rnURoman - this cause, that first item has no number to be shown (ancient Roman - people did not invent '0'). } - property RE_NumBrackets: TRichNumBrackets read REGetNumBrackets write RESetNumBrackets; - {* |<#richedit> - Brackets style for advanced numbering. rnbPlain is default - brackets style, and every time, when RE_NumStyle is changed, - RE_NumBrackets is reset to rnbPlain. } - property RE_NumTab: Integer read REGetNumTab write RESetNumTab; - {* |<#richedit> - Tab between start of number and start of paragraph text. If too small too - view number, number is not displayed. (Default value seems to be sufficient - though). } - property RE_NumberingValid: Boolean index PFM_NUMBERING read REGetParaAttrValid; - {* |<#richedit> - Returns True, if RE_Numbering, RE_NumStyle, RE_NumBrackets, RE_NumTab, - RE_NumStart properties are valid for entire selection. } - property RE_Level: Integer read REGetLevel; - {* |<#richedit> - Outline level (for numbering paragraphs?). Read only. } - property RE_SpaceBefore: Integer index 0 or PFM_SPACEBEFORE read REGetSpacing write RESetSpacing; - {* |<#richedit> - Spacing before paragraph. } - property RE_SpaceBeforeValid: Boolean index PFM_SPACEBEFORE read REGetParaAttrValid; - {* |<#richedit> - True, if RE_SpaceBefore value is valid for all selected paragraph (if - False, this value is valid only for first paragraph. } - property RE_SpaceAfter: Integer index 4 or PFM_SPACEAFTER read REGetSpacing write RESetSpacing; - {* |<#richedit> - Spacing after paragraph. } - property RE_SpaceAfterValid: Boolean index PFM_SPACEAFTER read REGetParaAttrValid; - {* |<#richedit> - True, only if RE_SpaceAfter value is valid for all selected paragraphs. } - property RE_LineSpacing: Integer index 8 or PFM_LINESPACING read REGetSpacing write RESetSpacing; - {* |<#richedit> - Linespacing in paragraph (this value is based on RE_SpacingRule property). } - property RE_SpacingRule: Integer read REGetSpacingRule write RESetSpacingRule; - {* |<#richedit> - Linespacing rule. Do not know what is it. } - property RE_LineSpacingValid: Boolean index PFM_LINESPACING read REGetParaAttrValid; - {* |<#richedit> - True, only if RE_LineSpacing and RE_SpacingRule values are valid for - entire selection. } - property RE_Indent: Integer index (20 shl 16) or PFM_OFFSET read REGetParaAttr write RESetParaAttr; - {* |<#richedit> - Returns left indentation for paragraph in current selection and allows - to change it (without changing other formatting attributes). } - property RE_IndentValid: Boolean index PFM_OFFSET read REGetParaAttrValid; - {* |<#richedit> - Returns True, if RE_Indent property is valid for entire selection. } - property RE_StartIndent: Integer index (12 shl 16) or PFM_STARTINDENT read REGetParaAttr write RESetParaAttr; - {* |<#richedit> - Returns left indentation for first line in paragraph for current - selection, and allows to change it (without changing other formatting - attributes). } - property RE_StartIndentValid: Boolean read REGetStartIndentValid; - {* |<#richedit> - Returns True, if property RE_StartIndent is valid for entire selection. } - property RE_RightIndent: Integer index (16 shl 16) or PFM_RIGHTINDENT read REGetParaAttr write RESetParaAttr; - {* |<#richedit> - Returns right indent for paragraph in current selection, and allow to - change it (without changing other formatting attributes). } - property RE_RightIndentValid: Boolean index PFM_RIGHTINDENT read REGetParaAttrValid; - {* |<#richedit> - Returns True, if property RE_RightIndent is valid for entire selection only. } - property RE_TabCount: Integer read REGetTabCount write RESetTabCount; - {* |<#richedit> - Number of tab stops in current selection. This value can not be set greater - then MAX_TAB_COUNT (32). } - property RE_Tabs[ Idx: Integer ]: Integer read REGetTabs write RESetTabs; - {* |<#richedit> - Tab stops for RichEdit control. } - property RE_TabsValid: Boolean index PFM_TABSTOPS read REGetParaAttrValid; - {* |<#richedit> - Returns True, if properties RE_Tabs[ ] and RE_TabCount are valid for - entire selection. } - - // following does not work now : - property RE_BorderWidth[ Side: TBorderEdge ]: Integer index 2 read REGetBorder write RESetBorder; - { * |<#richedit> - Border width. } - property RE_BorderSpace[ Side: TBorderEdge ]: Integer index 0 read REGetBorder write RESetBorder; - { * |<#richedit> - Border space. } - property RE_BorderStyle[ Side: TBorderEdge ]: Integer index 4 read REGetBorder write RESetBorder; - { * |<#richedit> - Border style. } - property RE_BorderValid: Boolean index PFM_BORDER read REGetParaAttrValid; - { * |<#richedit> - Returns True, if border style, space and width are the same for all - paragraphs in selection. } - property RE_Table: Boolean index $C000 read REGetParaEffect write RESetParaEffect; - { * |<#richedit> - True, if current paragraph is a part of table (row, cell or cell end). - seems working as read only property. } - // end of experiment section - - function RE_FmtStandard: PControl; - {* |<#richedit> - "Transparent" method (returns @Self as a result), which (when called) - provides "standard" keyboard interface for formatting Rich text (just - call this method, for example: - ! RichEd1 := NewRichEdit( Panel1, [ ] ).SetAlign( caClient ).RE_FmtStandard; - Following keys will be maintained additionally: - |
-       CTRL+I - switch "Italic",
-       CTRL+B - switch "Bold",
-       CTRL+U - switch "Underline",
-       CTRL+SHIFT+U - swith underline type
-                    and turn underline on (note, that some of underline styles
-                    can not be shown properly in RichEdit v2.0 and lower,
-                    though RichEdit2.0 stores data successfully).
-       CTRL+O - switch "StrikeOut",
-       CTRL+'gray+' - increase font size,
-       CTRL+'gray-' - decrease font size,
-       CTRL+SHIFT+'gray+' - superscript,
-       CTRL+SHIFT+'gray-' - subscript.
-       CTRL+SHIFT+Z - ReDo
-       |
- And, though following standard formatting keys are provided by RichEdit - control itself in Windows2000, some of these are not functioning - automatically in earlier Windows versions, even for RichEdit2.0. So, - functionality of some of these (marked with (*) ) are added here too: - |
-       CTRL+L - align paragraph left,           (*)
-       CTRL+R - align paragraph right,          (*)
-       CTRL+E - align paragraph center,         (*)
-       CTRL+A - select all,                     (*)
-       double-click on word - select word,
-       CTRL+Right - to next word,
-       CTRL+Left - to previous word,
-       CTRL+Home - to the beginning of text,
-       CTRL+End - to the end of text.
-       CTRL+Z - UnDo
-       |
- If You originally assign some (plain) text to Text property, switching "underline" - can also change other font attributes, e.g., "bold" - if fsBold style is - in default Font. To prevent such behavior, select entire text first (see - SelectAll) and make assignment to RE_Font property, e.g.: - ! RichEd1.SelectAll; - ! RichEd1.RE_Font := RichEd1.RE_Font; - ! RichEd1.SelLength := 0; - |
- And, some other notices about formatting. Please remember, that only True - Type fonts can be succefully scaled and transformed to get desired effects - (e.g., bold). By default, RichEdit uses System font face name, which can - even have problems with fsBold style. Please remember also, that assigning - RE_Font to RE_Font just initializying formatting attributes, making all - those valid in entire text, but does not change font attributes. To use - True Type font, directly assign face name You wish, e.g.: - ! RichEd1.SelectAll; - ! RichEd1.RE_Font := RichEd1.RE_Font; - ! RichEd1.RE_Font.FontName := 'Arial'; - ! RichEd1.SelLength := 0; - } - procedure RE_CancelFmtStandard; - {* Cancels RE_FmtStandard (detaching window procedure handler). } - property RE_AutoKeyboard: Boolean index 1 read REGetLangOptions write RESetLangOptions; - {* |<#richedit> - True if autokeyboard on (lovely "feature" of automatic switching keyboard - language when caret is over another language text). For older RichEdit, - is 'on' always, for newest - 'off' by default. } - property RE_AutoFont: Boolean index 2 read REGetLangOptions write RESetLangOptions; - {* |<#richedit> - True if autofont on (automatic switching font when keyboard layout is - changes). By default, is 'on' always. It is suggested to turn this option - off for Unicode control. } - property RE_AutoFontSizeAdjust: Boolean index 16 read REGetLangOptions write RESetLangOptions; - {* |<#richedit> - See IMF_AUTOFONTSIZEADJUST option in SDK: - Font-bound font sizes are scaled from insertion point size according to - script. For example, Asian fonts are slightly larger than Western ones. - This option is turned on by default. } - property RE_DualFont: Boolean index 128 read REGetLangOptions write RESetLangOptions; - {* |<#richedit> - See IMF_DUALFONT option in SDK: - Sets the control to dual-font mode. Used for Asian language support. - The control uses an English font for ASCII text and a Asian font for - Asian text. } - property RE_UIFonts: Boolean index 32 read REGetLangOptions write RESetLangOptions; - {* |<#richedit> - See IMF_UIFONTS option in SDK: - Use user-interface default fonts. This option is turned off by default. } - property RE_IMECancelComplete: Boolean index 4 read REGetLangOptions write RESetLangOptions; - {* |<#richedit> - See IMF_IMECANCELCOMPLETE option in SDK: - This flag determines how the control uses the composition string of an - IME if the user cancels it. If this flag is set, the control discards - the composition string. If this flag is not set, the control uses the - composition string as the result string. } - property RE_IMEAlwaysSendNotify: Boolean index 8 read REGetLangOptions write RESetLangOptions; - {* |<#richedit> - See IMF_IMEALWAYSSENDNOTIFY option in SDK: - Controls how Rich Edit notifies the client during IME composition: - |
- 0: No EN_CHANGED or EN_SELCHANGE notifications during undetermined state. - Send notification when final string comes in. (default) - |
- 1: Send EN_CHANGED and EN_SELCHANGE events during undetermined state. } - - property RE_OverwriteMode: Boolean read REGetOverwite write RESetOverwrite; - {* |<#richedit> - This property allows to control insert/overwrite mode. First, to examine, if - insert or overwrite mode is current (but it is necessary either to - access this property, at least once, immediately after creating RichEdit - control, or to assign event OnRE_InsOvrMode_Change to your handler). - Second, to set desired mode programmatically - by assigning value to - this property (You also have to initialize monitoring procedure by either - reading RE_OverwriteMode property or assigning handler to event - OnRE_InsOvrMode_Change immediately following RichEdit control creation). } - property OnRE_InsOvrMode_Change: TOnEvent index idx_FOnREInsModeChg - read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnREInsModeChg {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnREInsModeChg {$ENDIF}; - {* |<#richedit> - This event is called, whenever key INSERT is pressed in control (and for - RichEdit, this means, that insert mode is changed). } - property RE_DisableOverwriteChange: Boolean read DF.fReOvrDisable write RESetOvrDisable; - {* |<#richedit> - It is possible to disable switching between "insert" and "overwrite" mode - by user (therefore, event OnRE_InsOvrMode_Change continue works, but it - just called when key INSERT is pressed, though RE_OverwriteMode property - is not actually changed if switching is disabled). } - - function RE_LoadFromStream( Stream: PStream; Length: Integer; - {} Format: TRETextFormat; SelectionOnly: Boolean ): Boolean; - {* |<#richedit> - Use this method rather then assignment to RE_Text property, if - source is stored in file or stream (to minimize resources during - loading of RichEdit content). Data is loading starting from current - position in stream and no more then Length bytes are loaded (use -1 - value to load to the end of stream). Loaded data replaces entire - content of RichEdit control, or selection only, depending on SelectionOnly - flag. - |
    - If You want to provide progress (e.g. in form of progress bar), assign - OnProgress event to your handler - and to examine current position of - loading, read TSream.Position property of soiurce stream). } - function RE_SaveToStream( Stream: PStream; Format: TRETextFormat; SelectionOnly: Boolean ): Boolean; - {* |<#richedit> - Use this method rather then RE_TextProperty to store data to file - or stream (to minimize resources during saving of RichEdit content). - Data is saving starting from current position in a stream (until - end of RichEdit data). If SelectionOnly flag is True, only selected - part of RichEdit text is saved. - |
    - Like for RE_LoadFromStream, it is possible to assign your method to - OnProgress event (but to calculate progress of save-to-stream operation, - compare current stream position with RE_Size[ rsBytes ] property - value). } - - property OnProgress: TOnEvent index idx_FOnProgress - read {$IFDEF EVENTS_DYNAMIC} Get_TOnEvent {$ELSE} EV.fOnProgress {$ENDIF} - write {$IFDEF EVENTS_DYNAMIC} Set_TOnEvent {$ELSE} EV.fOnProgress {$ENDIF}; - {* |<#richedit> - This event is called during RE_SaveToStream, RE_LoadFromStream (and also - during RE_SaveToFile, RE_LoadFromFile and while accessing or changing - RE_Text property). To calculate relative progress, it is possible to - examine current position in stream/file with its total size while reading, - or with rich edit text size, while writing (property RE_TextSize[ rsBytes ]). - } - function RE_LoadFromFile( const Filename: KOLString; Format: TRETextFormat; - {} SelectionOnly: Boolean ): Boolean; - {* |<#richedit> - Use this method rather then other assignments to RE_Text property, - if a source for RichEdit is the file. See also RE_LoadFromStream. } - function RE_SaveToFile( const Filename: KOLString; Format: TRETextFormat; - {} SelectionOnly: Boolean ): Boolean; - {* |<#richedit> - Use this method rather then other similar, if You want to store - entire content of RichEdit or selection only of RichEdit to a file. } - - property RE_Text[ Format: TRETextFormat; SelectionOnly: Boolean ]: KOLString read REReadText write REWriteText; - {* |<#richedit> - This property allows to get / replace content of RichEdit control - (entire text or selection only). Using different formats, it is - possible to exclude or replace undesired formatting information - (see TRETextFormat specification). To get or replace entire text - in reText mode (plain text only), it is possible to use habitual - for edit controls Text property. - |
    - Note: it is possible to append text to the end of RichEdit control - using method Add, but only if property RE_Text is accessed at least - once: - ! RichEdit1.RE_Text[ reText, True ]; - (This line can be written immediatelly after creating RichEdit control). } - - procedure RE_Append( const S: KOLString; ACanUndo: Boolean ); - {* } - procedure RE_InsertRTF( const S: KOLString ); - {* } - property RE_Error: Integer read DF.fREError; - {* |<#richedit> - Contains error code, if access to RE_Text failed. } - - procedure RE_HideSelection( aHide: Boolean ); - {* |<#richedit> - Allows to hide / show selection in RichEdit. } - - function RE_SearchText( const Value: KOLString; MatchCase, WholeWord, ScanForward: Boolean; - SearchFrom, SearchTo: Integer ): Integer; - {* |<#richedit> - Searches given string starting from SearchFrom position up to SearchTo - position (to the end of text, if SearchTo is -1). Returns zero-based - character position of the next match, or -1 if there are no more matches. - To search in bacward direction, set ScanForward to False, and pass - SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). } - {$IFNDEF DISABLE_DEPRECATED} - {$IFNDEF _FPC} - {$IFNDEF _D2} //------- KOLWideString not supported in D2 - function RE_WSearchText( const Value: KOLWideString; MatchCase, WholeWord, ScanForward: Boolean; - SearchFrom, SearchTo: Integer ): Integer; - {* |<#richedit> - Searches given string starting from SearchFrom position up to SearchTo - position (to the end of text, if SearchTo is -1). Returns zero-based - character position of the next match, or -1 if there are no more matches. - To search in bacward direction, set ScanForward to False, and pass - SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). } - {$ENDIF} - {$ENDIF} - {$ENDIF DISABLE_DEPRECATED} - - property RE_AutoURLDetect: Boolean read REGetAutoURLDetect write RESetAutoURLDetect; - {* |<#richedit> - If set to True, automatically detects URLs (and highlights it with - blue color, applying fsItalic and fsUnderline font styles (while - typing and loading). Default value is False. Note: if event OnRE_URLClick - or event OnRE_OverURL are set, property RE_AutoURLDetect is set to True - automatically. } - - property RE_URL: PKOLChar read DF.fREUrl; - {* |<#richedit> - Detected URL (valid in OnRE_OverURL and OnRE_URLClick event handlers). } - property OnRE_OverURL: TOnEvent index 0 read {$IFDEF EVENTS_DYNAMIC} REGetOnURL {$ELSE} - {$IFDEF F_P} REGetOnURL - {$ELSE DELPHI} EV.fOnREOverURL - {$ENDIF F_P/DELPHI} {$ENDIF} write RESetOnURL; - {* |<#richedit> - Is called when mouse is moving over URL. This can be used to set - cursor, for example, depending on type of URL (to determine URL type - read property RE_URL). } - property OnRE_URLClick: TOnEvent index 8 read {$IFDEF EVENTS_DYNAMIC} REGetOnURL {$ELSE} - {$IFDEF F_P} REGetOnURL - {$ELSE DELPHI} EV.fOnREURLClick - {$ENDIF F_P/DELPHI} {$ENDIF} write RESetOnURL; - {* |<#richedit> - Is called when click on URL detected. } - - //property RE_SelectionBar: Boolean read REGetSelectionBar write RESetSelectionBar; - //{* ??? - don't know that is this... } - function RE_NoOLEDragDrop: PControl; - {* |<#richedit> - Just prevents drop OLE objects to the rich edit control. Seems not - working for some cases. } - - //function RE_Wyswig: PControl; - - function RE_Bottomless: PControl; - // finished ? - - property RE_Transparent: Boolean read REGetTransparent write RESetTransparent; - {* |<#richedit> - Use this property to make richedit control transparent, instead of - Ed_Transparent or Transparent. But do not place such transparent - richedit control directly on form - it can be draw incorrectly when - form is activated and rich editr control is not current active control. - Use at least panel as a parent instead. - } - property RE_Zoom: TSmallPoint read REGetZoom write RESetZoom; - {* |<#richedit> - To set zooming for rich edit control (3.0 and above), pass X as numerator - and Y as denominator. Resulting X/Y must be between 1/64 and 64. } - {$ENDIF NOT_USE_RICHEDIT} - - //========== both for Edit and RichEdit: ===================== - function CanUndo: Boolean; - {* |<#richedit> - |<#edit> - |<#memo> - Returns True, if the edit (or RichEdit) control can correctly process - the EM_UNDO message. } - procedure EmptyUndoBuffer; - {* |<#richedit> - |<#edit> - |<#memo> - Reset the undo flag of an edit control, preventing undoing all previous - changes. } - function Undo: Boolean; - {* |<#richedit> - |<#edit> - |<#memo> - For a single-line edit control, the return value is always TRUE. For a - multiline edit control and RichEdit control, the return value is TRUE if - the undo operation is successful, or FALSE if the undo operation fails. } - - public - property PropInt[ PropName: PKOLChar ]: Integer read Get_Prop_Int write Set_Prop_Int; - {* For any windowed control: use it to store desired property in window - properties. } - {$IFNDEF NOT_USE_RICHEDIT} - function RE_Redo: Boolean; - procedure FreeCharFormatRec; - {* |<#richedit> - Only for RichEdit control: Returns True if successful. } - {$ENDIF NOT_USE_RICHEDIT} - public - aAutoSzX: Byte; - aAutoSzY: Byte; - protected - fAlign: TControlAlign; - fAligning:TAlignings; -{$ENDIF GDI} - public - property Align: TControlAlign read FAlign write Set_Align; - {* Align style of a control. If this property is not used in your - application, there are no additional code added. Aligning of - controls is made in KOL like in VCL. To align controls when - initially create ones, use "transparent" function SetAlign - ("transparent" means that it returns @Self as a result). - |
- Note, that it is better not to align combobox caClient, caLeft or - caRight (better way is to place a panel with Border = 0 and - EdgeStyle = esNone, align it as desired and to place a combobox on it - aligning caTop or caBottom). Otherwise, big problems could be under - Win9x/Me, and some delay could occur under any other systems. - |
Do not attempt to align some kinds of controls (like combobox) - caLeft or caRight, this can cause infinite recursion. } - property SizeRedraw: Boolean - read {$IFDEF USE_FLAGS} Get_SizeRedraw {$ELSE} fSizeRedraw {$ENDIF} - write {$IFDEF USE_FLAGS} Set_SizeRedraw {$ELSE} fSizeRedraw {$ENDIF}; - procedure ResetEvent( idx: Integer ); - {$IFDEF FINAL_MARKER} - protected - ffinal_offset: Boolean; - {$ENDIF} - end; - - {$IFDEF USE_MHTOOLTIP} - {$DEFINE interface_part} - {$I KOLMHToolTip_interface.inc} - {$UNDEF interface_part} - {$ENDIF} - - {$IFDEF USE_MHTOOLTIP} - {$DEFINE interface_2} - {$I KOLMHToolTip_intf2.inc} - {$UNDEF interface_2} - {$ENDIF} - -{$IFDEF EVENTS_DYNAMIC} -var EmptyEvents: TEvents; -{$ENDIF} - -function DummyProc123_TRUE( Dummy: Pointer; Sender: PControl; param3: Integer ): Boolean; -function DummyProc123_0( Dummy: Pointer; Sender: PObj; param3: Integer ): Integer; -function DummyProc4_TRUE( Dummy: Pointer; Sender: PControl; p3, p4: Integer ): Boolean; -function DummyProc5_TRUE( Dummy: Pointer; Sender: PControl; p3, p4, p5: Integer ): Boolean; -procedure DummyOnLVDataProc( Dummy: Pointer; Sender: PControl; Idx, SubItem: Integer; - var Txt: KOL_String; var ImgIdx: Integer; var State: DWORD; - var Store: Boolean ); -function DummyProc4_0( Dummy: Pointer; Sender: PControl; p3, p4: Integer ): Integer; -function DummyOnDrawItemProc( Dummy:Pointer; Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer; - DrawAction: TDrawAction; ItemState: TDrawState ): Boolean; -function DummyOnLVCustomDrawProc( Dummy: Pointer; Sender: PControl; DC: HDC; Stage: DWORD; - ItemIdx, SubItemIdx: Integer; const Rect: TRect; - ItemState: TDrawState; var TextColor, BackColor: TColor ): DWORD; -function DummyOnSBBeforeScrollProc(Dummy: Pointer; Sender: PControl; - OldPos, NewPos: Integer; Cmd: Word; var AllowChange: Boolean): Boolean; - -{$IFDEF USE_GRAPHCTLS} -procedure InvalidateWindowed( Sender: PObj ); -procedure InvalidateNonWindowed( Sender: PObj ); -{$ENDIF} - -function FormNewLabel( Form: PControl ): PControl; -function FormNewWordWrapLabel( Form: PControl ): PControl; -function FormNewLabelEffect( Form: PControl ): PControl; -function FormNewButton( Form: PControl ): PControl; -function FormNewBitBtn( Form: PControl ): PControl; -function FormNewPanel( Form: PControl ): PControl; -function FormNewGradientPanel( Form: PControl ): PControl; -function FormNewGradientPanelEx( Form: PControl ): PControl; -function FormNewGroupbox( Form: PControl ): PControl; -function FormNewPaintbox( Form: PControl ): PControl; -function FormNewImageShow( Form: PControl ): PControl; -function FormNewEditBox( Form: PControl ): PControl; -{$IFDEF USE_RICHEDIT} -function FormNewRichEdit( Form: PControl ): PControl; -{$ENDIF} -function FormNewCombobox( Form: PControl ): PControl; -function FormNewCheckbox( Form: PControl ): PControl; -function FormNewRadiobox( Form: PControl ): PControl; -function FormNewSplitter( Form: PControl ): PControl; -function FormNewListbox( Form: PControl ): PControl; -function FormNewListView( Form: PControl ): PControl; -function FormNewTreeView( Form: PControl ): PControl; -function FormNewScrollbox( Form: PControl ): PControl; -function FormNewScrollboxEx( Form: PControl ): PControl; -function FormNewScrollBar( Form: PControl ): PControl; -function FormNewProgressBar( Form: PControl ): PControl; -function FormNewProgressBarEx( Form: PControl ): PControl; -//function FormNewToolbar( Form: PControl ): PControl; -function FormNewDateTimePicker( Form: PControl ): PControl; -{$IFDEF _D4orHigher} -function FormNewTabControl( Form: PControl ): PControl; -{$ENDIF} - -procedure FormSetSize( Form: PControl ); -procedure FormSetHeight( Form: PControl ); -procedure FormSetWidth( Form: PControl ); -procedure FormSetPosition( Form: PControl ); -procedure FormSetClientSize( Form: PControl ); -procedure FormSetAlign( Form: PControl ); -procedure FormSetTag( Form: PControl ); -{$IFDEF USE_NAMES} -procedure FormSetName( Form: PControl ); -{$ENDIF USE_NAMES} -{$IFDEF UNICODE_CTRLS} -procedure FormSetUnicode( Form: PControl ); -{$ENDIF UNICODE_CTRLS} -procedure FormAssignHelpContext( Form: PControl ); -procedure FormSetCanResizeFalse( Form: PControl ); -procedure FormInitMenu( Form: PControl ); - -procedure FormSizeGripFalse( Form: PControl ); -procedure FormSetExStyle( Form: PControl ); -procedure FormSetVisibleFalse( Form: PControl ); -procedure FormSetEnabledFalse( Form: PControl ); -procedure FormResetStyles( Form: PControl ); -procedure FormSetStyle( Form: PControl ); -procedure FormSetAlphaBlend( Form: PControl ); -procedure FormSetHasBorderFalse( Form: PControl ); -procedure FormSetHasCaptionFalse( Form: PControl ); -procedure FormResetCtl3D( Form: PControl ); -procedure FormIconLoad_hInstance( Form: PControl ); -procedure FormIconLoadCursor_0( Form: PControl ); -procedure FormSetIconNeg1( Form: PControl ); -procedure FormIconLoad_hInstance_str( Form: PControl ); -procedure FormSetWindowState( Form: PControl ); -procedure FormCursorLoad_0( Form: PControl ); -procedure FormCursorLoad_hInstance( Form: PControl ); -procedure FormSetColor( Form: PControl ); -procedure FormSetBrushStyle( Form: PControl ); -procedure FormSetBrushBitmap( Form: PControl ); -procedure FormSetFontColor( Form: PControl ); -procedure FormSetFontStyles( Form: PControl ); -procedure FormSetFontHeight( Form: PControl ); -procedure FormSetFontWidth( Form: PControl ); -procedure FormSetFontName( Form: PControl ); -procedure FormSetFontOrientation( Form: PControl ); -procedure FormSetFontCharset( Form: PControl ); -procedure FormSetFontPitch( Form: PControl ); -procedure FormSetBorder( Form: PControl ); -procedure FormSetMarginTop( Form: PControl ); -procedure FormSetMarginBottom( Form: PControl ); -procedure FormSetMarginLeft( Form: PControl ); -procedure FormSetMarginRight( Form: PControl ); -procedure FormSetSimpleStatusText( Form: PControl ); -procedure FormSetStatusText( Form: PControl ); -procedure FormRemoveCloseIcon( Form: PControl ); -procedure FormSetEraseBkgndTrue( Form: PControl ); -procedure FormSetMinWidth( Form: PControl ); -procedure FormSetMaxWidth( Form: PControl ); -procedure FormSetMinHeight( Form: PControl ); -procedure FormSetMaxHeight( Form: PControl ); -procedure FormSetKeyPreviewTrue( Form: PControl ); -// BitBtn only: -procedure FormSetRepeatInterval( Form: PControl ); -procedure FormSetTextShiftX( Form: PControl ); -procedure FormSetTextShiftY( Form: PControl ); -// LabelEffect only: -procedure FormSetColor2( Form: PControl ); - -procedure FormSetTextAlign( Form: PControl ); -procedure FormSetTextVAlign( Form: PControl ); -procedure FormSetTabStopFalse( Form: PControl ); -procedure FormSetIgnoreDefault( Form: PControl ); -procedure FormSetHintText( Form: PControl ); -procedure FormSetAnchor( Form: PControl ); -procedure FormSetCaption( Form: PControl ); -procedure FormSetGradienStyle( Form: PControl ); -procedure FormOverrideScrollbars( Form: PControl ); -// RichEdit only: -{$IFDEF USE_RICHEDIT} -procedure FormSetRE_AutoFontFalse( Form: PControl ); -procedure FormSetRE_AutoFontSizeAdjustFalse( Form: PControl ); -procedure FormSetRE_DualFontTrue( Form: PControl ); -procedure FormSetRE_UIFontsTrue( Form: PControl ); -procedure FormSetRE_IMECancelCompleteTrue( Form: PControl ); -procedure FormSetRE_IMEAlwaysSendNotifyTrue( Form: PControl ); -procedure FormSetMaxTextSize( Form: PControl ); -procedure FormSetRE_AutoKeyboardTrue( Form: PControl ); -procedure FormSetRE_DisableOverwriteChangeTrue( Form: PControl ); -procedure FormSetRE_Zoom( Form: PControl ); -{$ENDIF USE_RICHEDIT} -procedure FormSetListItems( Form: PControl ); -procedure FormSetCount( Form: PControl ); -procedure FormSetDroppedWidth( Form: PControl ); -procedure FormSetButtonIcon( Form: PControl ); -procedure FormSetButtonImage( Form: PControl ); -procedure FormSetButtonBitmap( Form: PControl ); -procedure FormSetDefaultBtn( Form: PControl ); -// progress -procedure FormSetMaxProgress( Form: PControl ); -procedure FormSetProgress( Form: PControl ); -// list view -procedure FormLVColumsAdd( Form: PControl ); -procedure FormSetLVColOrder( Form: PControl ); -procedure FormSetLVColImage( Form: PControl ); -// tree view -procedure FormSetTVIndent( Form: PControl ); -// toolbar -procedure FormSetTBBtnImgWidth( Form: PControl ); -procedure FormTBAddBitmap( Form: PControl ); -procedure FormSetTBButtonSize( Form: PControl ); -{$IFDEF _D4orHigher} -procedure FormTBSetTooltips( Form: PControl ); -{$ENDIF} -procedure FormSetTBButtonsMinWidth( Form: PControl ); -procedure FormSetTBButtonsMaxWidth( Form: PControl ); -procedure FormHideToolbarButton( Form: PControl ); -procedure FormDisableToolbarButton( Form: PControl ); -procedure FormFixFlatXPToolbar( Form: PControl ); -// datetimepicker -procedure FormSetDateTimeFormat( Form: PControl ); -procedure FormSetDateTimeColor( Form: PControl ); -// tabcontrol -procedure FormSetCurrentTab( Form: PControl ); -procedure FormSetCurIdx( Form: PControl ); -// scrolbar -procedure FormSetSBMin( Form: PControl ); -procedure FormSetSBMax( Form: PControl ); -procedure FormSetSBPosition( Form: PControl ); -procedure FormSetSBPageSize( Form: PControl ); - - -procedure FormLastCreatedChildAsNewCurrentParent( Form: PControl ); -procedure FormSetUpperParent( Form: PControl ); -procedure FormSetTabpageAsParent( Form: PControl ); - -procedure FormSetCurCtl( Form: PControl ); -procedure FormSetParent( Form: PControl ); -procedure FormSetEvent( Form: PControl ); -procedure FormSetIndexedEvent( Form: PControl ); - - -{$IFDEF WIN_GDI} -function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect; -{* Use this function instead of reading TControl.TBButtonRect, if you want - to have it working the same way when standard toolbar is used or GRushControl - toolbar provided in ToGRush.pas unit. -} -procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer; const Tooltips: array of PKOLChar ); -{* Use this function instead of TContol.TBSetTooltips in your project, when - you use ToGRush unit. -} -function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean; -{* Use this function instead of reading the property TControl.TBButtonEnabled - when tou use ToGRush unit. } -procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean ); -{* Use this procedure instead of writing the property TControl.TBButtonEnabled - when you use ToGRush unit. } -function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean; -{* Use this function instead of reading the property TControl.TBButtonVisible - when tou use ToGRush unit. } -procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean ); -{* Use this procedure instead of writing the property TControl.TBButtonVisible - when you use ToGRush unit. } -function ToolbarButtonChecked( Toolbar: PControl; BtnID: Integer): Boolean; -{* } -procedure ToolbarButtonSetChecked( Toolbar: PControl; BtnID: Integer; Checked: Boolean ); -{* } -procedure ToolbarAddButtons( Toolbar: PControl; const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer; Bitmap: HBitmap ); -{* } - -function Scrollbar_GetMinPos( sb: PControl ): Integer; -procedure Scrollbar_SetMinPos( sb: PControl; m: Integer ); -procedure Scrollbar_SetAll( sb: PControl; min, max, pg, cur: Integer ); -function Scrollbar_GetMaxPos( sb: PControl ): Integer; -procedure Scrollbar_SetMaxPos( sb: PControl; m: Integer ); -function Scrollbar_GetCurPos( sb: PControl ): Integer; -procedure Scrollbar_SetCurPos( sb: PControl; newp: Integer ); -procedure Scrollbar_SetPageSz( sb: PControl; psz: Integer ); -function Scrollbar_GetPageSz( sb: PControl ): Integer; -procedure Scrollbar_SetLineSz( sb: PControl; lnz: Integer ); -function Scrollbar_GetLineSz( sb: PControl ): Integer; -{$ENDIF WIN_GDI} - -var ToolbarsIDcmd: Integer = 100; - -type - TOnPaintBkgnd = procedure( Sender: PControl; DC: HDC; Rect: PRect ); - {* Global event definition. Used to define Global_OnPaintBackground - event placeholder. } - -procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect ); - -var - Global_OnPaintBkgnd: TOnPaintBkgnd = DefaultPaintBackground; - {* Global event. It is assigned in XBackgounds.pas add-on to replace - PaintBackground method for all TVisual objects, allowing great - visualization effect: transparent controls over [animated] bitmap - background. Idea: - | Wei Bao. Implementation: - | Kladov Vladimir. } - -function GetShiftState: DWORD; -{* Returns shift state. } - -{$IFDEF WIN_GDI} -function WndProcMouse( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -function WndProcKeybd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -function WndProcDummy( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} -function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -{$ENDIF} -function AutoMinimizeApplet(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -{* By Sergey Shishmintzev - Attach this handler to your modal dialog form handle to provide automatic - minimization of all other forms in the application together with the dialog. } - -procedure InitCommonControlSizeNotify( Ctrl: PControl ); -procedure InitCommonControlCommonNotify( Ctrl: PControl ); - -procedure DummyAttachProcExtension ( DynHandlers: PList ); -procedure TransparentAttachProcExtension ( DynHandlers: PList ); - -{$IFNDEF SMALLEST_CODE} -var Global_AttachProcExtension: procedure( DynHandlers: PList ) = DummyAttachProcExtension; -{$ENDIF} -{$ENDIF WIN_GDI} -var HelpFilePath: PKOLChar; - {* Path to application help file. If not assigned, application path with - extension replaced to '.hlp' used. To use '.chm' file (HtmlHelp), - call AssignHtmlHelp with a path to a html help file (or a name). } - -{$IFDEF WIN_GDI} -procedure AssignHtmlHelp( const HtmlHelpPath: KOLString ); -procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: KOLString; Cmd, Data: Integer ); -{* Use this wrapper procedure to call HtmlHelp API function. } -//+++++++++++ HTML HELP DEFINITIONS SECTION: -// this section is from -// HTML Help API Interface Unit -// Copyright (c) 1999 The Helpware Group -// provided for KOL by Alexey Babenko -const - HH_DISPLAY_TOPIC = $0000; {**} - HH_HELP_FINDER = $0000; // WinHelp equivalent - HH_DISPLAY_TOC = $0001; // not currently implemented - HH_DISPLAY_INDEX = $0002; // not currently implemented - HH_DISPLAY_SEARCH = $0003; // not currently implemented - HH_SET_WIN_TYPE = $0004; - HH_GET_WIN_TYPE = $0005; - HH_GET_WIN_HANDLE = $0006; - HH_ENUM_INFO_TYPE = $0007; // Get Info type name, call repeatedly to enumerate, -1 at end - HH_SET_INFO_TYPE = $0008; // Add Info type to filter. - HH_SYNC = $0009; - HH_RESERVED1 = $000A; - HH_RESERVED2 = $000B; - HH_RESERVED3 = $000C; - HH_KEYWORD_LOOKUP = $000D; - HH_DISPLAY_TEXT_POPUP = $000E; // display string resource id or text in a popup window - HH_HELP_CONTEXT = $000F; {**}// display mapped numeric value in dwData - HH_TP_HELP_CONTEXTMENU = $0010; // text popup help, same as WinHelp HELP_CONTEXTMENU - HH_TP_HELP_WM_HELP = $0011; // text popup help, same as WinHelp HELP_WM_HELP - HH_CLOSE_ALL = $0012; // close all windows opened directly or indirectly by the caller - HH_ALINK_LOOKUP = $0013; // ALink version of HH_KEYWORD_LOOKUP - HH_GET_LAST_ERROR = $0014; // not currently implemented // See HHERROR.h - HH_ENUM_CATEGORY = $0015; // Get category name, call repeatedly to enumerate, -1 at end - HH_ENUM_CATEGORY_IT = $0016; // Get category info type members, call repeatedly to enumerate, -1 at end - HH_RESET_IT_FILTER = $0017; // Clear the info type filter of all info types. - HH_SET_INCLUSIVE_FILTER = $0018; // set inclusive filtering method for untyped topics to be included in display - HH_SET_EXCLUSIVE_FILTER = $0019; // set exclusive filtering method for untyped topics to be excluded from display - HH_INITIALIZE = $001C; // Initializes the help system. - HH_UNINITIALIZE = $001D; // Uninitializes the help system. - HH_PRETRANSLATEMESSAGE = $00fd; // Pumps messages. (NULL, NULL, MSG*). - HH_SET_GLOBAL_PROPERTY = $00fc; // Set a global property. (NULL, NULL, HH_GPROP) - - { window properties } - -const - HHWIN_PROP_TAB_AUTOHIDESHOW = $00000001; // (1 << 0) Automatically hide/show tri-pane window - HHWIN_PROP_ONTOP = $00000002; // (1 << 1) Top-most window - HHWIN_PROP_NOTITLEBAR = $00000004; // (1 << 2) no title bar - HHWIN_PROP_NODEF_STYLES = $00000008; // (1 << 3) no default window styles (only HH_WINTYPE.dwStyles) - HHWIN_PROP_NODEF_EXSTYLES = $00000010; // (1 << 4) no default extended window styles (only HH_WINTYPE.dwExStyles) - HHWIN_PROP_TRI_PANE = $00000020; // (1 << 5) use a tri-pane window - HHWIN_PROP_NOTB_TEXT = $00000040; // (1 << 6) no text on toolbar buttons - HHWIN_PROP_POST_QUIT = $00000080; // (1 << 7) post WM_QUIT message when window closes - HHWIN_PROP_AUTO_SYNC = $00000100; // (1 << 8) automatically ssync contents and index - HHWIN_PROP_TRACKING = $00000200; // (1 << 9) send tracking notification messages - HHWIN_PROP_TAB_SEARCH = $00000400; // (1 << 10) include search tab in navigation pane - HHWIN_PROP_TAB_HISTORY = $00000800; // (1 << 11) include history tab in navigation pane - HHWIN_PROP_TAB_FAVORITES = $00001000; // (1 << 12) include favorites tab in navigation pane - HHWIN_PROP_CHANGE_TITLE = $00002000; // (1 << 13) Put current HTML title in title bar - HHWIN_PROP_NAV_ONLY_WIN = $00004000; // (1 << 14) Only display the navigation window - HHWIN_PROP_NO_TOOLBAR = $00008000; // (1 << 15) Don't display a toolbar - HHWIN_PROP_MENU = $00010000; // (1 << 16) Menu - HHWIN_PROP_TAB_ADVSEARCH = $00020000; // (1 << 17) Advanced FTS UI. - HHWIN_PROP_USER_POS = $00040000; // (1 << 18) After initial creation, user controls window size/position - HHWIN_PROP_TAB_CUSTOM1 = $00080000; // (1 << 19) Use custom tab #1 - HHWIN_PROP_TAB_CUSTOM2 = $00100000; // (1 << 20) Use custom tab #2 - HHWIN_PROP_TAB_CUSTOM3 = $00200000; // (1 << 21) Use custom tab #3 - HHWIN_PROP_TAB_CUSTOM4 = $00400000; // (1 << 22) Use custom tab #4 - HHWIN_PROP_TAB_CUSTOM5 = $00800000; // (1 << 23) Use custom tab #5 - HHWIN_PROP_TAB_CUSTOM6 = $01000000; // (1 << 24) Use custom tab #6 - HHWIN_PROP_TAB_CUSTOM7 = $02000000; // (1 << 25) Use custom tab #7 - HHWIN_PROP_TAB_CUSTOM8 = $04000000; // (1 << 26) Use custom tab #8 - HHWIN_PROP_TAB_CUSTOM9 = $08000000; // (1 << 27) Use custom tab #9 - HHWIN_TB_MARGIN = $10000000; // (1 << 28) the window type has a margin - - { window parameters } - -const - HHWIN_PARAM_PROPERTIES = $00000002; // (1 << 1) valid fsWinProperties - HHWIN_PARAM_STYLES = $00000004; // (1 << 2) valid dwStyles - HHWIN_PARAM_EXSTYLES = $00000008; // (1 << 3) valid dwExStyles - HHWIN_PARAM_RECT = $00000010; // (1 << 4) valid rcWindowPos - HHWIN_PARAM_NAV_WIDTH = $00000020; // (1 << 5) valid iNavWidth - HHWIN_PARAM_SHOWSTATE = $00000040; // (1 << 6) valid nShowState - HHWIN_PARAM_INFOTYPES = $00000080; // (1 << 7) valid apInfoTypes - HHWIN_PARAM_TB_FLAGS = $00000100; // (1 << 8) valid fsToolBarFlags - HHWIN_PARAM_EXPANSION = $00000200; // (1 << 9) valid fNotExpanded - HHWIN_PARAM_TABPOS = $00000400; // (1 << 10) valid tabpos - HHWIN_PARAM_TABORDER = $00000800; // (1 << 11) valid taborder - HHWIN_PARAM_HISTORY_COUNT = $00001000; // (1 << 12) valid cHistory - HHWIN_PARAM_CUR_TAB = $00002000; // (1 << 13) valid curNavType - - { button constants } - -const - HHWIN_BUTTON_EXPAND = $00000002; // (1 << 1) Expand/contract button - HHWIN_BUTTON_BACK = $00000004; // (1 << 2) Back button - HHWIN_BUTTON_FORWARD = $00000008; // (1 << 3) Forward button - HHWIN_BUTTON_STOP = $00000010; // (1 << 4) Stop button - HHWIN_BUTTON_REFRESH = $00000020; // (1 << 5) Refresh button - HHWIN_BUTTON_HOME = $00000040; // (1 << 6) Home button - HHWIN_BUTTON_BROWSE_FWD = $00000080; // (1 << 7) not implemented - HHWIN_BUTTON_BROWSE_BCK = $00000100; // (1 << 8) not implemented - HHWIN_BUTTON_NOTES = $00000200; // (1 << 9) not implemented - HHWIN_BUTTON_CONTENTS = $00000400; // (1 << 10) not implemented - HHWIN_BUTTON_SYNC = $00000800; // (1 << 11) Sync button - HHWIN_BUTTON_OPTIONS = $00001000; // (1 << 12) Options button - HHWIN_BUTTON_PRINT = $00002000; // (1 << 13) Print button - HHWIN_BUTTON_INDEX = $00004000; // (1 << 14) not implemented - HHWIN_BUTTON_SEARCH = $00008000; // (1 << 15) not implemented - HHWIN_BUTTON_HISTORY = $00010000; // (1 << 16) not implemented - HHWIN_BUTTON_FAVORITES = $00020000; // (1 << 17) not implemented - HHWIN_BUTTON_JUMP1 = $00040000; // (1 << 18) - HHWIN_BUTTON_JUMP2 = $00080000; // (1 << 19) - HHWIN_BUTTON_ZOOM = $00100000; // (1 << 20) - HHWIN_BUTTON_TOC_NEXT = $00200000; // (1 << 21) - HHWIN_BUTTON_TOC_PREV = $00400000; // (1 << 22) - - HHWIN_DEF_BUTTONS = (HHWIN_BUTTON_EXPAND - OR HHWIN_BUTTON_BACK - OR HHWIN_BUTTON_OPTIONS - OR HHWIN_BUTTON_PRINT); - - { Button IDs } - -const - IDTB_EXPAND = 200; - IDTB_CONTRACT = 201; - IDTB_STOP = 202; - IDTB_REFRESH = 203; - IDTB_BACK = 204; - IDTB_HOME = 205; - IDTB_SYNC = 206; - IDTB_PRINT = 207; - IDTB_OPTIONS = 208; - IDTB_FORWARD = 209; - IDTB_NOTES = 210; // not implemented - IDTB_BROWSE_FWD = 211; - IDTB_BROWSE_BACK = 212; - IDTB_CONTENTS = 213; // not implemented - IDTB_INDEX = 214; // not implemented - IDTB_SEARCH = 215; // not implemented - IDTB_HISTORY = 216; // not implemented - IDTB_FAVORITES = 217; // not implemented - IDTB_JUMP1 = 218; - IDTB_JUMP2 = 219; - IDTB_CUSTOMIZE = 221; - IDTB_ZOOM = 222; - IDTB_TOC_NEXT = 223; - IDTB_TOC_PREV = 224; - - { Notification codes } - -const - HHN_FIRST = (0-860); - HHN_LAST = (0-879); - - HHN_NAVCOMPLETE = (HHN_FIRST-0); - HHN_TRACK = (HHN_FIRST-1); - HHN_WINDOW_CREATE = (HHN_FIRST-2); - -type - {*** Used by command HH_GET_LAST_ERROR - NOTE: Not part of the htmlhelp.h but documented in HH Workshop help - You must call SysFreeString(xx.description) to free BSTR - } - tagHH_LAST_ERROR = packed record - cbStruct: Integer; // sizeof this structure - hr: Integer; // Specifies the last error code. - description: PWideChar; // (BSTR) Specifies a Unicode string containing a description of the error. - end; - HH_LAST_ERROR = tagHH_LAST_ERROR; - THHLastError = tagHH_LAST_ERROR; - -type - {*** Notify event info for HHN_NAVCOMPLETE, HHN_WINDOW_CREATE } - PHHNNotify = ^THHNNotify; - tagHHN_NOTIFY = packed record - hdr: TNMHdr; - pszUrl: PAnsiChar; //PCSTR: Multi-byte, null-terminated string - end; - HHN_NOTIFY = tagHHN_NOTIFY; - THHNNotify = tagHHN_NOTIFY; - - {** Use by command HH_DISPLAY_TEXT_POPUP} - PHHPopup = ^THHPopup; - tagHH_POPUP = packed record - cbStruct: Integer; // sizeof this structure - hinst: HINST; // instance handle for string resource - idString: cardinal; // string resource id, or text id if pszFile is specified in HtmlHelp call - pszText: PAnsiChar; // used if idString is zero - pt: TPOINT; // top center of popup window - clrForeground: COLORREF; // use -1 for default - clrBackground: COLORREF; // use -1 for default - rcMargins: TRect; // amount of space between edges of window and text, -1 for each member to ignore - pszFont: PAnsiChar; // facename, point size, char set, BOLD ITALIC UNDERLINE - end; - HH_POPUP = tagHH_POPUP; - THHPopup = tagHH_POPUP; - - {** Use by commands - HH_ALINK_LOOKUP, HH_KEYWORD_LOOKUP} - PHHAKLink = ^THHAKLink; - tagHH_AKLINK = packed record - cbStruct: integer; // sizeof this structure - fReserved: BOOL; // must be FALSE (really!) - pszKeywords: PAnsiChar; // semi-colon separated keywords - pszUrl: PAnsiChar; // URL to jump to if no keywords found (may be NULL) - pszMsgText: PAnsiChar; // Message text to display in MessageBox if pszUrl is NULL and no keyword match - pszMsgTitle: PAnsiChar; // Message text to display in MessageBox if pszUrl is NULL and no keyword match - pszWindow: PAnsiChar; // Window to display URL in - fIndexOnFail: BOOL; // Displays index if keyword lookup fails. - end; - HH_AKLINK = tagHH_AKLINK; - THHAKLink = tagHH_AKLINK; - -const - HHWIN_NAVTYPE_TOC = 0; - HHWIN_NAVTYPE_INDEX = 1; - HHWIN_NAVTYPE_SEARCH = 2; - HHWIN_NAVTYPE_FAVORITES = 3; - HHWIN_NAVTYPE_HISTORY = 4; // not implemented - HHWIN_NAVTYPE_AUTHOR = 5; - HHWIN_NAVTYPE_CUSTOM_FIRST = 11; - -const - IT_INCLUSIVE = 0; - IT_EXCLUSIVE = 1; - IT_HIDDEN = 2; - -type - PHHEnumIT = ^THHEnumIT; - tagHH_ENUM_IT = packed record //tagHH_ENUM_IT, HH_ENUM_IT, *PHH_ENUM_IT - cbStruct: Integer; // size of this structure - iType: Integer; // the type of the information type ie. Inclusive, Exclusive, or Hidden - pszCatName: PAnsiChar; // Set to the name of the Category to enumerate the info types in a category; else NULL - pszITName: PAnsiChar; // volitile pointer to the name of the infotype. Allocated by call. Caller responsible for freeing - pszITDescription: PAnsiChar; // volitile pointer to the description of the infotype. - end; - THHEnumIT = tagHH_ENUM_IT; - -type - PHHEnumCat = ^THHEnumCat; - tagHH_ENUM_CAT = packed record //tagHH_ENUM_CAT, HH_ENUM_CAT, *PHH_ENUM_CAT - cbStruct: Integer; // size of this structure - pszCatName: PAnsiChar; // volitile pointer to the category name - pszCatDescription: PAnsiChar; // volitile pointer to the category description - end; - THHEnumCat = tagHH_ENUM_CAT; - -type - PHHSetInfoType = ^THHSetInfoType; - tagHH_SET_INFOTYPE = packed record //tagHH_SET_INFOTYPE, HH_SET_INFOTYPE, *PHH_SET_INFOTYPE - cbStruct: Integer; // the size of this structure - pszCatName: PAnsiChar; // the name of the category, if any, the InfoType is a member of. - pszInfoTypeName: PAnsiChar; // the name of the info type to add to the filter - end; - THHSetInfoType = tagHH_SET_INFOTYPE; - -type - HH_INFOTYPE = DWORD; - THHInfoType = HH_INFOTYPE; - PHHInfoType = ^THHInfoType; //PHH_INFOTYPE - -const - HHWIN_NAVTAB_TOP = 0; - HHWIN_NAVTAB_LEFT = 1; - HHWIN_NAVTAB_BOTTOM = 2; - -const - HH_MAX_TABS = 19; // maximum number of tabs -const - HH_TAB_CONTENTS = 0; - HH_TAB_INDEX = 1; - HH_TAB_SEARCH = 2; - HH_TAB_FAVORITES = 3; - HH_TAB_HISTORY = 4; - HH_TAB_AUTHOR = 5; - HH_TAB_CUSTOM_FIRST = 11; - HH_TAB_CUSTOM_LAST = HH_MAX_TABS; - - HH_MAX_TABS_CUSTOM = (HH_TAB_CUSTOM_LAST - HH_TAB_CUSTOM_FIRST + 1); - - { HH_DISPLAY_SEARCH Command Related Structures and Constants } - -const - HH_FTS_DEFAULT_PROXIMITY = (-1); - -type - {** Used by command HH_DISPLAY_SEARCH} - PHHFtsQuery = ^THHFtsQuery; - tagHH_FTS_QUERY = packed record //tagHH_FTS_QUERY, HH_FTS_QUERY - cbStruct: integer; // Sizeof structure in bytes. - fUniCodeStrings: BOOL; // TRUE if all strings are unicode. - pszSearchQuery: PAnsiChar; // String containing the search query. - iProximity: LongInt; // Word proximity. - fStemmedSearch: Bool; // TRUE for StemmedSearch only. - fTitleOnly: Bool; // TRUE for Title search only. - fExecute: Bool; // TRUE to initiate the search. - pszWindow: PAnsiChar; // Window to display in - end; - THHFtsQuery = tagHH_FTS_QUERY; - - { HH_WINTYPE Structure } - -type - {** Used by commands HH_GET_WIN_TYPE, HH_SET_WIN_TYPE} - PHHWinType = ^THHWinType; - tagHH_WINTYPE = packed record //tagHH_WINTYPE, HH_WINTYPE, *PHH_WINTYPE; - cbStruct: Integer; // IN: size of this structure including all Information Types - fUniCodeStrings: BOOL; // IN/OUT: TRUE if all strings are in UNICODE - pszType: PAnsiChar; // IN/OUT: Name of a type of window - fsValidMembers: DWORD; // IN: Bit flag of valid members (HHWIN_PARAM_) - fsWinProperties: DWORD; // IN/OUT: Properties/attributes of the window (HHWIN_) - - pszCaption: PAnsiChar; // IN/OUT: Window title - dwStyles: DWORD; // IN/OUT: Window styles - dwExStyles: DWORD; // IN/OUT: Extended Window styles - rcWindowPos: TRect; // IN: Starting position, OUT: current position - nShowState: Integer; // IN: show state (e.g., SW_SHOW) - - hwndHelp: HWND; // OUT: window handle - hwndCaller: HWND; // OUT: who called this window - - paInfoTypes: PHHInfoType; // IN: Pointer to an array of Information Types - - { The following members are only valid if HHWIN_PROP_TRI_PANE is set } - - hwndToolBar: HWND; // OUT: toolbar window in tri-pane window - hwndNavigation: HWND; // OUT: navigation window in tri-pane window - hwndHTML: HWND; // OUT: window displaying HTML in tri-pane window - iNavWidth: Integer; // IN/OUT: width of navigation window - rcHTML: TRect; // OUT: HTML window coordinates - - pszToc: PAnsiChar; // IN: Location of the table of contents file - pszIndex: PAnsiChar; // IN: Location of the index file - pszFile: PAnsiChar; // IN: Default location of the html file - pszHome: PAnsiChar; // IN/OUT: html file to display when Home button is clicked - fsToolBarFlags: DWORD; // IN: flags controling the appearance of the toolbar (HHWIN_BUTTON_) - fNotExpanded: BOOL; // IN: TRUE/FALSE to contract or expand, OUT: current state - curNavType: Integer; // IN/OUT: UI to display in the navigational pane - tabpos: Integer; // IN/OUT: HHWIN_NAVTAB_TOP, HHWIN_NAVTAB_LEFT, or HHWIN_NAVTAB_BOTTOM - idNotify: Integer; // IN: ID to use for WM_NOTIFY messages - tabOrder: packed array[0..HH_MAX_TABS] of Byte; // IN/OUT: tab order: Contents, Index, Search, History, Favorites, Reserved 1-5, Custom tabs - cHistory: Integer; // IN/OUT: number of history items to keep (default is 30) - pszJump1: PAnsiChar; // Text for HHWIN_BUTTON_JUMP1 - pszJump2: PAnsiChar; // Text for HHWIN_BUTTON_JUMP2 - pszUrlJump1: PAnsiChar; // URL for HHWIN_BUTTON_JUMP1 - pszUrlJump2: PAnsiChar; // URL for HHWIN_BUTTON_JUMP2 - rcMinSize: TRect; // Minimum size for window (ignored in version 1) - - cbInfoTypes: Integer; // size of paInfoTypes; - pszCustomTabs: PAnsiChar; // multiple zero-terminated strings - end; - HH_WINTYPE = tagHH_WINTYPE; - THHWinType = tagHH_WINTYPE; - -const - HHACT_TAB_CONTENTS = 0; - HHACT_TAB_INDEX = 1; - HHACT_TAB_SEARCH = 2; - HHACT_TAB_HISTORY = 3; - HHACT_TAB_FAVORITES = 4; - - HHACT_EXPAND = 5; - HHACT_CONTRACT = 6; - HHACT_BACK = 7; - HHACT_FORWARD = 8; - HHACT_STOP = 9; - HHACT_REFRESH = 10; - HHACT_HOME = 11; - HHACT_SYNC = 12; - HHACT_OPTIONS = 13; - HHACT_PRINT = 14; - HHACT_HIGHLIGHT = 15; - HHACT_CUSTOMIZE = 16; - HHACT_JUMP1 = 17; - HHACT_JUMP2 = 18; - HHACT_ZOOM = 19; - HHACT_TOC_NEXT = 20; - HHACT_TOC_PREV = 21; - HHACT_NOTES = 22; - - HHACT_LAST_ENUM = 23; - -type - {*** Notify event info for HHN_TRACK } - PHHNTrack = ^THHNTrack; - tagHHNTRACK = packed record //tagHHNTRACK, HHNTRACK; - hdr: TNMHdr; - pszCurUrl: PAnsiChar; // Multi-byte, null-terminated string - idAction: Integer; // HHACT_ value - phhWinType: PHHWinType; // Current window type structure - end; - HHNTRACK = tagHHNTRACK; - THHNTrack = tagHHNTRACK; - -/////////////////////////////////////////////////////////////////////////////// -// -// Global Control Properties. -// -const - HH_GPROPID_SINGLETHREAD = 1; // VARIANT_BOOL: True for single thread - HH_GPROPID_TOOLBAR_MARGIN = 2; // long: Provides a left/right margin around the toolbar. - HH_GPROPID_UI_LANGUAGE = 3; // long: LangId of the UI. - HH_GPROPID_CURRENT_SUBSET = 4; // BSTR: Current subset. - HH_GPROPID_CONTENT_LANGUAGE = 5; // long: LandId for desired content. - -type - tagHH_GPROPID = HH_GPROPID_SINGLETHREAD..HH_GPROPID_CONTENT_LANGUAGE; - HH_GPROPID = tagHH_GPROPID; - THHGPropID = HH_GPROPID; - -{$ENDIF WIN_GDI} - -{$IFDEF WIN_GDI} -function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush; - -var - Global_GetCtlBrushHandle: function( Sender: PControl ): HBrush = SimpleGetCtlBrushHandle; - {* Is called to obtain brush handle. } -{$ENDIF WIN_GDI} - - Global_Align: procedure( Sender: PObj ) = DummyObjProc; - {* Is set to perform aligning of control, and only if property Align - is changed for TControl, or SetAlign method is called for it. } - -{$IFDEF WIN_GDI} -function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer ) - : Integer; stdcall; -{* Global message handler for window. Redirects all messages to - destination windows, obtaining target TControl object address from - window itself, using GetProp API call. } -{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -var AppletRunning: Boolean; - {* Is set to True while message loop is processing (in Run procedure). } - AppletTerminated: Boolean; - {* Is set to True when message loop is terminated. } - Applet: PControl; - {* Applet window object. Actually, can be set to main form if program - not needed in special applet button window (useful to make applet - button invisible on taskbar, or to have several forms with single - applet button - crete it in that case using NewApplet). } - AppButtonUsed: Boolean; - {* True if special window to represent applet button (may be invisible) - is used. If no, every form is represented with its own taskbar button - (always visible). } - -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - ScreenCursor: HCursor; - {* Set this global variable to override any cursor settings of current - form or control. } - -function ScreenWidth: Integer; -{* Returns screen width in pixels. } -function ScreenHeight: Integer; -{* Returns screen height in pixels. } - -type - TStatusOption = ( soNoSizeGrip, soTop ); - {* Options available for status bars. } - TStatusOptions = Set of TStatusOption; - {* Status bar options. } - -procedure DrawFormattedText( Ctl: PControl; DC: HDC; var R: TRect; Flags: DWORD {EditCtl: Boolean} ); -{* This procedure can be useful to draw control's text in custom-defined controls. } - -type TCommandActionsParam = {$IFDEF PACK_COMMANDACTIONS} PAnsiChar - {$ELSE} PCommandActions {$ENDIF}; - -{$IFDEF USE_GRAPHCTLS} - -{$IFDEF GRAPHCTL_XPSTYLES} -var DoNotDrawGraphCtlsUsingXPStyles: Boolean; -procedure DrawFormattedTextXP( Theme: THandle; Ctl: PControl; DC: HDC; - var R: TRect; CtlType, CtlStates, Flags1, Flags2: Integer ); -{* This procedure can be useful to draw control's text in custom-defined controls. } -{$ENDIF} - -function _NewGraphCtl( AParent: PControl; ATabStop: Boolean; - ACommandActions: TCommandActionsParam ): PControl; -{* Creates graphic control basics. } - -function NewGraphLabel( AParent: PControl; const ACaption: AnsiString ): PControl; -{* Creates graphic label, which does not require a window handle. } - -function NewWordWrapGraphLabel( AParent: PControl; const ACaption: KOLString ): PControl; -{* Creates graphic label, which does not require a window handle. } - -function NewGraphPaintBox( AParent: PControl ): PControl; -{* Creates graphic paint box (just the same as graphic label, but with empty Caption). } - -function NewGraphCheckBox( AParent: PControl; const ACaption: KOLString ): PControl; -{* Creates graphic checkbox. } - -function NewGraphRadioBox( AParent: PControl; const ACaption: KOLString ): PControl; -{* Creates graphic radiobox. } - -function NewGraphButton( AParent: PControl; const ACaption: KOLString ): PControl; -{* Creates graphic button. } - -function NewGraphEditbox( AParent: PControl; Options: TEditOptions ): PControl; -{* Creates graphic edit box. To do editing, this box should be replaced with - real edit box with a handle (actually, it is enough to place an edit box - on the same Parent having the same BoundsRect). } -{$ENDIF USE_GRAPHCTLS} -{$ENDIF WIN_GDI} - -procedure Run( var AppletCtl: PControl ); -{* |<#appbutton> - Call this procedure to process messages loop of your program. - Pass here pointer to applet button object (if You have created it - - see NewApplet) or your main form object of type PControl (created - using NewForm). - |

- |

- Visual objects constructing functions - |

- Following constructing functions for visual controls are available: - |#control -} - -{$IFDEF WIN_GDI} - -procedure TerminateExecution( var AppletCtl: PControl ); - -procedure AppletMinimize; -{* Minimizes the application (Applet should be assigned to have effect). } -procedure AppletHide; -{* Minimizes and hides application. } -procedure AppletRestore; -{* Restores Applet when minimized. } - -{YS+} -procedure RegisterIdleHandler( const OnIdle: TOnEvent ); -{* Registers new Idle handler. Idle handler is called each time when - message queue becomes empty. } -procedure UnRegisterIdleHandler( const OnIdle: TOnEvent ); -{* Unregisters Idle handler. } -{YS-} - -{* ComCtrl32 controls initialization. } -procedure InitCommonControls; stdcall; -procedure DoInitCommonControls( dwICC: DWORD ); -{* Calls extended initialization for Common Controls (from ComCtrl32). - Pass one of following constants: - |
-  ICC_LISTVIEW_CLASSES   = $00000001; // listview, header
-  ICC_TREEVIEW_CLASSES   = $00000002; // treeview, tooltips
-  ICC_BAR_CLASSES        = $00000004; // toolbar, statusbar, trackbar, tooltips
-  ICC_TAB_CLASSES        = $00000008; // tab, tooltips
-  ICC_UPDOWN_CLASS       = $00000010; // updown
-  ICC_PROGRESS_CLASS     = $00000020; // progress
-  ICC_HOTKEY_CLASS       = $00000040; // hotkey
-  ICC_ANIMATE_CLASS      = $00000080; // animate
-  ICC_WIN95_CLASSES      = $000000FF;
-  ICC_DATE_CLASSES       = $00000100; // month picker, date picker, time picker, updown
-  ICC_USEREX_CLASSES     = $00000200; // comboex
-  ICC_COOL_CLASSES       = $00000400; // rebar (coolbar) control
-  ICC_INTERNET_CLASSES   = $00000800;
-  ICC_PAGESCROLLER_CLASS = $00001000; // page scroller
-  ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control
-   |
- } - -const - ICC_LISTVIEW_CLASSES = $00000001; // listview, header - ICC_TREEVIEW_CLASSES = $00000002; // treeview, tooltips - ICC_BAR_CLASSES = $00000004; // toolbar, statusbar, trackbar, tooltips - ICC_TAB_CLASSES = $00000008; // tab, tooltips - ICC_UPDOWN_CLASS = $00000010; // updown - ICC_PROGRESS_CLASS = $00000020; // progress - ICC_HOTKEY_CLASS = $00000040; // hotkey - ICC_ANIMATE_CLASS = $00000080; // animate - ICC_WIN95_CLASSES = $000000FF; - ICC_DATE_CLASSES = $00000100; // month picker, date picker, time picker, updown - ICC_USEREX_CLASSES = $00000200; // comboex - ICC_COOL_CLASSES = $00000400; // rebar (coolbar) control - ICC_INTERNET_CLASSES = $00000800; - ICC_PAGESCROLLER_CLASS = $00001000; // page scroller - ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control - -function OleInit: Boolean; -{* Calls OleInitialize (once - all other calls are simulated by incrementing - call counter. Every OleInit shoud be complemented with correspondent OleUninit. - (Though, it is possible to call API function OleUnInitialize once to - cancel all OleInit calls). } -procedure OleUnInit; -{* Decrements counter and calls OleUnInitialize when it is zeroed. } -var OleInitCount: Integer; - -function StringToOleStr(const Source: Ansistring): PWideChar; -{* } - -function SysAllocStringLen(psz: PWideChar; len: Integer): PWideChar; stdcall; -procedure SysFreeString( psz: PWideChar ); stdcall; - -{$ENDIF WIN_GDI} -{ -- Contructors for visual controls -- } - -{$IFDEF GDI} -{$IFDEF COMMANDACTIONS_OBJ} -function NewCommandActionsObj: PCommandActionsObj; -function NewCommandActionsObj_Packed( fromPack: PAnsiChar ): PCommandActionsObj; -{$ENDIF} - -function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar; - Ctl3D: Boolean; ACommandActions: TCommandActionsParam): PControl; -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION _NewWindowed( AParent: PControl; ControlClassName: PAnsiChar; - widget: PGtkWidget; need_eventbox: Boolean ): PControl; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -function NewApplet( const Caption: KOLString ): PControl; -{* |<#control> - Creates applet button window, which has to be parent of all other forms - in your project (but this is *not must*). See also comments about NewForm. - |
- Following methods, properties and events are useful to work with applet - control: - |#appbutton } -{$ENDIF WIN_GDI} - -function NewForm( AParent: PControl; const Caption: KOLString ): PControl; -{* |<#control> - Creates form window object and returns pointer to it. If You use only one form, - and You are not going to do applet button on task bar invisible, it is not - necessary to create also special applet button window - just pass - your (main) form object to Run procedure. In that case, it is a good - idea to assign pointer to your main form object to Applet variable - immediately following creating it - because some objects (e.g. TTimer) - want to have Applet assigned to something. - |
- |&D= %0 - Following methods, properties and events are useful to work with forms - (ones common for all visual objects, such as , , , - , etc. are not listed here - look TControl for it): - |#form } - -function NewAlienPanel( AParentWnd: HWnd; EdgeStyle: TEdgeStyle ): PControl; - -{$IFDEF GDI} -function _NewControl( AParent: PControl; ControlClassName: PKOLChar; - Style: DWORD; Ctl3D: Boolean; Actions: TCommandActionsParam ): PControl; -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION _NewControl( AParent: PControl; ControlClassName: PAnsiChar; - Style: DWORD; Ctl3D: Boolean; widget: PGtkWidget; need_eventbox: Boolean ): PControl; -{$ENDIF GTK} -{$ENDIF _X_} - -function NewButton( AParent: PControl; const Caption: KOLString ): PControl; -{* |<#control> - Creates button on given parent control or form. - Please note, that in Windows, buttons can not change its color - and to be . - |
Following methods, properies and events are (especially) useful with - a button: - |#button } - -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -function NewBitBtn( AParent: PControl; const Caption: KOLString; - Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl; -{* |<#control> - Creates image button (actually implemented as owner-drawn). In Options, - it is possible to determine, whether bitmap or image list used to contain - one or more (up to 5) images, correspondent to certain BitBtn state. - |
    - For case of imagelist (option bboImageList), it is possible to use a - number of glyphs from the image list, starting from image index given - by GlyphCount parameter. Number of used glyphs is passed in that case - in high word of GlyphCount parameter (if 0, one image is used therefore). - For bboImageList, BitBtn can be Transparent (and in that case bboNoBorder - style can be useful to draw custom buttons of non-rectangular shape). - |
    - For case of bitmap BitBtn, image is stretched down (if too big), but can - not be transparent. It is not necessary for bitmap BitBtn to pass correct - GlyphCount - it is calculated on base of bitmap size, if 0 is passed. - |
    - And, certainly, BitBtn can be without glyph image (text only). For that - case, it is therefore is more flexible and power than usual Button (but - requires more code). E.g., BitBtn can change its , , - and to be totally . - Moreover, BitBtn can be , bboFixed, and - have property . - |
    - Note: if You use bboFixed Style, use OnChange event instead of OnClick, - because state is changed immediately however OnClick occure - only when mouse or space key released (and can be not called at all if - mouse button is released out of BitBtn bounds). Also, bboFixed defines - only which glyph to show (the border if it is not turned off behaves as - usual for a button, i.e. it becomes lowered and then raised again at any click). - Here You can find references to other properties, events and methods - applicable to BitBtn: - |#bitbtn } - -{$ENDIF GDI} -function NewLabel( AParent: PControl; const Caption: KOLString ): PControl; -{* |<#control> - Creates static text control (native Windows STATIC control). - Use property at run time to change label text. Also - it is possible to adjust label , or . - Label can be . If You want to have rotated text - label, call NewLabelEffect instead and change its .FontOrientation. - Other references certain for a label: - |#label } -{$IFDEF GDI} - -function NewWordWrapLabel( AParent: PControl; const Caption: KOLString ): PControl; -{* |<#control> - Creates multiline static text control (native Windows STATIC control), - which can wrap long text onto several lines. See also NewLabel. - See also: - |#wwlabel - |#label } - -function NewLabelEffect( AParent: PControl; const Caption: KOLString; ShadowDeep: Integer ): PControl; -{* |<#control> - Creates 3D-label with capability to rotate its text , which - is controlled by changing .FontOrientation property. If You want - to get flat effect label (e.g. to rotate it only), pass = 0. - Please note, that drawing procedure uses property, so using of - LabelEffect leads to increase size of executable. - See also: - |#3dlabel - |#label } - -{$ENDIF GDI} -function NewPaintbox( AParent: PControl ): PControl; -{* |<#control> - Creates owner-drawn STATIC control. Set its event to - perform custom painting. - |#paintbox } -{$IFDEF GDI} - -function NewImageShow( AParent: PControl; AImgList: PImageList; ImgIdx: Integer ): PControl; -{* |<#control> - Creates an image show control, implemented as a paintbox which is used to - draw an image from the imagelist. At run-time, use property CurIndex to - select another image from the imagelist, and a property ImageListNormal to - use another image list. When the control is created, its size becomes - equal to dimensions of imagelist (if any). } - -function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl; -{* |<#control> - Creates simple scroll bar. } - -function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle; - Bars: TScrollerBars ): PControl; -{* |<#control> - Creates simple scrolling box, which can be used any way you wish, e.g. to scroll - certain large image. To provide automatic scrolling of a set of child controls, - use advanced scroll box, created with NewScrollBoxEx. } - -procedure NotifyScrollBox( Self_, Child: PControl ); - -function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl; -{* |<#control> - Creates extended scrolling box control, which automatically scrolls child - controls (if any). } - -function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl; -{* |<#control> - Creates gradient-filled STATIC control. To adjust colors at the - run time, change and properties (which initially are - assigned from Color1, Color2 parameters), and call method - to repaint control. } - -function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor; - Style: TGradientStyle; Layout: TGradientLayout ): PControl; -{* |<#control> - Creates gradient-filled STATIC control. To adjust colors at the - run time, change and properties (which initially are - assigned from Color1, Color2 parameters), and call method - to repaint control. Depending on style and first line/point layout, can - looking different. Idea: Vladimir Stojiljkovic. } - -function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl; -{* |<#control> - Creates panel, which can be parent for other controls (though, any - control can be used as a parent for other ones, but panel is specially - designed for such purpose). } - -{$IFDEF USE_MDI} -function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl; -{* |<#control> - Creates MDI client window, which is a special type of child window, - containing all MDI child windows, created calling NewMDIChild function. - On a form, MDI client behaves like a panel, so it can be placed and sized - (or aligned) like any other controls. To minimize flick during resizing - main form having another aligned controls, place MDI client window on - a panel and align it caClient in the panel. - |
Note: - MDI client must be a single on the form. } - -function NewMDIChild( AParent: PControl; const ACaption: KOLString ): PControl; -{* |<#control> - Creates MDI client window. AParent should be a MDI client window, - created with NewMDIClient function. } -{$ENDIF USE_MDI} - -function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl; -{* |<#control> - Creates splitter control, which will separate previous one (i.e. last - created one before splitter on the same parent) from created - next, allowing to user to adjust size of separated controls by dragging - the splitter in desired direction. Created splitter becomes vertical - or horizontal depending on Align style of previous control on the same - parent (if caLeft/caRight then vertical, if caTop/caBottom then horizontal). - |
    - Please note, what if previous control has no Align equal to caLeft/caRight - or caTop/caBottom, splitter will not be able to function normally. If - previous control does not exist, it is yet possible to use splitter as - a resizeable panel (but set its initial Align value first - otherwise it - is not set by default. Also, change Cursor property as You wish in that - case, since it is not set too in case, when previous control does not - exist). - |
    - Additional parameters determine, which minimal size (width or height - - correspondently to split direction) is allowed for left (top) control - and to rest of client area of parent, correspondently. (It is possible - later to set second control for checking its size with MinSizeNext - value - using TControl.SecondControl property). If -1 passed, - correspondent control size is not checked during dragging of splitter. - Usually 0 is more suitable value (with this value, it is garantee, that - splitter will be always available even if mouse was released far from the - edge of form). - |
    - It is possible for user to press Escape any time while dragging splitter - to abort all adjustments made starting from left mouse button push and - begin of drag the splitter. But remember please, that such event is - controlled using timer, and therefore correspondent keyboard events - are received by currently focused control. Be sure, that pressing Escape - will not affect to any control on form, which could be focused, otherwise - filter keyboard messages (by yourself) to prevent undesired handling of - Escape key by certain controls while splitting. (Use Dragging property - to check if splitter is dragging by user with mouse). - |
    - See also: - NewSplitterEx - |#splitter } - -function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer; - EdgeStyle: TEdgeStyle ): PControl; -{* |<#control> - Creates splitter control. Difference from NewSplitter is what it is possible - to determine if a splitter will be beveled or not. See also NewSplitter. } - -function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl; -{* |<#control> - Creates group box control. Note, that to group radio items, group - box is not necessary - any parent can play role of group for radio items. - See also NewPanel. } - -function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl; -{* |<#control> - Creates check box control. Special properties, methods, events: - |#checkbox } - -function NewCheckBox3State( AParent: PControl; const Caption: KOLString ): PControl; -{* |<#control> - Creates check box control with 3 states. Special properties, methods, - events: - |#checkbox } - -function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl; -{* |<#control> - Creates radio box control. Alternative radio items must have the - same parent window (regardless of its kind, either groupbox (NewGroupbox), - panel (NewPanel) or form itself). Following properties, methods and events - are specially for radiobox controls: - |#radiobox } - -function NewEditbox( AParent: PControl; Options: TEditOptions ): PControl; -{* |<#control> - Creates edit box control. To create multiline edit box, similar to - TMemo in VCL, apply eoMultiline in Options. Following properties, methods, - events are special for edit controls: - |#edit } - -{$IFNDEF NOT_USE_RICHEDIT} -var FRichEditModule: Integer; - RichEditClass: PKOLChar; - -const RichEditLibnames: array[ 0..3 ] of PKOLChar = - ( 'msftedit', 'riched20', - 'riched32', 'riched' ); - RichEditClasses: array[ 0..3 ] of PKOLChar = - ( 'RichEdit50W', 'RichEdit20A', - 'RichEdit', 'RichEdit' ); -var RichEditIdx: Byte = High( RichEditLibnames ); - -function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl; -{* |<#control> - Creates rich text edit control. A rich edit control is a window in which - the user can enter and edit text. The text can be assigned character and - paragraph formatting, and can include embedded OLE objects. Rich edit - controls provide a programming interface for formatting text. However, an - application must implement any user interface components necessary to make - formatting operations available to the user. - |
    - Note: eoPassword, eoMultiline options have no effect for RichEdit control. - Some operations are supersided with special versions of those, created - especially for RichEdit, but in some cases it is necessary to use - another properties and methods, specially designed for RichEdit (see - methods and properties, which names are starting from RE_...). - |
    - Following properties, methods, events are special for edit controls: - |#richedit - } - -function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl; -{* |<#control> - Like NewRichEdit, but to work with older RichEdit control version 1.0 - (window class 'RichEdit' forced to use instead of 'RichEdit20A', even - if library RICHED20.DLL found and loaded successfully). One more - difference - OleInit is not called, so the most of OLE capabilities - of RichEdit could not working. } -{$ENDIF NOT_USE_RICHEDIT} - -function NewListbox( AParent: PControl; Options: TListOptions ): PControl; -{* |<#control> - Creates list box control. Following properties, methods and events are - special for Listbox: - |#listbox } - -function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl; -{* |<#control> - Creates new combo box control. Note, that it is not possible to align - combobox caLeft or caRight: this can cause infinite recursion in the - application. - |
Following properties, methods and events are - special for Combobox: - |#combo } - -function _NewCommonControl( AParent: PControl; ClassName: PKOLChar; Style: DWORD; - Ctl3D: Boolean; Actions: TCommandActionsParam - ): PControl; - -function NewProgressbar( AParent: PControl ): PControl; -{* |<#control> - Creates progress bar control. Following properties are special for - progress bar: - |#progressbar - See also NewProgressEx. } - -function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl; -{* |<#control> - Can create progress bar with smooth style (progress is not segmented - onto bricks) or/and vertical progress bar - using additional parameter. - For list of properties, suitable for progress bars, see NewProgressbar. } - -function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions; - ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl; -{* |<#control> - Creates list view control. It is very powerful control, which can partially - compensate absence of grid controls (in lvsDetail view mode). Properties, - methods and events, special for list view control are: - |#listview } - -function NewTreeView( AParent: PControl; Options: TTreeViewOptions; - ImgListNormal, ImgListState: PImageList ): PControl; -{* |<#control> - Creates tree view control. See tree view methods and properties: - |#treeview } - -function NewTabControl( AParent: PControl; const Tabs: array of PKOLChar; Options: TTabControlOptions; - ImgList: PImageList; ImgList1stIdx: Integer ): PControl; -{* |<#control> - Creates new tab control (like notebook). To place child control on a certain - page of TabControl, use property Pages[ Idx ], for example: - ! Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' ); - |     - To determine number of pages at run time, use property ; - |
to determine which page is currently selected (or to change - selection), use property ; - |
to feedback to switch between tabs assign your handler to OnSelChange - event; - |
Note, that by default, tab control is created with a border lowered to - tab control's parent. To remove it, you can apply WS_EX_TRANSPARENT extended - style (see TControl.ExStyle property), but painting of some child controls - can be strange a bit in this case (no border drawing for edit controls was - found, but not always...). You can also apply style WS_THICKFRAME (TControl.Style - property) to make the border raised. - |
Other methods and properties, suitable for tab control, are: - |#tabcontrol } -{$IFNDEF OLD_ALIGN} -function NewTabEmpty( AParent: PControl; Options: TTabControlOptions; - ImgList: PImageList ): PControl; -{* |<#control> - Creates new empty tab control for using metods TC_Insert (to create Pages as Panel), - or TC_InsertControl (if you want using your custom Pages).} -{$ENDIF} - -var ToolbarDfltWidth: WORD = 1000; - ToolbarDfltHeight: WORD = 26; - -function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions; - Bitmap: HBitmap; const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer ) : PControl; -{* |<#control> - Creates toolbar control. Bitmap (if present) must contain images for all buttons - excluding separators (defined by string '-' in Buttons array) and system images, - otherwise last buttons will no have images at all. Image width for every button - is assumed to be equal to Bitmap height (if last of "squares" has - insufficient width, it will not be used). To define fixed buttons, use - characters '+' or '-' as a prefix for button string (even empty). To - create groups of (radio-)buttons, use also '!' follow '+' or '-'. (These rules - are similar used in menu creation). To define drop down button, use (as - first) prefix '^'. (Do not forget to set event for this - case). If You want to assign images to buttons not in the same order - how these are placed in Bitmap (or You use system bitmap), define for every - button (in BtnImgIdxArray array) indexes for every button (excluding - separator buttons). Otherwise, it is possible to define index only for first - button (e.g., [0]). It is also possible to change TBImages[ ] property - for such purpose, or do the same in method TBSetBtnImgIdx). - |
- Following properties, methods and event are specially designed to work with - toolbar control: - |#toolbar - |
    - If your project uses Align property to align controls, this can conflict with - toolbar native aligning. To solve such problem, place toolbar to parent panel, - which has its own Align property assigned to desired value. - |
- To create toolbar with buttons, drawn from top to bottom, instead from left - to right, combine caLeft / caRight in Align parameter and style tboWrapable - when create toolbar. To adjust width of vertically aligned toolbar, it is - possible to call ResizeParentLeft for it. E.g.: - - ! P0 := NewPanel( W, esRaised ) .SetSize( 30, 0 ) .SetAlign( caLeft ); - ! // ^^^^^^^^^^^^^^^^^ ////// - !TB := NewToolbar( P0, caLeft, [ tboNoDivider, tboWrapable ], DWORD(-1), - ! // ////// /////////// - ! [ ' ', ' ', ' ', '-', ' ', ' ' ], - ! [ STD_FILEOPEN ] ).ResizeParentRight; - !//Note, that caLeft is *must*, and tboWrapable style too. SetSize for - !//parent panel is not necessary, but only if ResizeParentRight is called - !//than for Toolbar. - |

- One more note: if You create toolbar without text labels (passing ' ' for - each button You add), include also option tboTextRight to fix incorrect - sizing of buttons under Windows9x. - |
- And, certainly, if you use image lists rather then bitmap, all written - above about Bitmap become absolutely incorrect. - } - -function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions ) - : PControl; -{* |<#control> - Creates date and time picker common control. -} - -{ -- Constructor for Image List objet -- } - -function NewImageList( AOwner: PControl ): PImageList; -{* Constructor of TImageList object. Unlike other non-visual objects, image list - can be parented by TControl object (but this does not *must*), and in that - case it is destroyed automatically when its parent control is destroyed. - Every control can have several TImageList objects, linked to a simple list. - But if any TImageList object is destroyed, all following ones are destroyed - too (at least, now I implemented it so). } - -{$ENDIF WIN_GDI} - -type - TTimerKind = ( tkReal, tkProcess, tkProfiler ); // only for UNIX! - PTimer = ^TTimer; -{ ---------------------------------------------------------------------- - TTimer object ------------------------------------------------------------------------ } - TTimer = object( TObj ) - {* Easy timer incapsulation object. It uses separate topmost window, - common for all timers in the application, to handle WM_TIMER message. - This allows using timers in non-windowed application (but anyway it - should contain message handling loop for a thread). - |
- Note: in UNIX, there are no special windows created, certainly. } - protected - fHandle : Integer; - fEnabled: Boolean; - fInterval: Integer; - fOnTimer: TOnEvent; - {$IFDEF LIN} - {$IFNDEF GTK} - {$IFNDEF QT} - fPrev, fNext: PTimer; // двусвязный список всех _активных_ таймеров - fTimeStart: clock_t; - fExpireNext: clock_t; - fExpireTotal: Int64; - fTimerHandled: Boolean; - fResolution: Integer; - fPeriodic: Boolean; - fMultimedia: Boolean; - {$ENDIF QT} - {$ENDIF GTK} - {$ENDIF} - procedure SetEnabled(const Value: Boolean); {$IFDEF WIN} virtual; {$ENDIF} - procedure SetInterval(const Value: Integer); - protected - destructor Destroy; virtual; - {* Destructor. } - public - property Handle : Integer read fHandle; - {* Windows timer object handle. } - property Enabled : Boolean read fEnabled write SetEnabled; - {* True, is timer is on. Initially, always False. } - property Interval : Integer read fInterval write SetInterval; - {* Interval in milliseconds (1000 is default and means 1 second). - Note: in UNIX, if an Interval can be set to a value large then 30 minutes, - add a conditional definition SUPPORT_LONG_TIMER to the project options. } - property OnTimer : TOnEvent read fOnTimer write fOnTimer; - {* Event, which is called when time interval is over. } - {$IFDEF LIN} - {$IFNDEF GTK} - {$IFNDEF QT} - property Resolution: Integer read fResolution write fResolution; // dummy property, just for compatibility - property Periodic: Boolean read fPeriodic write fPeriodic; - {$ENDIF QT} - {$ENDIF GTK} - {$ENDIF LIN} - end; - -function NewTimer( Interval: Integer ): PTimer; -{* Constructs initially disabled timer with interval 1000 (1 second). } - -{$IFDEF WIN} -type - PMMTimer = ^TMMTimer; - - TMMTimer = object( TTimer ) - {* Multimedia timer incapsulation object. Does not require Applet or special - window to handle it. System creates a thread for each high resolution - timer, so using many such objects can degrade total PC performance. } - protected - FResolution: Integer; - FPeriodic: Boolean; - procedure SetEnabled(const Value: Boolean); virtual; - public - destructor Destroy; virtual; - {* } - property Resolution: Integer read FResolution write FResolution; - {* Minimum timer resolution. The less the more accuracy (0 is exactly - Interval milliseconds between timer shots). It is recommended to set - this property greater to prevent entire system from reducing overhead. - If you change this value, reset and then set Enabled again to apply - changes. } - property Periodic: Boolean read FPeriodic write FPeriodic; - {* TRUE, if timer is periodic (default). Otherwise, timer is one-shot - (set it Enabled every time in such case for each shot). If you change - this property, reset and set Enabled property again to get effect. } - end; - -function NewMMTimer( Interval: Integer ): PMMTimer; -{* Creates multimedia timer object. Initially, it has Resolution = 0, - Periodic = TRUE and Enabled = FALSE. Do not forget also to assign your - event handler to OnTimer to do something on timer shot. } -{$ENDIF WIN} - -{$IFDEF LIN} -function NewMMTimer( Interval: Integer ): PTimer; -{$ENDIF LIN} - -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -{ -- TTrayIcon object -- } - -type - TOnTrayIconMouse = procedure( Sender: PObj; Message : Word ) of object; - {* Event type to be called when Applet receives a message from an icon, - added to the taskbar tray. } - - PTrayIcon = ^TTrayIcon; -{ ---------------------------------------------------------------------- - TTrayIcon - icon in tray area of taskbar ------------------------------------------------------------------------ } - TTrayIcon = object(TObj) - {* Object to place (and change) a single icon onto taskbar tray. } - protected - FIcon: HIcon; - FActive: Boolean; - FTooltip: KOLString; - FOnMouse: TOnTrayIconMouse; - FControl: PControl; - fAutoRecreate: Boolean; - FNoAutoDeactivate: Boolean; - FWnd: HWnd; - procedure SetIcon(const Value: HIcon); - procedure SetActive(const Value: Boolean); - procedure SetTrayIcon( const Value : DWORD ); - procedure SetTooltip(const Value: KOLString); - procedure SetAutoRecreate(const Value: Boolean); - protected - destructor Destroy; virtual; - {* Destructor. Use Free method instead (as usual). } - public - property Icon : HIcon read FIcon write SetIcon; - {* Icon to be shown on taskbar tray. If not set, value of Active - property has no effect. It is also possible to assign a value - to Icon property after assigning True to Active to install - icon first time or to replace icon with another one (e.g. to - get animation effect). - |
    - Previously allocated icon (if any) is not deleted using - DeleteObject. This is normal for icons, loaded from resource - (e.g., by LoadIcon API call). But if icon was created (e.g.) by - CreateIconIndirect, your code is responsible for destroying - of it). } - property Active : Boolean read FActive write SetActive; - {* Set it to True to show assigned Icon on taskbar tray. Default - is False. Has no effect if Icon property is not assigned. - TrayIcon is deactivated automatically when Applet is finishing - (but only if Applet window is used as a "parent" for tray - icon object). } - property Tooltip : KOLString read FTooltip write SetTooltip; - {* Tooltip string, showing automatically when mouse is moving - over installed icon. Though "huge string" type is used, only - first 63 characters are considered. Also note, that only in - most recent versions of Windows multiline tooltips are supported. } - property OnMouse : TOnTrayIconMouse read FOnMouse write FOnMouse; - {* Is called then mouse message is taking place concerning installed - icon. Only type of message can be obtained (e.g. WM_MOUSEMOVE, - WM_LBUTTONDOWN etc.) } - property AutoRecreate: Boolean read fAutoRecreate write SetAutoRecreate; - {* If set to TRUE, auto-recreating of tray icon is proveded in case, - when Explorer is restarted for some (unpredictable) reasons. Otherwise, - your tray icon is disappeared forever, and if this is the single way - to communicate with your application, the user nomore can achieve it. } - property NoAutoDeactivate: Boolean read FNoAutoDeactivate write FNoAutoDeactivate; - {* If set to true, tray icon is not removed from tray automatically on - WM_CLOSE message receive by owner control. Set Active := FALSE in - your code for such case before accepting closing the form. } - property Wnd: HWnd read FWnd write FWnd; - {* A window to use as a base window for tray icon messages. Overrides - parent Control handle is assigned. Note, that if Wnd property used, - message handling is not done automatically, and you should do this in - your code, or at least for one tray icon object, call AttachProc2Wnd. } - procedure AttachProc2Wnd; - {* Call this method for a tray icon object in case if Wnd used rather then - control. It is enough to call this method once for each Wnd used, even - if several other tray icons are also based on the same Wnd. See also - DetachProc2Wnd method. } - procedure DetachProc2Wnd; - {* Call this method to detach window procedure attached via AttachProc2Wnd. - Do it once for a Wnd, used as a base to handle tray icon messages. - Caution! If you do not call this method before destroying Wnd, the - application will not functioning normally. } - end; - {* When You create invisible application, which should be represented by - only the tray icon, prepare a handle for the window, resposible for - messages handling. Remember, that window handle is created automatically - only when a window is showing first time. If window's property Visible is - set to False, You should to call CreateWindow manually. -
- There is a known bug exist with similar invisible tray-iconized applications. - When a menu is activated in response to tray mouse event, if there was - not active window, belonging to the application, the menu is not disappeared - when mouse is clicked anywhere else. This bug is occure in Windows9x/ME. - To avoid it, activate first your form window. This last window shoud have - status visible (but, certainly, there are no needs to place it on visible - part of screen - change its position, so it will not be visible for user, - if You wish). -
- Also, to make your application "invisible" but until special event is occure, - use Applet separate from the main form, and make for both Visible := False. - This allows for You to make your form visible any time You wish, and without - making application button visible if You do not wish. - } - {= Когда Вы делаете невидимое приложение, которое должно быть представлено - только иконкой в трее, обеспечьте ненулевой Handle для окна, отвечающего - за обработку сообщений. Помните, что Handle окна создается автоматически - только в тот момент, когда оно должно появиться в первый раз. Если свойство - окна Visible установлено в FALSE, необходимо вызвать CreateWindow самостоятельно. -
- Существует известный BUG с подобными невидимыми минимизированными в трей - приложениями. Когда в ответ на событие мыши активизирвано выпадающее меню, - оно не исчезает по щелчку мыши вне этого меню. Происходит это в Windows9x/ME. - чтобы решить эту проблему, сначала активизируйте свое окно (форму). Это окно - должно быть видимым (но, конечно, его можно разместить вне пределов видимой - части экрана, так что пользователю его видно не будет). -
- Так же, чтобы сделать приложение невидимым, по крайней мере, пока это не - потребуется, используйте отдельный представитель класса TControl - глобальную - переменную Applet, и присвойте FALSE ее свойству Visible. - } - -function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon; -{* Constructor of TTrayIcon object. Pass main form or applet as Wnd - parameter. } - -{ -- JustOne -- } - -type - TOnAnotherInstance = procedure( const CmdLine: KOLString ) of object; - {* Event type to use in JustOneNotify function. } - -function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean; -{* Returns True, if this is a first instance. For all other instances - (application is already running), False is returned. } - -function JustOneNotify( Wnd: PControl; const Identifier : KOLString; - const aOnAnotherInstance: TOnAnotherInstance ) : Boolean; -{* Returns True, if this is a first instance. For all other instances - (application is already running), False is returned. If handler - aOnAnotherInstance passed, it is called (in first instance) every time - when another instance of an application is started, receiving command - line used to run it. } - -{ -- string (mainly) utility procedures and functions. -- } - -{$IFDEF GDI} -function MsgBox( const S: KOLString; Flags: DWORD ): DWORD; -{* Displays message box with the same title as Applet.Caption. If applet - is not running, and Applet global variable is not assigned, caption - 'Error' is displayed (but actually this is not an error - the system - does so, if nil is passed as a title). - |
    - Returns ID_... result (correspondently to flags passed (MB_OK, MBYESNO, - etc. -> ID_OK, ID_YES, ID_NO, etc.) } -procedure MsgOK( const S: KOLString ); -{* Displays message box with the same title as Applet.Caption (or 'Error', - if Applet is not running). } -function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD; -{* Displays message box like MsgBox, but uses Applet.Handle as a parent - (so the message has no button on a task bar). } -procedure ShowMessage( const S: KOLString ); -{* Like ShowMsg, but has only styles MB_OK and MB_SETFOREGROUND. } -{$ENDIF GDI} -{$IFDEF WIN} -{$IFNDEF PAS_ONLY} -procedure SpeakerBeep( Freq: Word; Duration: DWORD ); -{* On Windows NT, calls Windows.Beep. On Windows 9x, produces beep on speaker - of desired frequency during given duration time (in milliseconds). } -{$ENDIF PAS_ONLY} -{$ENDIF WIN} - -function SysErrorMessage(ErrorCode: Integer): KOLString; -{* Creates and returns a string containing formatted system error message. - It is possible then to display this message or write it to a log - file, e.g.: - ! ShowMsg( SysErrorMessage( GetLastError ) ); - - |&R=

%0

 - -} -{$ENDIF WIN_GDI} -type - I64 = record - {* 64 bit integer record. Use it and correspondent functions below in KOL - projects to avoid dependancy from Delphi version (earlier versions of - Delphi had no Int64 type). } - Lo, Hi: DWORD; - end; - PI64 = ^I64; - {* } - -{$IFNDEF _D4orHigher} - Int64 = I64; - PInt64 = PI64; -{$ENDIF} - -function MakeInt64( Lo, Hi: DWORD ): I64; -{* } -{$IFNDEF PAS_ONLY} -function Int2Int64( X: Integer ): I64; -{* } -procedure IncInt64( var I64: I64; Delta: Integer ); -{* I64 := I64 + Delta; } -procedure DecInt64( var I64: I64; Delta: Integer ); -{* I64 := I64 - Delta; } -function Add64( const X, Y: I64 ): I64; -{* Result := X + Y; } -function Sub64( const X, Y: I64 ): I64; -{* Result := X - Y; } -function Neg64( const X: I64 ): I64; -{* Result := -X; } -function Mul64i( const X: I64; Mul: Integer ): I64; -{* Result := X * Mul; } -function Div64i( const X: I64; D: Integer ): I64; -{* Result := X div D; } -function Mod64i( const X: I64; D: Integer ): Integer; -{* Result := X mod D; } -function Sgn64( const X: I64 ): Integer; -{* Result := sign( X ); i.e.: - |
- if X < 0 then -1 - |
- if X = 0 then 0 - |
- if X > 0 then 1 } -function Cmp64( const X, Y: I64 ): Integer; -{* Result := sign( X - Y ); i.e. - |
- if X < Y then -1 - |
- if X = Y then 0 - |
- if X > Y then 1 } -function Int64_2Str( X: I64 ): AnsiString; -{* } -function Int64_2Hex( X: I64; MinDigits: Integer ): KOLString; -{* } -function Str2Int64( const S: AnsiString ): I64; -{* } -function Int64_2Double( const X: I64 ): Double; -{* } -function Double2Int64( D: Double ): I64; -{$ENDIF PAS_ONLY} -{* - - -} - -const - NAN = 0.0 / 0.0; - Infinity = 1.0 / 0.0; - -function IsNan(const AValue: Double): Boolean; -{* Checks if an argument passed is NAN. } -function IsInfinity(const AValue: Double): Boolean; -{* Checks if an argument passed is Infinite. } -function IntPower(Base: Extended; Exponent: Integer): Extended; -{* Result := Base ^ Exponent; } -function NextPowerOf2( n: DWORD ): DWORD; -{* 0->1, 1->1, 2->2, 3->4, 4->4, 5->8, ... } -function Str2Double( const S: KOLString ): Double; -{* } -function Str2Extended( const S: KOLString ): Extended; -{* } -function Double2Str( D: Double ): KOLString; -{* } -function Extended2Str( E: Extended ): KOLString; -{* } -function Extended2StrDigits( D: Double; n: Integer ): KOLString; -{* Converts floating point number to string, leaving exactly n digits - following floating point. } -function Double2StrEx( D: Double ): KOLString; -{* experimental, do not use } -{$IFNDEF PAS_ONLY} -function TruncD( D: Double ): Double; -{$ENDIF} -{* Result := trunc( D ) as Double; -|
- - - See also TBits object. -} - -function IfThenElseBool( t, e, Cond: Boolean ): Boolean; -function IfThenElseInt( t, e: Integer; Cond: Boolean ): Integer; -function IfThenElseStr( const t, e: AnsiString; Cond: Boolean ): AnsiString; -{$IFDEF _D5orHigher} -function IfThenElse( t, e: Boolean; Cond: Boolean ): Boolean; overload; -function IfThenElse( t, e: Integer; Cond: Boolean ): Integer; overload; -function IfThenElse( t, e: AnsiString; Cond: Boolean ): AnsiString; overload; -function IfThenElse( t, e: Double; Cond: Boolean ): Double; overload; -{$ENDIF} - -function GetBits( N: DWORD; first, last: Byte ): DWord; -{* Retuns bits straing from and to inclusively. } -function GetBitsL( N: DWORD; from, len: Byte ): DWord; -{* Retuns len bits starting from index . -|
- - - - See also units KolMath.pas, CplxMath.pas and Err.pas. -} -//[MulDiv DECLARATION] -{$IFNDEF FPC} -function MulDiv( A, B, C: Integer ): Integer; -{* Returns A * B div C. Small and fast. } -{$ENDIF} - - function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; stdcall; - {* Use it instead of VCL Rect function } - function RectsEqual( const R1, R2: TRect ): Boolean; - {* Returns True if rectangles R1 and R2 have the same bounds } - function RectsIntersected( const R1, R2: TRect ): Boolean; - {* Returns TRUE if rectangles R1 and R2 have at least one common point. - Note, that right and bottom bounds of rectangles are not their part, - so, if such points are lying on that bounds, FALSE is returned. } - function PointInRect( const P: TPoint; const R: TRect ): Boolean; - {* Returns True if point P is located in rectangle R (including - left and top bounds but without right and bottom bounds of the - rectangle). } - function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint; - {* } - function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint; - {* } - function Point2SmallPoint( const T: TPoint ): TSmallPoint; - {* } - function SmallPoint2Point( const T: TSmallPoint ): TPoint; - {* } - function MakePoint( X, Y: Integer ): TPoint; - {* Use instead of VCL function Point } - function MakeSmallPoint( X, Y: Integer ): TSmallPoint; - {* Use to construct TSmallPoint } - function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer; - {* } - function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange; - {* Returns TDateTimeRange from two TDateTime bounds. } - procedure Swap( var X, Y: Integer ); - {* exchanging values } - function Min( X, Y: Integer ): Integer; - {* minimum of two integers } - function Max( X, Y: Integer ): Integer; - {* maximum of two integers } -{$IFDEF REDEFINE_ABS} - function Abs( X: Integer ): Integer; - {* absolute value } -{$ENDIF} - function Sgn( X: Integer ): Integer; - {* sign of X: if X < 0, -1 is returned, if > 0, then +1, otherwise 0. } - function iSqrt( X: Integer ): Integer; - {* square root } - function iCbrt( X: DWORD ): Integer; - {* cubic root - |
- -} -function Int2Hex( Value : DWord; Digits : Integer ) : KOLString; -{* Converts integer Value into string with hex number. Digits parameter - determines minimal number of digits (will be completed by adding - necessary number of leading zeroes). } -function Int2Str( Value : Integer ) : KOLString; -{* Obvious. } -procedure Int2PChar( s: PAnsiChar; Value: Integer ); -{* Converts Value to string and puts it into buffer s. Buffer must have - enough size to store the number converted: buffer overflow does - not checked anyway! } -function UInt2Str( Value: DWORD ): AnsiString; -{* The same as Int2Str, but for unsigned integer value. } -function Int2StrEx( Value, MinWidth: Integer ): KOLString; -{* Like Int2Str, but resulting string filled with leading spaces to provide - at least MinWidth characters. } -function Int2Rome( Value: Integer ): KOLString; -{* Represents number 1..8999 to Rome numer. } -function Int2Ths( I: Integer ): KOLString; -{* Converts integer into string, separating every three digits from each - other by character ThsSeparator. (Convert to thousands). You } -function Int2Digs( Value, Digits: Integer ): KOLString; -{* Converts integer to string, inserting necessary number of leading zeroes - to provide desired length of string, given by Digits parameter. If - resulting string is greater then Digits, string is not truncated anyway. } -function Num2Bytes( Value : Double ) : KOLString; -{* Converts double float to string, considering it as a bytes count. - If Value is sufficiently large, number is represented in kilobytes (with - following letter K), or in megabytes (M), gigabytes (G) or terabytes (T). - Resulting string number is truncated to two decimals (.XX) or to one (.X), - if the second is 0. } -function S2Int( S: PKOLChar ): Integer; -{* Converts null-terminated string to Integer. Scanning stopped when any - non-digit character found. Even empty string or string not containing - valid integer number silently converted to 0. } -function Str2Int(const Value : KOLString) : Integer; -{* Converts string to integer. First character, which can not be - recognized as a part of number, regards as a separator. Even - empty string or string without number silently converted to 0. } -function Hex2Int( const Value : KOLString) : Integer; -{* Converts hexadecimal number to integer. Scanning is stopped - when first non-hexadicimal character is found. Leading dollar ('$') - character is skept (if present). Minus ('-') is not concerning as - a sign of number and also stops scanning.} -function cHex2Int( const Value : KOLString) : Integer; -{* As Hex2Int, but also checks for leading '0x' and skips it. } -function Octal2Int( const Value: AnsiString ) : Integer; -{* Converts octal number to integer. Scanning is stopped on first - non-octal digit (any char except 0..7). There are no checking if - there octal numer in the parameter. If the first char is not octal - digit, 0 is returned. } -function Binary2Int( const Value: AnsiString ) : Integer; -{* Converts binary number to integer. Like Octal2Int, but only digits - 0 and 1 are allowed. } -type Radix_int = {$IFDEF _D5orHigher} Int64 {$ELSE} Integer {$ENDIF}; -function ToRadix( number: Radix_int; radix, min_digits: Integer ): KOLString; -{* Converts unsigned number to string representing it literally in a numeric - base given by radix parameter. } -function FromRadixStr( var Rslt: Radix_int; s: PKOLChar; radix: Integer ): PKOLChar; -{* Converts unsigned number from string representation in a numeric base given by - a radix parameter. Returns a pointer to a character next to the last digit of - the number. } -function FromRadix( const s: AnsiString; radix: Integer ): Radix_int; -{* Converts unsigned number from string representation in a numeric base given by - a radix parameter. See also: FromRadixStr function. } -function InsertSeparators( const s: KOLString; chars_between: Integer; - Separator: KOLChar ): KOLString; -{* Inserts given Separator between symbols in s, separating each portion of - chars_between characters with a Separator starting from right side. See also: - Int2Ths function. } -{$IFDEF WIN} -{$IFNDEF _FPC} -//{$IFNDEF PAS_ONLY} -function Format( const fmt: KOLString; params: array of const ): KOLString; -//{$ENDIF} -{* Uses API call to wvsprintf, so does not understand extra formats, - such as floating point, date/time, currency conversions. See list of - available formats in win32.hlp (topic wsprintf). -|
- - -} -{$ENDIF _FPC} -{$ENDIF WIN} -function StrComp(const Str1, Str2: PAnsiChar): Integer; -{* Compares two strings fast. -1: Str1Str2 } - -{$IFDEF PAS_ONLY} -function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; -function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -{$ELSE} -{$IFDEF SMALLER_CODE} -function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; -{* Compares two strings fast without case sensitivity. - Returns: -1 when Str1Str2 } -function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -{* Compare two strings fast without case sensitivity. - Terminating 0 is not considered, so if strings are equal, - comparing is continued up to MaxLen bytes. - Since this, pass minimum of lengths as MaxLen. } -{$ELSE} -function StrComp_NoCase1(const Str1, Str2: PAnsiChar): Integer; -var StrComp_NoCase: function(const Str1, Str2: PAnsiChar): Integer = StrComp_NoCase1; -{* Compares two strings fast without case sensitivity. - Returns: -1 when Str1Str2 } -function StrLComp_NoCase1(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -var StrLComp_NoCase: function(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer = StrLComp_NoCase1; -{$ENDIF} -{$ENDIF} - -function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -{* Compare two strings (fast). Terminating 0 is not considered, so if - strings are equal, comparing is continued up to MaxLen bytes. - Since this, pass minimum of lengths as MaxLen. } - -function StrCopy( Dest, Source: PAnsiChar ): PAnsiChar; -{* Copy source string to destination (fast). Pointer to Dest is returned. } -function StrCat( Dest, Source: PAnsiChar ): PAnsiChar; -{* Append source string to destination (fast). Pointer to Dest is returned. } -function StrLen(const Str: PAnsiChar): Cardinal; -{* StrLen returns the number of characters in Str, not counting the null - terminator. } -function StrScanLen(Str: PAnsiChar; Chr: AnsiChar; Len: Integer): PAnsiChar; -{* Fast scans string Str of length Len searching character Chr. - Pointer to a character next to found or to Str[Len] (if no one found) - is returned. } -function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; -{* Fast search of given character in a string. Pointer to found character - (or nil) is returned. } -function StrRScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; -{* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr - does not occur in Str, StrRScan returns NIL. The null terminator is - considered to be part of the string. } -function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean; -{* Returns True, if string Str is starting from Pattern, i.e. if - Copy( Str, 1, StrLen( Pattern ) ) = Pattern. Str must not be nil! } -function StrIsStartingFromNoCase( Str, Pattern: PAnsiChar ): Boolean; -{* Like StrIsStartingFrom above, but without case sensitivity. } -function TrimLeft(const S: KOLString): KOLString; -{* Removes spaces, tabulations and control characters from the starting - of string S. } -function TrimRight(const S: KOLString): KOLString; -{* Removes spaces, tabulates and other control characters from the - end of string S. } -function Trim( const S : KOLString): KOLString; -{* Makes TrimLeft and TrimRight for given string. } -function RemoveSpaces( const S: KOLString ): KOLString; -{* Removes all characters less or equal to ' ' in S and returns it. } -procedure Str2LowerCase( S: PAnsiChar ); -{* Converts null-terminated string to lowercase (inplace). } -function LowerCase(const S: Ansistring): Ansistring; -{* Obvious. } -function UpperCase(const S: Ansistring): Ansistring; -{* Obvious. } -function AnsiUpperCase(const S: Ansistring): Ansistring; -{* Obvious. } -function AnsiLowerCase(const S: Ansistring): Ansistring; -{* Obvious. } -function KOLUpperCase(const S: KOLString): KOLString; -{* Obvious. } -function KOLLowerCase(const S: KOLString): KOLString; -{* Obvious. } -{$IFDEF _D3orHigher} -function WUpperCase(const S: KOLWideString): KOLWideString; -{* Obvious. } -function WLowerCase(const S: KOLWideString): KOLWideString; -{* Obvious. } -{$ENDIF} -{$IFNDEF _D2} -{$IFNDEF _FPC} -function WAnsiUpperCase(const S: KOLWideString): KOLWideString; -{* Obvious. } -function WAnsiLowerCase(const S: KOLWideString): KOLWideString; -{* Obvious. } -function WStrComp(const S1, S2: KOLWideString): Integer; -{* } -function _WStrComp(S1, S2: PWideChar): Integer; -{* } -function _WStrLComp(S1, S2: PWideChar; Len: Integer): Integer; -{* } -function WStrScan(Str: PWideChar; Chr: WideChar): PWideChar; -{* Fast search of given character in a string. Pointer to found character - (or nil) is returned. } -function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; -{* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr - does not occur in Str, StrRScan returns NIL. The null terminator is - considered to be part of the string. } -{$ENDIF _FPC} -{$ENDIF _D2} -//--- set of functions to work either with AnsiString or with KOLWideString -// depending on UNICODE_CTRLS symbol ---------------------------------------- -function AnsiCompareStr(const S1, S2: KOLString): Integer; -{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare - operation is controlled by the current Windows locale. The return value - is the same as for CompareStr. } -function _AnsiCompareStr(S1, S2: PKOLChar): Integer; -{* The same, but for PChar ANSI strings } -function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer; -{* AnsiCompareStrNoCase compares S1 to S2, without case-sensitivity. The compare - operation is controlled by the current Windows locale. The return value - is the same as for CompareStr. } -function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer; -{* The same, but for PChar ANSI strings } -function AnsiCompareText( const S1, S2: KOLString ): Integer; -{* } -function AnsiEq( const S1, S2 : KOLString ) : Boolean; -{* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI - stringsare equal to each other without caring of characters case - sensitivity. } - -//--- set of functions to work always with AnsiString -// even if UNICODE_CTRLS symbol is defined ---------------------------------- -function AnsiCompareStrA(const S1, S2: AnsiString): Integer; -{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare - operation is controlled by the current Windows locale. The return value - is the same as for CompareStr. } -function _AnsiCompareStrA_Slow(S1, S2: PAnsiChar): Integer; -function _AnsiCompareStrA_Fast(S1, S2: PAnsiChar): Integer; -var _AnsiCompareStrA: function(S1, S2: PAnsiChar): Integer = - {$IFDEF SPEED_FASTER} _AnsiCompareStrA_Fast - {$ELSE} _AnsiCompareStrA_Slow {$ENDIF}; -{* The same, but for PChar ANSI strings } -function _AnsiCompareStrA_Fast2(S1, S2: PAnsiChar): Integer; -function _AnsiCompareStrNoCaseA_Fast2(S1, S2: PAnsiChar): Integer; -function AnsiCompareStrNoCaseA(const S1, S2: AnsiString): Integer; -{* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare - operation is controlled by the current Windows locale. The return value - is the same as for CompareStr. } -function _AnsiCompareStrNoCaseA_Slow(S1, S2: PAnsiChar): Integer; -function _AnsiCompareStrNoCaseA_Fast(S1, S2: PAnsiChar): Integer; -var _AnsiCompareStrNoCaseA: function(S1, S2: PAnsiChar): Integer = - {$IFDEF SPEED_FASTER} _AnsiCompareStrNoCaseA_Fast - {$ELSE} _AnsiCompareStrNoCaseA_Slow {$ENDIF}; -{* The same, but for PChar ANSI strings } -function AnsiCompareTextA( const S1, S2: AnsiString ): Integer; -{* } - -{$IFDEF WIN} -{$IFNDEF _FPC} -function LStrFromPWCharLen(Source: PWideChar; Length: Integer): AnsiString; -{* from Delphi5 - because D2 does not contain it. } -function LStrFromPWChar(Source: PWideChar): AnsiString; -{* from Delphi5 - because D2 does not contain it. } -{$ENDIF _FPC} -function WCharIn( C: KOLChar; const Chars: array of KOLChar ): Boolean; -{$ENDIF WIN} - -function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString; -{* Returns copy of source string S starting from Idx up to the end of - string S. Works correctly for case, when Idx > Length( S ) (returns - empty string for such case). } -function CopyTail( const S : KOLString; Len : Integer ) : KOLString; -{* Returns last Len characters of the source string. If Len > Length( S ), - entire string S is returned. } -procedure DeleteTail( var S : KOLString; Len : Integer ); -{* Deletes last Len characters from string. } -function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer; -{* Returns index of given character (1..Length(S)), or - -1 if a character not found. } -function IndexOfCharsMin( const S, Chars : KOLString ) : Integer; -{* Returns index (in string S) of those character, what is taking place - in Chars string and located nearest to start of S. If no such - characters in string S found, -1 is returned. } -{$IFDEF _D3orHigher} -function WIndexOfChar( const S : KOLWideString; Chr : WideChar ) : Integer; -function WIndexOfCharsMin( const S, Chars : KOLWideString ) : Integer; -{$ENDIF} -{$IFNDEF _D2} -{$IFNDEF _FPC} -function IndexOfWideCharsMin( const S, Chars : KOLWideString ) : Integer; -{* Returns index (in wide string S) of those wide character, what - is taking place in Chars wide string and located nearest to start of S. - If no such characters in string S found, -1 is returned. } -{$ENDIF _FPC} -{$ENDIF _D2} - -function IndexOfStr( const S, Sub : KOLString ) : Integer; -{* Returns index of given substring in source string S. If found, - 1..Length(S)-Length(Sub), if not found, -1. } -function Parse( var S : KOLString; const Separators : KOLString ) : KOLString; -{* Returns first characters of string S, separated from others by - one of characters, taking place in Separators string, assigning - a tail of string (after found separator) to source string. If - no separator characters found, source string S is returned, and - source string itself becomes empty. } -{$IFDEF _D3orHigher} -function ParseW( var S : KOLWideString; const Separators : KOLWideString ) : KOLWideString; -{$ENDIF} - -{$IFNDEF _FPC} -{$IFNDEF _D2} -function WParse( var S : KOLWideString; const Separators : KOLWideString ) : KOLWideString; -{* Returns first wide characters of wide string S, separated from others - by one of wide characters, taking place in Separators wide string, - assigning a tail of wide string (following found separator) to the - source one. If there are no separator characters found, source wide - string S is returned, and source wide string itself becomes empty. } -{$ENDIF _D2} -{$ENDIF _FPC} -function ParsePascalString( var S : KOLString; const Separators : KOLString ) : KOLString; -{* Returns first characters of string S, separated from others by - one of characters, taking place in Separators string, assigning - a tail of string (after the found separator) to source string. If - there are no separator characters found, the source string S is returned, - and the source string itself becomes empty. Additionally: if the first (after - a blank space) is the quote "'" or '#', pascal string is assumung first - and is converted to usual string (without quotas) before analizing - of other separators. } -function String2PascalStrExpr( const S : KOLString ) : KOLString; -{* Converts string to Pascal-like string expression (concatenation of - strings with quotas and characters with leading '#'). } -function StrEq( const S1, S2 : AnsiString ) : Boolean; -{* Returns True, if LowerCase(S1) = LowerCase(S2). I.e., if strings - are equal to each other without caring of characters case sensitivity - (ASCII only). } -{$IFNDEF _D2} -{$IFNDEF _FPC} -function WAnsiEq( const S1, S2 : KOLWideString ) : Boolean; -{* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI - stringsare equal to each other without caring of characters case - sensitivity. } -{$ENDIF _FPC} -{$ENDIF _D2} - -function StrIn( const S : AnsiString; const A : array of AnsiString ) : Boolean; -{* Returns True, if S is "equal" to one of strings, taking place - in A array. To check equality, StrEq function is used, i.e. - comaprison is taking place without case sensitivity. } -{$IFNDEF _FPC} -type TSetOfChar = Set of AnsiChar; -{$IFNDEF _D2} -function WStrIn( const S : KOLWideString; const A : array of KOLWideString ) : Boolean; -{* Returns True, if S is "equal" to one of strings, taking place - in A array. To check equality, WAnsiEq function is used, i.e. - comaprison is taking place without case sensitivity. } -function CharIn( C: KOLChar; const A: TSetOfChar ): Boolean; -{* To replace expressions like S[1] in [ '0'..'z' ] to CharIn( S[ 1 ], [ '0'..'z' ] ) - (and to avoid problems with Unicode version of code). } -{$ENDIF _D2} -{$ENDIF _FPC} -function StrIs( const S : AnsiString; const A : Array of AnsiString; var Idx: Integer ) : Boolean; -{* Returns True, if S is "equal" to one of strings, taking place - in A array, and in such Case Idx also is assigned to an index of A element - equal to S. To check equality, StrEq function is used, i.e. - comaprison is taking place without case sensitivity. } -function IntIn( Value: Integer; const List: array of Integer ): Boolean; -{* Returns TRUE, if Value is found in a List. } -function _StrSatisfy( S, Mask : PKOLChar ) : Boolean; -{* } -function _2StrSatisfy( S, Mask: PKOLChar ): Boolean; -{* } -function StrSatisfy( const S, Mask : KOLString ) : Boolean; -{* Returns True, if S is satisfying to a given Mask (which can contain - wildcard symbols '*' and '?' interpeted correspondently as 'any - set of characters' and 'single any character'. If there are no - such wildcard symbols in a Mask, result is True only if S is maching - to Mask string.) } -function StrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean; -{* Replaces first occurance of From to ReplTo in S, returns True, - if pattern From was found and replaced. } -function KOLStrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean; -{* Replaces first occurance of From to ReplTo in S, returns True, - if pattern From was found and replaced. } -{$IFNDEF _FPC} -{$IFNDEF _D2} -function WStrReplace( var S: KOLWideString; const From, ReplTo: KOLWideString ): Boolean; -{* Replaces first occurance of From to ReplTo in S, returns True, - if pattern From was found and replaced. See also function StrReplace. - This function is not available in Delphi2 (this version of Delphi - does not support KOLWideString type). } -{$ENDIF _D2} -{$ENDIF _FPC} - -function StrRepeat( const S: KOLString; Count: Integer ): KOLString; -{* Repeats given string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. } -{$IFNDEF _FPC} -{$IFNDEF _D2} -function WStrRepeat( const S: KOLWideString; Count: Integer ): KOLWideString; -{* Repeats given wide string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. } -{$ENDIF _D2} -{$ENDIF _FPC} - -procedure NormalizeUnixText( var S: AnsiString ); -{* In the string S, replaces all occurances of character #10 (without leading #13) - to the character #13. } -procedure Koi8ToAnsi( s: PAnsiChar ); -{* Converts Koi8 text to Ansi (in place) } -const KOI8_Rus: array[ #$C0..#$FF ] of AnsiChar = ( - { 'ю', - 'а', 'б', 'ц', 'д', 'е', 'ф', 'г', 'х', 'и', 'й', 'к', 'л', 'м', 'н', 'о', 'п', - 'я', 'р', 'с', 'т', 'у', 'ж', 'в', 'ь', 'ы', 'з', 'ш', 'э', 'щ', 'ч', 'ъ', - 'Ю', - 'А', 'Б', 'Ц', 'Д', 'Е', 'Ф', 'Г', 'Х', 'И', 'Й', 'К', 'Л', 'М', 'Н', 'О', 'П', - 'Я', 'Р', 'С', 'Т', 'У', 'Ж', 'В', 'Ь', 'Ы', 'З', 'Ш', 'Э', 'Щ', 'Ч', 'Ъ'} - #$FE, - #$E0, #$E1, #$F6, #$E4, #$E5, #$F4, #$E3, #$F5, #$E8, #$E9, #$EA, #$EB, #$EC, #$ED, #$EE, #$EF, - #$FF, #$F0, #$F1, #$F2, #$F3, #$E6, #$E2, #$FC, #$FB, #$E7, #$F8, #$FD, #$F9, #$F7, #$FA, - #$DE, - #$C0, #$C1, #$D6, #$C4, #$C5, #$D4, #$C3, #$D5, #$C8, #$C9, #$CA, #$CB, #$CC, #$CD, #$CE, #$CF, - #$DF, #$D0, #$D1, #$D2, #$D3, #$C6, #$C2, #$DC, #$DB, #$C7, #$D8, #$DD, #$D9, #$D7, #$DA - ); - -function StrPCopy(Dest: PAnsiChar; const Source: Ansistring): PAnsiChar; -{* Copyes string into null-terminated. } -function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; -{* Copyes first MaxLen characters of the Source string into null-terminated Dest. } - -function DelimiterLast( const Str, Delimiters: KOLString ): Integer; -{* Returns index of the last of delimiters given by same named parameter - among characters of Str. If there are no delimiters found, length of - Str is returned. This function is intended mainly to use in filename - parsing functions. } -function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar; -{* Returns address of the last of delimiters given by Delimiters parameter - among characters of Str. If there are no delimeters found, position of - the null terminator in Str is returned. This function is intended - mainly to use in filename parsing functions. } -{$IFDEF _D3orHigher} -function W__DelimiterLast( Str, Delimiters: PWideChar ): PWideChar; -{* } -{$ENDIF _D3orHigher} -function SkipSpaces( P: PKOLChar ): PKOLChar; -{* Skips all characters #1..' ' in a string. -} -{$IFDEF F_P} -function DummyStrFun( const S: AnsiString ): AnsiString; -{$ENDIF} - -function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; -{* Fast compare of two memory blocks. } -function AllocMem( Size : Integer ) : Pointer; -{* Allocates global memory and unlocks it. } -procedure DisposeMem( var Addr : Pointer ); -{* Locks global memory block given by pointer, and frees it. - Does nothing, if the pointer is nil. - |
- - -} -{$IFDEF WIN_GDI} - -function ClipboardHasText: Boolean; -{* Returns true, if the clipboard contain text to paste from. } -function Clipboard2Text: AnsiString; -{* If clipboard contains text, this function returns it for You. } -{$IFNDEF _FPC} -{$IFNDEF _D2} -function Clipboard2WText: KOLWideString; -{* If clipboard contains text, this function returns it for You (as Unicode string). } -{$ENDIF _D2} -{$ENDIF _FPC} -function Text2Clipboard( const S: AnsiString ): Boolean; -{* Puts given string to a clipboard. } -{$IFNDEF _FPC} -{$IFNDEF _D2} -function WText2Clipboard( const WS: KOLWideString ): Boolean; -{* Puts given Unicode string to a clipboard. -|
-} -{$ENDIF _D2} -{$ENDIF _FPC} - -var SearchMnemonics: function ( const S: KOLString ): KOLString - = {$IFDEF F_P} DummyStrFun {$ELSE} - {$IFDEF UNICODE_CTRLS} WAnsiUpperCase {$ELSE} AnsiUpperCase {$ENDIF} {$ENDIF}; - MnemonicsLocale: Integer; - -procedure SupportAnsiMnemonics( LocaleID: Integer ); -{* Provides encoding to work with given locale. Call this global function to - extend TControl.SupportMnemonics capability (also should be called for a form - or for Applet variable). - - -} -{$ENDIF WIN_GDI} -{$IFDEF WIN_GDI} - -{$IFnDEF _D5orHigher} - {$DEFINE DATE0_0001} -{$ENDIF _D5orHigher} -{$IFnDEF DATE0_0001} - {$DEFINE DATE0_1601} -{$ENDIF} //Starting from the version 3.1415926, (so called PI-version), datetime - //can be correctly handled (by default) from 1-Jan-1601 to 1-Jan-38827. - //This made it possible to use short calls to API functions to convert date and time. - //If you still want to count time correctly from 1-Jan-1 B.C., or a compatibility - //is required for old applications, define symbol DATE0_0001 in your - //project options. Actually this does not mean that TDateTime forma changed, - //but only restrictions are in converting date to TSystemTime from TDateTime - //and vice versa. -type - //TDateTime = Double; // well, it is already defined so in System.pas - {* Basic date and time type. Integer part represents year and days (as is, - i.e. 1-Jan-2000 is representing by value 730141, which is a number of - days from 1-Jan-0001 to 1-Jan-2000 inclusively). Fractional part is - representing hours, minutes, seconds and milliseconds of a day - proportionally (like in VCL TDateTime type, e.g. 0.5 = 12:00, 0.25 = 6:00, - etc.). } - - PDayTable = ^TDayTable; - TDayTable = array[1..12] of Byte; - - TDateFormat = ( dfShortDate, dfLongDate ); - {* Date formats available to use in formatting date/time to string. } - TTimeFormatFlag = ( tffNoMinutes, tffNoSeconds, tffNoMarker, tffForce24 ); - {* Additional flags, used for formatting time. } - TTimeFormatFlags = Set of TTimeFormatFlag; - {* Set of flags, used for formatting time. } - -const - MonthDays: array [Boolean] of TDayTable = - ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), - (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)); - {* The MonthDays array can be used to quickly find the number of - days in a month: MonthDays[IsLeapYear(Y), M]. } - - SecsPerDay = 24 * 60 * 60; - {* Seconds per day. } - MSecsPerDay = SecsPerDay * 1000; - {* Milliseconds per day. } - - Date1601 = 584389; - VCLDate0 = 693594; - {* Value to convert VCL "date 0" to KOL "date 0" and back. - This value corresponds to 30-Dec-1899, 0:00:00. So, - to convert VCL date to KOL date, just subtract this - value from VCL date. And to convert back from KOL date - to VCL date, add this value to KOL date.} - -function Now : TDateTime; -{* Returns local date and time on running PC. } -function Date: TDateTime; -{* Returns todaylocal date. } -procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD ); -{* Decodes date. } -procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD ); -{* Decodes date. } -function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean; -{* Encodes date. } -function CompareSystemTime(const D1, D2 : TSystemTime) : Integer; -{* Compares to TSystemTime records. Returns -1, 0, or 1 if, correspondantly, - D1 < D2, D1 = D2 and D1 > D2. } -procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer ); -{* Increases/decreases day in TSystemTime record onto given days count - (can be negative). } -procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer ); -{* Increases/decreases month number in TSystemTime record onto given - months count (can be negative). Correct result is not garantee if - day number is incorrect for newly obtained month. } -function IsLeapYear(Year: Integer): Boolean; -{* Returns True, if given year is "leap" (i.e. has 29 days in the February). } -function DayOfWeek(Date: TDateTime): Integer; -{* Returns day of week (0..6) for given date. } -function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean; -{* Converts TSystemTime record to XDateTime variable. } -function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean; -{* Converts TDateTime variable to TSystemTime record. } -function DateTime_System2Local( DTSys: TDateTime ): TDateTime; -{* Converts DTSys representing system time (+0 Grinvich) to local time. } -function DateTime_Local2System( DTLoc: TDateTime ): TDateTime; -{* Converts DTLoc representing local time to system time (+0 Grinvich) } -function FileTime2DateTime( const ft: TFileTime; var DT: TDateTime ): Boolean; -{* } -function DateTime2FileTime( DT: TDateTime; var ft: TFileTime ): Boolean; -{* } - -procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word); -{* Dividing of integer onto divisor with obtaining both result of division - and remainder. } - -function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD; - const DfltDateFormat : TDateFormat; - const DateFormat : PKOLChar ) : KOLString; -{* Formats date, stored in TSystemTime record into string, using given locale - and date/time formatting flags. (E.g.: GetUserDefaultLangID). } -function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD; - const Flags : TTimeFormatFlags; - const TimeFormat : PKOLChar ) : KOLString; -{* Formats time, stored in TSystemTime record into string, using given locale - and date/time formatting flags. } - -function Date2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString; -{* Represents date as a string correspondently to Fmt formatting string. - See possible pictures in definition of the function Str2DateTimeFmt - (the first part). If Fmt string is empty, default system date format - for short date string used. } -function Time2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString; -{* Represents time as a string correspondently to Fmt formatting string. - See possible pictures in definition of the function Str2DateTimeFmt - (the second part). If Fmt string is empty, default system time format - for short date string used. } -function DateTime2StrShort( D: TDateTime ): KOLString; -{* Formats date and time to string in short date format using current user - locale. } -function Str2DateTimeFmt( const sFmtStr, sS: KOLString ): TDateTime; -{* Restores date or/and time from string correspondently to a format string. - Date and time formatting string can contain following pictures (case - sensitive): - |
-        DATE PICTURES
-   d    Day of the month as digits without leading zeros for single digit days.
-   dd   Day of the month as digits with leading zeros for single digit days
-   ddd  Day of the week as a 3-letter abbreviation as specified by a
-        LOCALE_SABBREVDAYNAME value.
-   dddd Day of the week as specified by a LOCALE_SDAYNAME value.
-   M    Month as digits without leading zeros for single digit months.
-   MM   Month as digits with leading zeros for single digit months
-   MMM  Month as a three letter abbreviation as specified by a LOCALE_SABBREVMONTHNAME value.
-   MMMM Month as specified by a LOCALE_SMONTHNAME value.
-   y    Year represented only be the last digit.
-   yy   Year represented only be the last two digits.
-   yyyy Year represented by the full 4 digits.
-   gg   Period/era string as specified by the CAL_SERASTRING value. The gg
-        format picture in a date string is ignored if there is no associated era
-        string. In Enlish locales, usual values are BC or AD.
-
-        TIME PICTURES
-   h    Hours without leading zeros for single-digit hours (12-hour clock).
-   hh   Hours with leading zeros for single-digit hours (12-hour clock).
-   H    Hours without leading zeros for single-digit hours (24-hour clock).
-   HH   Hours with leading zeros for single-digit hours (24-hour clock).
-   m    Minutes without leading zeros for single-digit minutes.
-   mm   Minutes with leading zeros for single-digit minutes.
-   s    Seconds without leading zeros for single-digit seconds.
-   ss   Seconds with leading zeros for single-digit seconds.
-   t    One character–time marker string (usually P or A, in English locales).
-   tt   Multicharacter–time marker string (usually PM or AM, in English locales).
-   |
- E.g., 'D, yyyy/MM/dd h:mm:ss'. - See also Str2DateTimeShort function. - } -function Str2TimeFmt(const sFmtStr, sS: KOLString): TDateTime; -{* Same as above but for time only } -function Str2DateTimeShort( const S: KOLString ): TDateTime; -{* Restores date and time from string correspondently to current user locale. } -function Str2DateTimeShortEx( const S: KOLString ): TDateTime; -{* Like Str2DateTimeShort above, but uses locale defined date and time - separators to avoid recognizing time as a date in some cases.} -function Str2TimeShort(const S: KOLString): TDateTime; -{* Like Str2DateTimeShort but for time only. -|
- - -} -{$ENDIF WIN_GDI} - -const - ofOpenRead = {$IFDEF LIN} O_RDONLY {$ELSE} $80000000 {$ENDIF}; - {* Use this flag (in combination with others) to open file for "read" only. } - ofOpenWrite = {$IFDEF LIN} O_WRONLY {$ELSE} $40000000 {$ENDIF}; - {* Use this flag (in combination with others) to open file for "write" only. } - ofOpenReadWrite = {$IFDEF LIN} O_RDWR {$ELSE} $C0000000 {$ENDIF}; - {* Use this flag (in combination with others) to open file for "read" and "write". } - - ofShareExclusive = {$IFDEF LIN} $10 {$ELSE} $00 {$ENDIF}; - {* Use this flag (in combination with others) to open file for exclusive use. } - ofShareDenyWrite = {$IFDEF LIN} $20 {$ELSE} $01 {$ENDIF}; - {* Use this flag (in combination with others) to open file in share mode, when - only attempts to open it in other process for "write" will be impossible. - I.e., other processes could open this file simultaneously for read only - access. } - ofShareDenyRead = {$IFDEF LIN} 0 {not supported} {$ELSE} $02 {$ENDIF}; - {* Use this flag (in combination with others) to open file in share mode, when - only attempts to open it for "read" in other processes will be disabled. - I.e., other processes could open it for "write" only access. } - ofShareDenyNone = {$IFDEF LIN} $30 {$ELSE} $03 {$ENDIF}; - {* Use this flag (in combination with others) to open file in full sharing mode. - I.e. any process will be able open this file using the same share flag. } - ofCreateNew = {$IFDEF LIN} O_CREAT or O_TRUNC {$ELSE} $100 {$ENDIF}; - {* Default creation disposition. Use this flag for creating new file (usually - for write access. } - ofCreateAlways = {$IFDEF LIN} O_CREAT {$ELSE} $200 {$ENDIF}; - {* Use this flag (in combination with others) to open existing or creating new - file. If existing file is opened, it is truncated to size 0. } - ofOpenExisting = {$IFDEF LIN} 0 {$ELSE} $300 {$ENDIF}; - {* Use this flag (in combination with others) to open existing file only. } - ofOpenAlways = {$IFDEF LIN} O_CREAT {$ELSE} $400 {$ENDIF}; - {* Use this flag (in combination with others) to open existing or create new - (if such file is not yet exists). } - ofTruncateExisting = {$IFDEF LIN} O_TRUNC {$ELSE} $500 {$ENDIF}; - {* Use this flag (in combination with others) to open existing file and truncate - it to size 0. } - - ofAttrReadOnly = {$IFDEF LIN} 0 {$ELSE} $10000 {$ENDIF}; - {* Use this flag to create Read-Only file (?). } - ofAttrHidden = {$IFDEF LIN} 0 {$ELSE} $20000 {$ENDIF}; - {* Use this flag to create hidden file. } - ofAttrSystem = {$IFDEF LIN} 0 {$ELSE} $40000 {$ENDIF}; - {* Use this flag to create system file. } - ofAttrTemp = {$IFDEF LIN} 0 {$ELSE} $1000000 {$ENDIF}; - {* Use this flag to create temp file. } - ofAttrArchive = {$IFDEF LIN} 0 {$ELSE} $200000 {$ENDIF}; - {* Use this flag to create archive file. } - ofAttrCompressed = {$IFDEF LIN} 0 {$ELSE} $8000000 {$ENDIF}; - {* Use this flag to create compressed file. Has effect only on NTFS, and - only if ofAttrCompressed is not specified also. } - ofAttrOffline = {$IFDEF LIN} 0 {$ELSE} $10000000 {$ENDIF}; - {* Use this flag to create offline file. } - -{$IFDEF _D3orHigher} -function WFileCreate(const FileName: KOLWideString; OpenFlags: DWord): THandle; -{* } -{$ENDIF} -function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle; -{* Call this function to open existing or create new file. OpenFlags - parameter can be a combination of up to three flags (by one from - each group: - | - |&L= - - 1st group. Here You decide - wish You open file for read, write or read-and-write operations; - -2nd - group - sharing. Here You can mark out sharing mode, which is used to - open file. - - - 3rd group - creation disposition. Here You determine, either to create new - or open existing file and if to truncate existing or not. - |
%0 - |&E=
} -function FileClose(Handle: THandle): Boolean; -{* Call it to close opened earlier file. } -function FileExists( const FileName: KOLString ) : Boolean; -{* Returns True, if given file exists. - |
Note (by Dod): - It is not documented in a help for GetFileAttributes, but it seems that - under NT-based Windows systems, FALSE is always returned for files - opened for excluseve use like pagefile.sys. } -{$IFDEF _D3orHigher} -function WFileExists( const FileName: KOLWideString ) : Boolean; -{* Returns True, if given file exists. - |
Note (by Dod): - It is not documented in a help for GetFileAttributes, but it seems that - under NT-based Windows systems, FALSE is always returned for files - opened for excluseve use like pagefile.sys. } -{$ENDIF} -function FileSeek(Handle: THandle; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize; -{* Changes current position in file. } -function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord; -{* Reads bytes from current position in file to buffer. Returns number of - read bytes. } -{$IFDEF LIN} -function GetFileSize( Handle: THandle; HiSize: PDWORD ): DWORD; -{$ENDIF LIN} -function File2Str(Handle: THandle): AnsiString; -{* Reads file from current position to the end and returns result as ansi string. } -{$IFNDEF _D2} -function File2WStr(Handle: THandle): KOLWideString; -{* Reads UNICODE file from current position to the end and returns result as - unicode string. } -{$ENDIF} -function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord; -{* Writes bytes from buffer to file from current position, extending its - size if needed. } -function FileEOF( Handle: THandle ) : Boolean; -{* Returns True, if EOF is achieved during read operations or last byte is - overwritten or append made to extend file during last write operation. } -function FileFullPath( const FileName : KOLString ) : KOLString; -{* Returns full path name for given file. Validness of source FileName path - is not checked at all. } -{$IFDEF WIN} //--------------- these functions have not sense in Linux: -------- -function FileShortPath( const FileName: KOLString ): KOLString; -{* Returns short path to the file or directory. } -function FileIconSystemIdx( const Path: KOLString ): Integer; -{* Returns index of the index of the system icon correspondent to the file or - directory in system icon image list. } -function FileIconSysIdxOffline( const Path: KOLString ): Integer; -{* The same as FileIconSystemIdx, but an icon is calculated for the file - as it were offline (it is possible to get an icon for file even if - it is not existing, on base of its extension only). } -function DirIconSysIdxOffline( const Path: KOLString ): Integer; -{* The same as FileIconSysIdxOffline, but for a folder rather then for a file. } -{$ENDIF WIN} //----------------------------------------------------------------- -procedure LogFileOutput( const filepath, str: KOLString ); -{* Debug function. Use it to append given string to the end of the given file. } - -function Str2File( Filename: PKOLChar; Str: PAnsiChar ): Boolean; -{* Save null-terminated string to file directly. If file does not exists, it is - created. If it exists, it is overriden. If operation failed, FALSE is returned. } -function WStr2File( Filename: PKOLChar; Str: PWideChar ): Boolean; -{* Save null-terminated wide string to file directly. If file does not exists, it is - created. If it exists, it is overriden. If operation failed, FALSE is returned. } -function StrSaveToFile( const Filename: KOLString; const Str: AnsiString ): Boolean; -{* Saves a string to a file without any changes. If file does not exists, it is - created. If it exists, it is overriden. If operation failed, FALSE is returned. } -function StrLoadFromFile( const Filename: KOLString ): AnsiString; -{* Reads entire file and returns its content as a string. If operation failed, - an empty strinng is returned. - |
by Sergey Shishmintzev: it is possible to pass Filename = 'CON' to - read input from redirected console output. } -{$IFNDEF _D2} -function WStrSaveToFile( const Filename: KOLString; const Str: KOLWideString ): Boolean; -{* Saves a string to a file without any changes. If file does not exists, it is - created. If it exists, it is overriden. If operation failed, FALSE is returned. } -function WStrLoadFromFile( const Filename: KOLString ): KOLWideString; -{* Reads entire file and returns its content as a string. If operation failed, - an empty strinng is returned. - |
by Sergey Shishmintzev: it is possible to pass Filename = 'CON' to - read input from redirected console output. } -{$ENDIF} - -function Mem2File( Filename: PKOLChar; Mem: Pointer; Len: Integer ): Integer; -{* Saves memory block to a file (if file exists it is overriden, created new if - not exists). } -function File2Mem( Filename: PKOLChar; Mem: Pointer; MaxLen: Integer ): Integer; -{* Loads file content to memory. } - -{$IFDEF WIN} -type - PFindFileData = ^TFindFileData; - TFindFileData = packed record - // from TWin32FindData: ------------- - dwFileAttributes: DWORD; - ftCreationTime: TFileTime; - ftLastAccessTime: TFileTime; - ftLastWriteTime: TFileTime; - nFileSizeHigh: DWORD; - nFileSizeLow: DWORD; - dwReserved0: DWORD; - dwReserved1: DWORD; - cFileName: Array[0..MAX_PATH - 1] of KOLChar; - cAlternateFileName: Array[0..13] of KOLChar; - //-------- + handle: - FindHandle: THandle; - end; -{$ENDIF WIN} -function Find_First( const FilePathName: KOLString; var F: TFindFileData ): Boolean; -function Find_Next( var F: TFindFileData ): Boolean; -procedure Find_Close( var F: TFindFileData ); -{$IFDEF _D2orD3} -function FileSize( const Path: KOLString ) : Integer; -{$ELSE} -function FileSize( const Path: KOLString ) : Int64; -{$ENDIF} -{* Returns file size in bytes without opening it. If file too large - to represent its size as Integer, -1 is returned. } -procedure FileTime( const Path: KOLString; - CreateTime, LastAccessTime, LastModifyTime: PFileTime ); stdcall; -{* Returns file times without opening it. } -function GetUniqueFilename( PathName: KOLString ) : KOLString; -{* If file given by PathName exists, modifies it to create unique - filename in target folder and returns it. Modification is performed - by incrementing last number in name (if name part of file does not - represent a number, such number is generated and concatenated to - it). E.g., if file aaa.aaa is already exist, the function checks - names aaa1.aaa, aaa2.aaa, ..., aaa10.aaa, etc. For name abc123.ext, - names abc124.ext, abc125.ext, etc. will be checked. } -function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer; -{* Compares time of file (createing, writing, accessing. Returns - -1, 0, 1 if correspondantly FT1FT2. } -function DirectoryExists(const Name: KOLString): Boolean; -{* Returns True if given directory (folder) exists. } -function DiskPresent( const DrivePath: KOLString ): Boolean; -{* Returns TRUE if the disk is present } -{$IFDEF _D3orHigher} -function WDirectoryExists(const Name: KOLWideString): Boolean; -{* } -{$ENDIF} -function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean; - const Mask: KOLString ): Boolean; -{* Returns TRUE if directory does not contain files (or directories only) - satisfying given mask. } -function DirectoryEmpty(const Name: KOLString): Boolean; -{* Returns True if given directory is not exists or empty. } -function DirectoryHasSubdirs( const Path: KOLString ): Boolean; -{* Returns TRUE if given directory exists and has subdirectories. } -function GetStartDir: KOLString; -{* Returns path to directory where executable is located (regardless - of current directory). } -function ExePath: KOLString; -{* Returns the path to the exe-file (in case of dll hook, this is exe-file - of the process in which context dll hook function is called). } -function ModulePath: KOLString; -{* Returns the path to the module (exe, dll) itself. } - - - -//--------------------------------------------------------- -// Following functions/procedures are created by Edward Aretino: -// IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter, -// ForceDirectories, CreateDir, ChangeFileExt -//--------------------------------------------------------- -function ExcludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString; -{* If S is finished with character C, it is excluded. } -function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString; -{* If S is not finished with character C, it is added. } -function IncludeTrailingPathDelimiter(const S: KOLString): KOLString; -{* by Edward Aretino. Adds '\' to the end if it is not present. } -function ExcludeTrailingPathDelimiter(const S: KOLString): KOLString; -{* by Edward Aretino. Removes '\' at the end if it is present. } - -function ExtractFileDrive( const Path: KOLString ) : KOLString; -{* Returns only drive part from exact path to a file or a directory. - For network paths, returns a computer name together with a following - name of shared directory (like '\\compname\shared\' ). } -function ExtractFilePath( const Path: KOLString ) : KOLString; -{* Returns only path part from exact path to file. } -{$IFDEF _D3orHigher} -function WExtractFilePath( const Path: KOLWideString ) : KOLWideString; -{* Returns only path part from exact path to file. } -{$ENDIF} -function IsNetworkPath( const Path: KOLString ): Boolean; -{* Returns TRUE, if Path is starting from '\\'. } -function ExtractFileName( const Path: KOLString ) : KOLString; -{* Extracts file name from exact path to file. } -function ExtractFileNameWOext( const Path: KOLString ) : KOLString; -{* Extracts file name from path to file or from filename. } -function ExtractFileExt( const Path: KOLString ) : KOLString; -{* Extracts extention from file name (returns it with dot '.' first) } -function ReplaceExt( const Path, NewExt: KOLString ): KOLString; -{* Returns Path to a file with extension replaced to a new extension. - Pass a new extension started with '.', e.g. '.txt'. } - -function ForceDirectories(Dir: KOLString): Boolean; -{* by Edward Aretino. Creates given directory if not present. All needed - subdirectories are created if necessary. } -function CreateDir(const Dir: KOLString): Boolean; -{* by Edward Aretino. Creates given directory. } -function ChangeFileExt(FileName: KOLString; const Extension: KOLString): KOLString; -{* by Edward Aretino. Changes file extention. } -function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString; -{* Returns a path with extension replaced to a given one. } -{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -function ExtractShortPathName( const Path: KOLString ): KOLString; -{* } -{$IFDEF GDI} -function FilePathShortened( const Path: KOLString; MaxLen: Integer ): KOLString; -{* Returns shortened file path to fit MaxLen characters. } -function FilePathShortenPixels( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString; -{* Returns shortened file path to fit MaxPixels for a given DC. If you pass - Canvas.Handle of any control or bitmap object, ensure that font is valid - for it (or call TCanvas.RequiredState( FontValid ) method before. If DC passed - = 0, call is equivalent to call FilePathShortened, and MaxPixels means in such - case maximum number of characters. } -function MinimizeName( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString; -{* Exactly the same as MinimizeName in FileCtrl.pas (VCL). } -{$ENDIF GDI} - -function GetSystemDir: KOLString; -{* Returns path to windows system directory. } -function GetWindowsDir : KOLString; -{* Returns path to Windows directory. } -{$ENDIF WIN} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -function GetWorkDir : KOLString; -{* Returns path to application's working directory. } -function GetTempDir : KOLString; -{* Returns path to default temp folder (directory to place temporary files). } -function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString; -{* Returns path to just created temporary file. } -function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLString): KOLString; -{* List of files in string, separating each path from others with a character stored - in FileOpSeparator variables (#13 by default). - E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())} -function DeleteFiles( const DirPath: KOLString ): Boolean; -{* Deletes files by file mask (given with wildcards '*' and '?'). } -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -var FileOpSeparator: KOLChar = {$IFDEF OLD_COMPAT}';'{$ELSE}#13{$ENDIF}; -function DoFileOp( const FromList, ToList: KOLString; FileOp: UINT; Flags: Word; - Title: PKOLChar): Boolean; -{* By Unknown Mystic. FileOp can be: FO_MOVE, FO_COPY, FO_DELETE, FO_RENAME. - Flags can be a combination of values: FOF_MULTIDESTFILES, FOF_CONFIRMMOUSE, - FOF_SILENT, FOF_RENAMEONCOLLISION, FOF_NOCONFIRMATION, FOF_WANTMAPPINGHANDLE, - FOF_ALLOWUNDO, FOF_FILESONLY, FOF_SIMPLEPROGRESS, FOF_NOCONFIRMMKDIR, - FOF_NOERRORUI. Title used only with FOF_SIMPLEPROGRESS. } -function DeleteFile2Recycle( const Filename : KOLString ) : Boolean; -{* Deletes file to recycle bin. This operation can be very slow, when - called for a single file. To delete group of files at once (fast), - pass a list of paths to files to be deleted, separating each path - from others with a character stored in FileOpSeparator variable (by default #13, - but in case when OLD_COMPAT symbol added - ';'). E.g.: 'unit1.dcu'#13'unit1.~pa' - |
- FALSE is returned only in case when at least one file was not deleted - successfully. - |
- Note, that files are deleted not to recycle bin, if wildcards are - used or not fully qualified paths to files. } -function CopyMoveFiles( const FromList, ToList: KOLString; Move: Boolean ): Boolean; -{* } -{$IFNDEF PAS_ONLY} -function DiskFreeSpace( const Path: KOLString ): I64; -{$ENDIF} -{* Returns disk free space in bytes. Pass a path to root directory, - e.g. 'C:\'. - |
- - - - These functions can be used independently to simplify access to Windows - registry. } -{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -function RegKeyOpenRead( Key: HKey; const SubKey: KOLString ): HKey; -{* Opens registry key for read operations (including enumerating of subkeys). - Pass either handle of opened earlier key or one of constans - HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS - as a first parameter. If not successful, 0 is returned. } -function RegKeyOpenWrite( Key: HKey; const SubKey: KOLString ): HKey; -{* Opens registry key for write operations (including adding new values or - subkeys), as well as for read operations too. See also RegKeyOpenRead. } -function RegKeyOpenCreate( Key: HKey; const SubKey: KOLString ): HKey; -{* Creates and opens key. } -function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString; -{* Reads key, which must have type REG_SZ (null-terminated string). If - not successful, empty string is returned. This function as well as all - other registry manipulation functions, does nothing, if Key passed is 0 - (without producing any error). } -function RegKeyGetStrEx( Key: HKey; const ValueName: KOLString - {$IFDEF OPTIONAL_REG_EXPAND_SZ} ; ExpandEnvVars: Boolean {$ENDIF} ): KOLString; -{* Like RegKeyGetStr, but accepts REG_EXPAND_SZ type, expanding all - environment variables in resulting string. - |
- Code provided by neuron, e-mailto:neuron@hollowtube.mine.nu } -function RegKeyGetDw( Key: HKey; const ValueName: KOLString ): DWORD; -{* Reads key value, which must have type REG_DWORD. If ValueName passed - is '' (empty string), unnamed (default) value is reading. If not - successful, 0 is returned. } -function RegKeySetStr(Key: HKey; const ValueName: KOLString; const Value: KOLString ): Boolean; -{* Writes new key value as null-terminated string (type REG_SZ). If not - successful, returns False. } -function RegKeySetStrEx( Key: HKey; const ValueName: KOLString; const Value: KOLString; - expand: Boolean): Boolean; -{* Writes new key value as REG_SZ or REG_EXPAND_SZ. - by neuron, e-mailto:neuron@hollowtube.mine.nu } -function RegKeySetDw( Key: HKey; const ValueName: KOLString; Value: DWORD ): Boolean; -{* Writes new key value as dword (with type REG_DWORD). Returns False, - if not successful. } -procedure RegKeyClose( Key: HKey ); -{* Closes key, opened using RegKeyOpenRead or RegKeyOpenWrite. (But does - nothing, if Key passed is 0). } -function RegKeyDelete( Key: HKey; const SubKey: KOLString ): Boolean; -{* Deletes key. Does nothing if key passed is 0 (returns FALSE). } -function RegKeyDeleteValue( Key: HKey; const SubKey: KOLString ): Boolean; -{* Deletes value. - by neuron, e-mailto:neuron@hollowtube.mine.nu } -function RegKeyExists( Key: HKey; const SubKey: KOLString ): Boolean; -{* Returns TRUE, if given subkey exists under given Key. } -function RegKeyValExists( Key: HKey; const ValueName: KOLString ): Boolean; -{* Returns TRUE, if given value exists under the Key. -} -function RegKeyValueSize( Key: HKey; const ValueName: KOLString ): Integer; -{* Returns a size of value. This is a size of buffer needed to store - registry key value. For string value, size returned is equal to a - length of string plus 1 for terminated null character. } -function RegKeyGetBinary( Key: HKey; const ValueName: KOLString; var Buffer; Count: Integer ): Integer; -{* Reads binary data from a registry, writing it to the Buffer. - It is supposed that size of Buffer provided is at least Count bytes. - Returned value is actul count of bytes read from the registry and written - to the Buffer. - |
- This function can be used to get data of any type from the registry, not - only REG_BINARY. } -function RegKeySetBinary( Key: HKey; const ValueName: KOLString; const Buffer; Count: Integer ): Boolean; -{* Stores binary data in the registry. } -function RegKeyGetDateTime(Key: HKey; const ValueName: KOLString): TDateTime; -{* Returns datetime variable stored in registry in binary format. } -function RegKeySetDateTime(Key: HKey; const ValueName: KOLString; DateTime: TDateTime): Boolean; -{* Stores DateTime variable in the registry. } - -//------------------------------------------------------- -// registry functions by Valerian Luft -//------------------------------------------------------- -function RegKeyGetSubKeys( const Key: HKEY; List: PKOLStrList): Boolean; -{* The function enumerates subkeys of the specified open registry key. - True is returned, if successful. -} -function RegKeyGetValueNames(const Key: HKEY; List: PKOLStrList): Boolean; -{* The function enumerates value names of the specified open registry key. - True is returned, if successful. -} -function RegKeyGetValueTyp (const Key:HKEY; const ValueName: KOLString) : DWORD; -{* The function receives the type of data stored in the specified value. - |
- If the function fails, the return value is the Key value. - |
- If the function succeeds, the return value return will be one of the following: - |
- REG_BINARY , REG_DWORD, REG_DWORD_LITTLE_ENDIAN, - REG_DWORD_BIG_ENDIAN, REG_EXPAND_SZ, REG_LINK , REG_MULTI_SZ, - REG_NONE, REG_RESOURCE_LIST, REG_SZ - -|
- - - This part contains implementation of 'quick sort' algorithm, - based on following code: - -|
-| TQSort by Mike Junkin 10/19/95.
-| DoQSort routine adapted from Peter Szymiczek's QSort procedure which
-| was presented in issue#8 of The Unofficial Delphi Newsletter.
-
-| TQSort changed by Vladimir Kladov (Mr.Bonanzas) to allow 32-bit
-| sorting (of big arrays with more than 64K elements).
-|
- - Finally, this sort procedure is adapted to XCL (and then to KOL) - requirements (no references to SysUtils, Classes etc. TQSort object - is transferred to a single procedure call and DoQSort method is - renamed to SortData - which is a regular procedure now). } - -{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -procedure SortData( const Data: Pointer; const uNElem: Dword; - const CompareFun: TCompareEvent; - const SwapProc: TSwapEvent ); -{* Call it to sort any array of data of any kind, passing total - number of items in an array and two defined (regular) function - and procedure to perform custom compare and swap operations. - First procedure parameter is to pass it to callback function - CompareFun and procedure SwapProc. Items are enumerated from - 0 to uNElem-1. } - -{$IFDEF _D3orHigher} -procedure SortArray( const Data: Pointer; const uNElem: Dword; - const CompareFun: TCompareArrayEvent ); -{* Like SortData, but faster and allows to sort only contigous arrays of - dwords (or integers or pointers occupying for 4 bytes for each item. } -{$ENDIF} - -procedure SwapListItems( const L: Pointer; const e1, e2: DWORD ); -{* Use this function as the last parameter for SortData call when a PList - object is sorting. SwapListItems just exchanges two items of the list. } - -procedure SortIntegerArray( var A : array of Integer ); -{* procedure to sort array of integers. } - -procedure SortDwordArray( var A : array of DWORD ); -{* Procedure to sort array of unsigned 32-bit integers. -|
-} -{ ------------------- directory list object ---------------------------------- } - -type - TDirItemAction = ( diSkip, diAccept, diCancel ); - TOnDirItem = procedure( Sender: PObj; var DirItem: TFindFileData; var Accept: TDirItemAction ) - of object; - TSortDirRules = ( sdrNone, sdrFoldersFirst, sdrCaseSensitive, sdrByName, sdrByExt, - sdrBySize, sdrBySizeDescending, sdrByDateCreate, sdrByDateChanged, - sdrByDateAccessed, sdrInvertOrder ); - {* List of rules (options) to sort directories. Rules are passed to Sort - method in an array, and first placed rules are applied first. } - - PDirList = ^TDirList; -{ ---------------------------------------------------------------------- - TDirList - Directory scanning ------------------------------------------------------------------------ } - TDirList = object( TObj ) - {* Allows easy directory scanning. This is not visual object, but - storage to simplify working with directory content. } - protected - FListPositions : PList; //^^^^^^^^^^ Attention: order of FListPositions & - fStoreFiles: PStream; //__________ fStoreFiles is IMPORTANT! - FPath: KOLString; - fFilters: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF}; - fOnItem: TOnDirItem; - function Get(Idx: Integer): PFindFileData; - function GetCount: Integer; - function GetNames(Idx: Integer): KOLString; - function GetIsDirectory(Idx: Integer): Boolean; - protected - function SatisfyFilter( FileName : PKOLChar; FileAttr, FindAttr : DWord ) : Boolean; - destructor Destroy; virtual; - {* Destructor. As usual, call Free method to destroy an object. } - public - property Items[ Idx : Integer ] : PFindfileData read Get; default; - {* Full access to scanned items (files and subdirectories). } - property IsDirectory[ Idx: Integer ]: Boolean read GetIsDirectory; - {* Returns TRUE, if specified item represents a directory, not a file. } - property Count : Integer read GetCount; - {* Number of items. } - property Names[ Idx : Integer ] : KOLString read GetNames; - {* Full long names of directory items. } - property Path : KOLString read FPath; - {* Path of scanned directory. } - procedure Clear; - {* Call it to clear list of files. } - procedure ScanDirectory( const DirPath, Filter : KOLString; Attr : DWord ); - {* Call it to rescan directory or to scan another directory content - (method Clear is called first). Pass path to directory, file filter - and attributes to scan directory immediately. - |
    - Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr - parameter. If 0 passed, both files and directories are listed. } - procedure ScanDirectoryEx( const DirPath, Filters : KOLString; Attr : DWord ); - {* Call it to rescan directory or to scan another directory content - (method Clear is called first). Pass path to directory, file filter - and attributes to scan directory immediately. - |
    - Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr - parameter. } - procedure Sort( Rules : array of TSortDirRules ); - {* Sorts directory entries. If empty rules array passed, default rules - array DefSortDirRules is used. } - function FileList( const Separator {e.g.: ';', or #13}: KOLString; - Dirs, FullPaths: Boolean ): KOLString; - {* Returns a string containing all names separated with Separator. - If Dirs=FALSE, only files are returned. } - property OnItem: TOnDirItem read fOnItem write fOnItem; - {* This event is called on reading each item while scanning directory. - To use it, first create PDirList object with empty path to scan, then - assign OnItem event and call ScanDirectory with correct path. } - procedure DeleteItem( Idx: Integer ); - {* Allows to delete an item from the directory list (not from the disk!) } - procedure AddItem( FindData: PFindFileData ); - {* Allows to add arbitrary item to the list. } - procedure InsertItem( idx: Integer; FindData: PFindFileData ); - {* Allows to add arbitrary item to the list. } - end; - -function NewDirList( const DirPath, Filter: KOLString; Attr: DWORD ): PDirList; -{* Creates directory list object using easy one-string filter. If Attr = FILE_ATTRIBUTE_NORMAL, - only files are scanned without directories. If Attr = 0, both files and - directories are listed. } -function NewDirListEx( const DirPath, Filters: KOLString; Attr: DWORD ): PDirList; -{* Creates directory list object using several filters, separated by ';'. - Filters starting from '^' consider to be anti-filters, i.e. files, - satisfying to those masks, are skept during scanning. } -const DefSortDirRules : array[ 0..3 ] of TSortDirRules = ( sdrFoldersFirst, - sdrByName, sdrBySize, sdrByDateCreate ); -{* Default rules to sort directory entries. } -{$IFNDEF PAS_ONLY} -function DirectorySize( const Path: KOLString ): I64; -{* Returns directory size in bytes as large 64 bit integer. } -{$ENDIF} - -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -type - TOpenSaveOption = ( OSCreatePrompt, - OSExtensionDiffent, - OSFileMustExist, - OSHideReadonly, - OSNoChangedir, - OSNoReferenceLinks, - OSAllowMultiSelect, - OSNoNetworkButton, - OSNoReadonlyReturn, - OSOverwritePrompt, - OSPathMustExist, - OSReadonly, - OSNoValidate - //{$IFDEF OpenSaveDialog_Extended} - , - OSTemplate, - OSHook - //{$ENDIF} - ); - TOpenSaveOptions = set of TOpenSaveOption; - {* Options available for TOpenSaveDialog. } - - POpenSaveDialog = ^TOpenSaveDialog; -{ ---------------------------------------------------------------------- - TOpenSaveDialog ------------------------------------------------------------------------ } - TOpenSaveDialog = object( TObj ) - {* Object to show standard Open/Save dialog. Initially provided - for XCL by Carlo Kok. } - protected - FFilter : KOLString; - fFilterIndex : Integer; - fOpenDialog : Boolean; - FInitialDir : KOLString; - FDefExtension : KOLString; - FFilename : KOLString; - FTitle : KOLString; - FOptions : TOpenSaveOptions; - fWnd: THandle; - fOpenReadOnly: Boolean; - public - TemplateName: KOLString; // do not forget to add OpenSaveDialog_Extended - HookProc: Pointer; // to project options conditionals! - NoPlaceBar: Boolean; // TRUE, if place bar is disabled in the new style - // dialogs (if the symbol OpenSaveDialog_Extended is - // not added in project options, place bar is always - // enabled in Windows 2000 and higher). - destructor Destroy; virtual; - {* destructor } - Function Execute : Boolean; - {* Call it after creating to perform selecting of file by user. } - property Filename : KOLString read FFilename write FFileName; - {* - Filename is separated by #13 when multiselect is true and the first - file, is the path of the files selected. - |
-    |  C:\Projects
-    |  Test1.Dpr
-    |  Test2.Dpr
-    |
- If only one file is selected, it is provided as (e.g.) - C:\Projects\Test1.dpr - |
For case when OSAllowMultiselect option used, after each - call initial value for a Filename containing several files prevents - system from opening the dialog. To fix this, assign another initial - value to Filename property in your code, when you use multiselect. - } - property InitialDir : KOLString read FInitialDir write FInitialDir; - {* Initial directory path. If not set, current directory (usually - directory when program is started) is used. } - property Filter : KOLString read FFilter write FFilter; - {* A list of pairs of filter names and filter masks, separated with '|'. - If a mask contains more than one mask, it should be separated with ';'. - E.g.: - ! 'All files|*.*|Text files|*.txt;*.1st;*.diz' } - property FilterIndex : Integer read FFilterIndex write FFilterIndex; - {* Index of default filter mask (0 by default, which means "first"). } - property OpenDialog : Boolean read FOpenDialog write FOpenDialog; - {* True, if "Open" dialog. False, if "Save" dialog. True is default. } - property Title : KOLString read Ftitle write Ftitle; - {* Title for dialog. } - property Options : TOpenSaveOptions read FOptions write FOptions; - {* Options. } - property DefExtension : KOLString read FDefExtension write FDefExtension; - {* Default extention. Set it to desired extension without leading period, - e.g. 'txt', but not '.txt'. } - property WndOwner: THandle read fWnd write fWnd; - {* Owner window handle. If not assigned, Applet.Handle is used (whenever - possible). Assign it, if your application has stay-on-top forms, and - a separate Applet object is used. } - property OpenReadOnly: Boolean read fOpenReadOnly; - {* TRUE after Execute, if Read Only check box was checked by the user. - Options are not affected anyway. } - end; - -const DefOpenSaveDlgOptions: TOpenSaveOptions = [ OSHideReadonly, - OSOverwritePrompt, OSFileMustExist, OSPathMustExist ]; - -function NewOpenSaveDialog( const Title, StrtDir: KOLString; - Options: TOpenSaveOptions ): POpenSaveDialog; -{* Creates object, which can be used (several times) to open file(s) - selecting dialog. } - -type - POpenDirDialog = ^TOpenDirDialog; - - TOpenDirOption = ( odBrowseForComputer, odBrowseForPrinter, odDontGoBelowDomain, - odOnlyFileSystemAncestors, odOnlySystemDirs, odStatusText, - odBrowseIncludeFiles, odEditBox, odNewDialogStyle ); - {* Flags available for TOpenDirDialog object. } - // odfStatusText - do not support status callback - TOpenDirOptions = set of TOpenDirOption; - {* Set of all flags used to control ZOpenDirDialog class. } - - TOnODSelChange = procedure( Sender: POpenDirDialog; NewSelDir: PKOL_Char; - var EnableOK: Integer; var StatusText: KOL_String ) - of object; - {* Event type to be called when user select another directory in OpenDirDialog. - Set EnableOK to -1 to disable OK button, or to +1 to enable it. - It is also possible to set new StatusText string. } - -{ ---------------------------------------------------------------------- - TOpenDirDialog ------------------------------------------------------------------------ } - TOpenDirDialog = object( TObj ) - {* Dialog for open directories, uses SHBrowseForFolder. } - protected - FTitle: KOLString; - FOptions: TOpenDirOptions; - FCallBack: Pointer; - FCenterProc: procedure( Wnd: HWnd ); - FBuf : array[ 0..MAX_PATH ] of KOLChar; - FInitialPath: KOLString; - FCenterOnScreen: Boolean; - FDoSelChanged: procedure( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ); stdcall; - FOnSelChanged: TOnODSelChange; - FStatusText: KOLString; - FWnd, FDialogWnd: HWnd; - function GetPath: KOLString; - procedure SetInitialPath(const Value: KOLString); - procedure SetCenterOnScreen(const Value: Boolean); - procedure SetOnSelChanged(const Value: TOnODSelChange); - function GetInitialPath: KOLString; - public - destructor Destroy; virtual; - {* destructor } - function Execute : Boolean; - {* Call it to select directory by user. Returns True, if operation was - not cancelled by user. } - property Title : KOLString read FTitle write FTitle; - {* Title for a dialog. } - property Options : TOpenDirOptions read FOptions write FOptions; - {* Option flags. } - property Path : KOLString read GetPath; - {* Resulting (selected by user) path. } - property InitialPath: KOLString read GetInitialPath write SetInitialPath; - {* Set this property to a path of directory to be selected initially - in a dialog. } - property CenterOnScreen: Boolean read FCenterOnScreen write SetCenterOnScreen; - {* Set it to True to center dialog on screen. } - property OnSelChanged: TOnODSelChange read FOnSelChanged write SetOnSelChanged; - {* This event is called every time, when user selects another directory. - It is possible to enable/disable OK button in dialog and/or change - dialog status text in responce to event. } - property WndOwner: HWnd read FWnd write FWnd; - {* Owner window. If you want to provide your dialog visible over stay-on-top - form, fire it as a child of the form, assigning the handle of form window - to this property first. } - property DialogWnd: HWnd read FDialogWnd; - {* Handle to the open directory dialog itself, become available on the - first call of callback procedure (i.e. on the first call to OnSelChanged). - } - end; - -function NewOpenDirDialog( const Title: KOLString; Options: TOpenDirOptions ): - POpenDirDialog; -{* Creates object, which can be used (several times) to open directory - selecting dialog (using SHBrowseForFolder API call). } - -type - TColorCustomOption = ( ccoFullOpen, ccoShortOpen, ccoPreventFullOpen ); - -{$IFDEF KOL_MCK} -type TKOLOpenDirDialog = POpenDirDialog; -{$ENDIF} - - PColorDialog = ^TColorDialog; -{ ---------------------------------------------------------------------- - TColorDialog ------------------------------------------------------------------------ } - TColorDialog = object( TObj ) - {* Color choosing dialog. } - protected - public - OwnerWindow: HWnd; - {* Owner window (can be 0). } - CustomColors: array[ 1..16 ] of TColor; - {* Array of stored custom colors. } - ColorCustomOption: TColorCustomOption; - {* Options (how to open a dialog). } - Color: TColor; - {* Returned color (if the result of Execute is True). } - function Execute: Boolean; - {* Call this method to open a dialog and wait its result. } - end; - -function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog; -{* Creates color choosing dialog object. } -{$ENDIF WIN_GDI} -{$IFDEF WIN_GDI} -type - TIniFileMode = ( ifmRead, ifmWrite ); - {* ifmRead is default mode (means "read" data from ini-file. - Set mode to ifmWrite to write data to ini-file, correspondent to - TIniFile. } - - PIniFile = ^TIniFile; - -{ ---------------------------------------------------------------------- - TIniFile - store/load data to ini-files ------------------------------------------------------------------------ } - TIniFile = object( TObj ) - {* Ini file incapsulation. The main feature is what the same block of - read-write operations could be defined (difference must be only in - Mode value). - |*Ini file sample. - This sample shows how the same Pascal operators can be used both - for read and write for the same variables, when working with TIniFile: - ! procedure ReadWriteIni( Write: Boolean ); - ! var Ini: PIniFile; - ! begin - ! Ini := OpenIniFile( 'MyIniFile.ini' ); - ! Ini.Section := 'Main'; - ! if Write then // if Write, the same operators will save - ! Ini.Mode := ifmWrite; // data rather then load. - ! MyForm.Left := Ini.ValueInteger( 'Left', MyForm.Left ); - ! MyForm.Top := Ini.ValueInteger( 'Top', MyForm.Top ); - ! Ini.Free; - ! end; - ! - |* } - protected - fMode: TIniFileMode; - fFileName: KOLString; - fSection: KOLString; - protected - public - destructor Destroy; virtual; - {* destructor } - property Mode: TIniFileMode read fMode write fMode; - {* ifmWrite, if write data to ini-file rather than read it. } - property FileName: KOLString read fFileName; - {* Ini file name. } - property Section: KOLString read fSection write fSection; - {* Current ini section. } - function ValueInteger( const Key: KOLString; Value: Integer ): Integer; - {* Reads or writes integer data value. } - function ValueString( const Key: KOLString; const Value: KOLString ): KOLString; - {* Reads or writes string data value. } - function ValueDouble( const Key: KOLString; const Value: Double ): Double; - {* Reads or writes Double data value. } - function ValueBoolean( const Key: KOLString; Value: Boolean ): Boolean; - {* Reads or writes Boolean data value. } - function ValueData( const Key: KOLString; Value: Pointer; Count: Integer ): Boolean; - {* Reads or writes data from/to buffer. Returns True, if success. } - procedure ClearAll; - {* Clears all sections of ini-file. } - procedure ClearSection; - {* Clears current Section of ini-file. } - procedure ClearKey( const Key: KOLString ); - {* Clears given key in current section. } - - /////////////// + by Vyacheslav A. Gavrik: - procedure GetSectionNames(Names:PKOLStrList); - {* Retrieves section names, storing it in string list passed as a parameter. - String list does not cleared before processing. Section names are added - to the end of the string list. } - procedure SectionData(Names:PKOLStrList); - {* Read/write current section content to/from string list. (Depending on - current Mode value). } - /////////////// - - end; - -function OpenIniFile( const FileName: KOLString ): PIniFile; -{* Opens ini file, creating TIniFile object instance to work with it. } -{$ENDIF WIN_GDI} - -type - TMenuitemInfo = packed record - cbSize: UINT; - fMask: UINT; - fType: UINT; { used if MIIM_TYPE} - fState: UINT; { used if MIIM_STATE} - wID: UINT; { used if MIIM_ID} - hSubMenu: HMENU; { used if MIIM_SUBMENU} - hbmpChecked: HBITMAP; { used if MIIM_CHECKMARKS} - hbmpUnchecked: HBITMAP; { used if MIIM_CHECKMARKS} - dwItemData: DWORD; { used if MIIM_DATA} - dwTypeData: PKOLChar; { used if MIIM_TYPE} - cch: UINT; { used if MIIM_TYPE} - hbmpItem: HBITMAP; { used if MIIM_BITMAP - not exists under Windows95 } - end; - -const - TPM_HORPOSANIMATION = $0400; - TPM_HORNEGANIMATION = $0800; - TPM_VERPOSANIMATION = $1000; - TPM_VERNEGANIMATION = $2000; - TPM_NOANIMATION = $4000; - -type - PMenu = ^TMenu; - - TOnMenuItem = procedure( Sender : PMenu; Item : Integer ) of object; - {* Event type to define OnMenuItem event. } - - TMenuAccelerator = packed Record - {* Menu accelerator record. Use MakeAccelerator function to combine desired - attributes into a record, describing the accelerator. } - fVirt: Byte; // or-combination of FSHIFT, FCONTROL, FALT, FVIRTKEY, FNOINVERT - Key: Word; // character or virtual key code (FVIRTKEY flag is present above) - NotUsed: Byte; // not used - end; - - // by Sergey Shisminzev: - TMenuOption = (moDefault, moDisabled, moChecked, - moCheckMark, moRadioMark, moSeparator, moBitmap, moSubMenu, - moBreak, moBarBreak); - {* Options to add menu items dynamically. } - TMenuOptions = set of TMenuOption; - {* Set of options for menu item to use it in TMenu.AddItem method. } - - TMenuBreak = ( mbrNone, mbrBreak, mbrBarBreak ); - {* Possible menu item break types. } - -{ ---------------------------------------------------------------------- - TMenu - main, popup menu and menu item ------------------------------------------------------------------------ } - TMenu = object( TObj ) - protected - {$IFDEF GDI} - function GetItemHelpContext(Idx: Integer): Integer; - procedure SetItemHelpContext(Idx: Integer; const Value: Integer); - {* Dynamic menu incapsulation object. Can play role of form main menu or popup - menu, depending on kind of parent window (form or control) and order of - creation (created first (for a form) become main menu). Does not allow - merging menus, but items can be hidden. Additionally checkmark bitmaps, - shortcut key accelerators and other features are available. } - protected - FHandle: HMenu; - FId: Integer; - FControl: PControl; - {$ENDIF GDI} - fNextMenu : PMenu; - {$IFDEF GDI} - FMenuBreak: TMenuBreak; - FOnMenuItem : TOnMenuItem; - FOnRadioOff : TOnMenuItem; - fOnPopup: TOnEvent; - fByAccel: Boolean; - FIsCheckItem: Boolean; - FIsSeparator: Boolean; - FVisible: Boolean; - FOwnerDraw: Boolean; - FClearBitmaps: Boolean; - FNotPopup: Boolean; - f_DummyFiller: Byte; - FPopupFlags: DWORD; - FSavedState: DWORD; - FData: Pointer; - {$ENDIF GDI} - FParentMenu: PMenu; - FMenuItems: PList; - FRadioGroup: Integer; - FCaption: KOLString; - {$IFDEF _X_} - {$IFDEF GTK} - fChecked: Boolean; - fMnemonics: AnsiString; - fGtkMenuItem: PGtkWidget; - fGtkMenuShell: PGtkWidget; - fGtkMenuBar: PGtkWidget; - {$ENDIF GTK} - {$ENDIF _X_} - {$IFDEF GDI} - FBitmap: HBitmap; - FBmpChecked: HBitmap; - FBmpItem: HBitmap; - ClearBitmapsProc: procedure( Sender: PMenu ); - FAccelerator: TMenuAccelerator; - FHelpContext: Integer; - FOnMeasureItem: TOnMeasureItem; - FOnDrawItem: TOnDrawItem; - {$IFDEF USE_MENU_CURCTL} - fCurCtl: PControl; - {$ENDIF USE_MENU_CURCTL} - function GetItems( Id: HMenu ): PMenu; - function GetCount: Integer; - function GetTopParent: PMenu; - function GetState( const Index: Integer ): Boolean; - procedure SetState( const Index: Integer; Value: Boolean ); - procedure SetMenuVisible( Value: Boolean ); - procedure SetData( Value: Pointer ); - procedure SetMenuItemCaption( const Value: KOLString ); - function FillMenuItems(AHandle: HMenu; StartIdx: Integer; - const Template: array of PKOLChar): Integer; - procedure SetMenuBreak( Value: TMenuBreak ); - function GetControl: PControl; - function GetInfo( var MII: TMenuItemInfo ): Boolean; - function SetInfo( var MII: TMenuItemInfo ): Boolean; - function SetTypeInfo( var MII: TMenuItemInfo ): Boolean; - procedure SetBitmap( Value: HBitmap ); - procedure SetBmpChecked( Value: HBitmap ); - procedure SetBmpItem( Value: HBitmap ); - procedure ClearBitmaps; - procedure SetAccelerator( const Value: TMenuAccelerator ); - {$IFDEF GDI} - procedure SetHelpContext( Value: Integer ); - {$ENDIF GDI} - procedure SetSubmenu( Value: HMenu ); - procedure SetOnMeasureItem( const Value: TOnMeasureItem ); - procedure SetOnDrawItem( const Value: TOnDrawItem ); - procedure SetOwnerDraw( Value: Boolean ); - protected - function GetItemChecked( Item : Integer ) : Boolean; - procedure SetItemChecked( Item : Integer; Value : Boolean ); - function GetItemBitmap(Idx: Integer): HBitmap; - procedure SetItemBitmap(Idx: Integer; const Value: HBitmap); - function GetItemText(Idx: Integer): KOLString; - procedure SetItemText(Idx: Integer; const Value: KOLString); - function GetItemEnabled(Idx: Integer): Boolean; - procedure SetItemEnabled(Idx: Integer; const Value: Boolean); - function GetItemVisible(Idx: Integer): Boolean; - procedure SetItemVisible(Idx: Integer; const Value: Boolean); - function GetItemAccelerator(Idx: Integer): TMenuAccelerator; - procedure SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator); - function GetItemSubMenu( Idx: Integer ): HMenu; - {$ENDIF GDI} - public - destructor Destroy; virtual; - {* To release menu dynamically, call Free method instead. All (popup) - menus created after this (for the same control) are destroyed in - that case too. - |
- It is not necessary to release menu object manually: all menus, - created with given form (or control), are automatically released, - when owner form (or control) is destroyed. - } - {$IFDEF GDI} - property Handle : HMenu read FHandle; - {* Handle of Windows menu object. } - property MenuId: Integer read FId; - {* Id of the menu item object. If menu item has subitems, it has - also submenu Handle. Top parent menu object itself has no Id. - Id-s areassigned automatically starting from 4096. Do not - (re)create menu items instantly, because such values are not - reused, and maximum possible Id value must not exceed 65535. } - property Parent: PMenu read FParentMenu; - {* Parent menu item (or parent menu). } - property TopParent: PMenu read GetTopParent; - {* Top parent menu, owning all nested subitems. } - property Owner: PControl read GetControl; - {* Parent control or form. } - property Caption: KOLString read FCaption write SetMenuItemCaption; - {* Menu item caption text (including '&' indicating mnemonic characters, - and keyboard accelerator representation string, usually following - tabulation character). } - property Items[ Id: HMenu ]: PMenu read GetItems; - {* Returns menu item object by its index or by menu id. Since menu id - values are starting from 4096, values from 0 to 4095 are interpreted - as absolute index of menu item. Be careful accessing menu items or - submenus by index, if you dynamically insert or delete items or - submenus. In this version, separators are enumerating too, like - all other items. Use index -1 to access object itself. The first - item of a menu (or the first subitem of submenu item) has index 0. - Children are enumerating before all siblings. The maximum available - index is (Count - 1), when accessing menu items by index. } - property Count: Integer read GetCount; - {* Count of items together with all its nested subitems. } - function IndexOf( Item: PMenu ): Integer; - {* Returns index of an item. This index can be used to access - menu item. Value -2 is returned, if the Item is not a child for menu - or menu item, and has no parents, which are children for it, etc. - Menu object itself always has index -1. } - property OnMenuItem : TOnMenuItem read FOnMenuItem write FOnMenuItem; - {* Is called when menu item is clicked. Absolute index of menu item - clicked is passed as the second parameter. TopParent always is - passed as a Sender parameter. } - property ByAccel: Boolean read fByAccel; - {* True, when OnMenuItem is called not by mouse, but by accelerator key. - Check this flag for entire menu (TopParent), not for item itself. - (Note, that Sender in OnMenuItem always is TopParent menu object). ) - } - property IsSeparator: Boolean read FIsSeparator; - {* TRUE, if a separator menu item. } - property MenuBreak: TMenuBreak read FMenuBreak write SetMenuBreak; - {* Menu item break type. } - property OnUncheckRadioItem : TOnMenuItem read FOnRadioOff write FOnRadioOff; - {* Is called when radio item becomes unchecked in menu in result of - checking another radio item of the same radio group. } - property RadioGroup: Integer read FRadioGroup write FRadioGroup; - {* Radio group index. Several neighbour items with the same radio group - index form radio group. Only single item from the same group can be - checked at a time. } - property IsCheckItem: Boolean read FIsCheckItem; - {* If menu item is defined as check item, it is checked automatically - when clicked. } - procedure RadioCheckItem; - {* Call this method to check radio item. (Calling this method for - an item, which is not belonging to a radio group, just sets its - Checked state to TRUE). } - property Checked: Boolean index MFS_CHECKED read GetState write SetState; - {* Checked state of the item. } - property Enabled: Boolean - {$IFDEF F_P} - index $80000000 or MFS_DISABLED - {$ELSE DELPHI} - index Integer( $80000000 or MFS_DISABLED ) - {$ENDIF F_P/DELPHI} - read GetState write SetState; - {* Enabled state of the item. Whaen assigned, Grayed state also is - set to arbitrary value (i.e., when Enabled is set to true, Grayed - is set to FALSE. } - property DefaultItem: Boolean index MFS_DEFAULT read GetState write SetState; - {* Set this property to TRUE to make menu item default. Default item - is drawn with bold. - |
If you change DefaultItem at run-time and whant - to provide changing its visual state, recreate the item first resetting - Visible property, then setting it again. } - property Highlight: Boolean index MFS_HILITE read GetState write SetState; - {* Highlight state of the item. } - property Visible: Boolean read FVisible write SetMenuVisible; - {* Visibility of menu item. } - property Data: Pointer read FData write SetData; - {* Data pointer, associated with the menu item. } - property Bitmap: HBitmap read FBitmap write SetBitmap; - {* Bitmap used for unchecked state of the menu item. } - property BitmapChecked: HBitmap read FBmpChecked write SetBmpChecked; - {* Bitmap used for checked state of the menu item. } - property BitmapItem: HBitmap read FBmpItem write SetBmpItem; - {* Bitmap used for item itself. In addition, following special values - are possible: - HBMMENU_CALLBACK, HBMMENU_MBAR_CLOSE, HBMMENU_MBAR_CLOSE_D, - HBMMENU_MBAR_MINIMIZE, HBMMENU_MBAR_MINIMIZE_D, HBMMENU_MBAR_RESTORE, - HBMMENU_POPUP_CLOSE, HBMMENU_POPUP_MAXIMIZE, HBMMENU_POPUP_MINIMIZE, - HBMMENU_POPUP_RESTORE, HBMMENU_SYSTEM. } - property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator; - {* Accelerator for menu item. } - {$IFDEF GDI} - property HelpContext: Integer read FHelpContext write SetHelpContext; - {* Help context for entire menu (help context can not be assigned to - individual menu items). } - {$ENDIF GDI} - - procedure AssignEvents( StartIdx: Integer; const Events: array of TOnMenuItem ); - {* It is possible to assign its own event handler to every menu item - using this call. This procedure also is called automatically in - a constructor NewMenuEx. } - - function Popup( X, Y : Integer ): Integer; {!ecm} - {* Only for popup menu - to popup it at the given position on screen. - Return: If you specify TPM_RETURNCMD in the uFlags parameter, the return - value is the menu-item identifier of the item that the user selected. - If the user cancels the menu without making a selection, or if an error - occurs, then the return value is zero. - If you do not specify TPM_RETURNCMD in the uFlags parameter, the return - value is nonzero if the function succeeds and zero if it fails. } - function PopupEx( X, Y: Integer ): Integer; {!ecm} - {* This version of popup command is very useful, when popup menu is activated - when its parent window is not visible (e.g., for a kind of applications, - which always are invisible, and can be activated only using tray icon). - PopupEx method provides correct tracking of menu disappearing when mouse - is clicked anywhere else on screen, fixing strange menu behavior in some - Windows versions (NT). - |
- Actually, when PopupEx used, parent form is shown but below of visible - screen, and when menu is disappearing, previous state of the form (visibility - and position) are restored. If such solvation is not satisfying You, - You can do something else (e.g., use region clipping, etc.) } - property OnPopup: TOnEvent read fOnPopup write fOnPopup; - {* This event occurs before the popup menu is shown. } - property NotPopup: Boolean read FNotPopup write FNotPopup; - {* Set this property to true to prevent popup of popup menu, e.g. in - OnPopup event handler. } - property Flags: DWORD read FPopupFlags write FPopupFlags; - {* Pop-up flags, which are used to call TrackPopupMenuEx, when Popup or - PopupEx method is called. Can be a combination of following values: - |
- TPM_CENTERALIGN or TPM_LEFTALIGN or TPM_RIGHTALIGN - |
- TPM_BOTTOMALIGN or TPM_TOPALIGN or TPM_VCENTERALIGN - |
- TPM_NONOTIFY or TPM_RETURNCMD - |
- TPM_LEFTBUTTON or TPM_RIGHTBUTTON - |
- TPM_HORNEGANIMATION or TPM_HORPOSANIMATION or TPM_NOANIMATION or - TPM_VERNEGANIMATION or TPM_VERPOSANIMATION - |
- TPM_HORIZONTAL or TPM_VERTICAL. - |
- By default, a combination TPM_LEFTALIGN or TPM_LEFTBUTTON is used. } - function Insert(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; - Options: TMenuOptions): PMenu; - {* Inserts new menu item before item, given by Id (>=4096) or index - value InsertBefore. Pointer to an object created is returned. } - property SubMenu: HMenu read FHandle; // write SetSubMenu; - {* Submenu associated with the menu item. The same as Handle. It was possible - in ealier versions to change this value, replacing (removing, assigning) - entire popup menu as a submenu for menu item. - But in modern version of TMenu, this is not possible. - Instead, entire menu object should be added or removed using - InsertSubmenu or RemoveSubmenu methods. } - procedure InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer ); - {* Inserts existing menu item (together with its subitems if any present) - into given position. See also RemoveSubMenu. } - function RemoveSubMenu( ItemToRemove: Integer ): PMenu; - {* Removes menu item from the menu, returning TMenu object, representing it, - if submenu item, having its own children, detached. If an individual menu - item is removed, nil is returned. - This function can be useful to add or remove dynamically entire submenus - (created together with its subitems). } - property OnMeasureItem: TOnMeasureItem read FOnMeasureItem write SetOnMeasureItem; - {* This event is called for owner-drawn menu items. Event handler should return - menu item height in lower word of a result and item width (for menu) in - high word of result. If either for height or for width returned value is 0, - a default one is used. } - property OnDrawItem: TOnDrawItem read FOnDrawItem write SetOnDrawItem; - {* This event is called for owner-drawn menu items. } - property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw; - {* Set this property to true for some items to make it owner-draw. } - - // For compatibility with old code (be sure that item with given index - // actually exists): - function GetMenuItemHandle( Idx : Integer ): DWORD; - {* Returns Id of menu item with given index. } - property ItemHandle[ Idx: Integer ]: DWORD read GetMenuItemHandle; - {* Returns handle for item given by index. } - property ItemChecked[ Idx : Integer ] : Boolean read GetItemChecked write SetItemChecked; - {* True, if correspondent menu item is checked. } - procedure RadioCheck( Idx : Integer ); - {* Call this method to check radio item. For radio items, do not - use assignment to ItemChecked or Checked properties. } - property ItemBitmap[ Idx: Integer ]: HBitmap read GetItemBitmap write SetItemBitmap; - {* This property allows to assign bitmap to menu item (for unchecked state - only - for checked menu items default checkmark bitmap is used). } - procedure AssignBitmaps( StartIdx: Integer; Bitmaps: array of HBitmap ); - {* Can be used to assign bitmaps to several menu items during one call. } - property ItemText[ Idx: Integer ]: KOLString read GetItemText write SetItemText; - {* This property allows to get / modify menu item text at run time. } - property ItemEnabled[ Idx: Integer ]: Boolean read GetItemEnabled write SetItemEnabled; - {* Controls enabling / disabling menu items. Disabled menu items are - displayed (grayed) but inaccessible to click. } - property ItemVisible[ Idx: Integer ]: Boolean read GetItemVisible write SetItemVisible; - {* This property allows to simulate visibility of menu items (implementing - it by removing or inserting again if needed. For items of submenu, which - is made invisible, True is returned. If such item made Visible, entire - submenu with all its parent menu items becomes visible. To release menu - properly it is necessary to make before all its items visible again. - This does not matter, if menu is released at the end of execution, but - can be sensible if owner form is destroyed and re-created at run time - dynamically. } - property ItemHelpContext[ Idx: Integer ]: Integer read GetItemHelpContext - write SetItemHelpContext; - function ParentItem( Idx: Integer ): Integer; - {* Returns index of parent menu item (for submenu item). If there are no - such item (Idx corresponds to root level menu item), -1 is returned. } - property ItemAccelerator[ Idx: Integer ]: TMenuAccelerator read GetItemAccelerator write SetItemAccelerator; - {* Allows to get / change accelerator key kodes assigned to menu items. - Has no effect unless SupportMnemonics called for a form. } - property ItemSubmenu[ Idx: Integer ]: HMenu read GetItemSubmenu; // write SetItemSubmenu; - {* Retrieves submenu item dynamically. See also SubMenu property. } - - // by Sergey Shisminzev: - function AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer; - {* Adds menu item dynamically. Returns ID of the added item. } - function InsertItem(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer; - {* Inserts menu item before an item with ID, given by InsertBefore parameter. } - function InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions; - ByPosition: Boolean): Integer; - {* Inserts menu item by command or by position, dependant on ByPosition parameter } - procedure RedrawFormMenuBar; - {* } - - {$IFDEF USE_MENU_CURCTL} - property CurCtl: PControl read fCurCtl write fCurCtl; - {* By Alexander Pravdin. This property is assigned to a control which were - initiated a pop-up, for popup menu. } - {$ENDIF USE_MENU_CURCTL} - {$ENDIF GDI} - end; - -{$IFDEF WIN_GDI} -function MenuStructSize: Integer; -{* Returns 44 under Windows95, and 48 (=sizeof(TMenuItemInfo) under all other - Windows versions. } - -var FDynamicMenuID: DWORD = $1000; -{$ENDIF WIN_GDI} -function NewMenu( AParent : PControl; MaxCmdReserve: DWORD; - const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu; -{* Menu constructor. First created menu becomes main menu of form (if AParent - is a form). All other menus becomes popup (can be activated using Popup - method). To provide dynamic replacing of main menu, create all popup - menus as children of any other control, not form itself. - When Menu is created, pass FirstCmd integer value to set it - as ID of first menu item (all other ID's obtained by incrementing this value), - and Template, which is an array of PChar (usually array of string constants), - containing list of menu item identifiers and/or formatting characters. -|
    - FirstCmd value is assigned to first menu item created as its ID, - all follow menu items are assigned to ID's obtained from FirstCmd incrementing - it by 1. It is desirable to provide not intersected ranges of ID's for - defferent menus in the applet. -|
    - Following formatting characters can be used in menu template strings: -|&L=
%1 - - to underline next character and use it as a shortcut character - when possible; - - to make item checked. If also -|! is used before - & -| than radioitem is defined; - - item not checked; - - separator (between two items); - - start of submenu; - - end of submenu; -|
    - To get access to menu items, use constants 0, 1, etc. It is a good idea - to create special enumerated type to index correspondent menu items - using Ord( ) operator. Note in that case, that it is necessary only to - define constants correspondent to identifiers (positions, correspondent - to separators or submenu brackets are not identified by numbers). -|
    -} - -function NewMenuEx( AParent : PControl; FirstCmd : Integer; - const Template : array of PKOLChar; aOnMenuItems: array of TOnMenuItem ): PMenu; -{* Creates menu, assigning its own event handler for every (enough) menu item. } -{$IFDEF WIN_GDI} - -function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator; -{* Creates accelerator item to assign it to TMenu.ItemAccelerator[ ] property - easy.} - -// {YS} added 7 Aug 2004 -function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLString; -{* Returns text representation of accelerator. - |
- - -} -type - TWindowChildKind = ( wcActive, wcFocus, wcCapture, wcMenuOwner, - wcMoveSize, wcCaret ); - {* Type of window child kind. Used in function GetWindowChild. } - -function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd; -{* Returns child of given top-level window, having given characteristics. - For example, it is possible to get know for foreground window, - which of its child window has focus. This function does not work in old - Windows 95 (returns Wnd in that case). But for Windows 98, Windows NT/2000 - this function works fine. To obtain focused child of the window, - use GetFocusedWindow, which is independant from Windows version. } - -function GetFocusedChild( Wnd: HWnd ): HWnd; -{* Returns focused child of given window (which should be foreground - and active, certainly). 0 is returned either if Wnd is not active - or Wnd has no focused child window. } - -function Stroke2Window( Wnd: HWnd; const S: AnsiString ): Boolean; -{* Posts characters from string S to those child window of Wnd, which - has focus now (top-level window Wnd must be foreground, and have - focused edit-aware control to receive the stroke). - |
- This function allows only to post typeable characters (including - such special symbols as #13 (Enter), #9 (Tab), #8 (BackSpace), etc. - |
- See also function Stroke2WindowEx, which allows to post any key down - and up events, simulating keyboard for given (automated) application. } - -function Stroke2WindowEx( Wnd: HWnd; const S: AnsiString; Wait: Boolean ): Boolean; -{* In addition to function Stroke2Window, this one can send special keys - to given window, including functional keys and navigation keys. To - post special key to target window, place a combination of names of - such key together with keys, which should be passed simultaneously, - between square or figure brackets. For example, [Ctrl F1], [Alt Shift Home], - [Ctrl E]. For letters and usual characters, it is not necessary to - simulate pressing it with determining all Shift combinations and it is - sufficient to pass characters as is. (E.g., not '[Shift 1]', but '!'). } - -function FindWindowByThreadID( ThreadID : DWORD ) : HWnd; -{* Searches for window, belonging to a given thread. } - -function DesktopPixelFormat: TPixelFormat; -{* Returns the pixel format correspondent to current desktop color resolution. - Use this function to decide which format to use for converting bitmap, - planned to draw transparently using TBitmap.DrawTransparent or - TBitmap.StretchDrawTransparent methods. } - -function GetDesktopRect : TRect; -{* Returns rectangle of screen, free of taskbar and other - similar app-bars, which reduces size of available desktop - when created. } -function GetWorkArea: TRect; -{* The same as GetDesktopRect, but obtained calling SystemParametersInfo. } - -function ExecuteWait( const AppPath, CmdLine, DfltDirectory: KOLString; - Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean; -{* Allows to execute an application and wait when it is finished. Pass - INFINITE constant as TimeOut, if You sure that application is finished - anyway. If another value passed as a TimeOut (in milliseconds), and - application was not finished for that time, ExecuteWait is returning - FALSE, and if ProcID is not nil, than ProcID^ contains started process - handle (it can be used to wait it more, or to terminate it using - TerminateProcess API function). - |
- Launching application can be console or GUI - it does not matter. - Pass SW_SHOW, SW_HIDE or other SW_XXX constant as Show parameter - as appropriate. - |
- True is returned only in case when application specified was launched - successfully and finished for TimeOut specified. Otherwise, check - ProcID^ variable: if it is 0, process could not be launched (and it - is possible to get information about error using GetLastError API - function in a such case). You can freely pass nil in place of ProcID - parameter, but this is acually correct only when TimeOut is INFINITE. } -function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString; - Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean; -{* Executes an application with its console input and output redirection. - Terminating of the application is not waiting, but if ProcID pointer - is defined, it receives process Id launched, so it is possible to - call WaitForSingleObject for it. InPipe is a pointer to THandle variable - which receives a handle to input pipe of the console redirected. The same - is for OutPipeWr and OutPipeRd, but for output of the console redirected. - Before reading from OutPipeRd^, first close OutPipeWr^. If you run - simple console application, for which you want to read results after its - termination, you can use ExecuteConsoleAppIORedirect instead. - |
    - Notes: if your application is not console and it does not create console - using AllocConsole, this function will fail to redirect input-output. } -function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString; - Show: DWORD; const InStr: KOLString; var OutStr: KOLString; WaitTimeout: DWORD ) - : Boolean; -{* Executes an application, redirecting its console input and output. - After redirecting input and output and launching the application, - content of InStr is written to input stream of the application, then - the application is waiting for its termination (WaitTimeout milliseconds - or INFINITE, as passed) and console output of the application is read to - OutStr. TRUE is returned only in case, when all these tasks are - completed successfully. - |
    - Notes: if your application is not console and it does not create console - using AllocConsole, this function will fail to redirect input-output. } - -function WindowsShutdown( const Machine : KOLString; Force, Reboot : Boolean ) : Boolean; -{* Shut down of Windows NT. Pass Machine = '' to shutdown this PC. - Pass Reboot = True to reboot immediatelly after shut down. } -function WindowsLogoff( Force : Boolean ) : Boolean; -{* Logoff of Windows. } - - -type - TWindowsVersion = ( wv31, wv95, wv98, wvME, wvNT, wvY2K, wvXP, wvServer2003, - wvVista, wvSeven ); - {* Windows versions constants. } - TWindowsVersions = Set of TWindowsVersion; - {* Set of Windows version (e.g. to define a range of versions supported by the - application). } - -function WinVer : TWindowsVersion; -{* Returns Windows version. } -function IsWinVer( Ver : TWindowsVersions ) : Boolean; -{* Returns True if Windows version is in given range of values. } -{$IFNDEF PARAMS_DEFAULT} -function SkipParam(P: PKOLChar): PKOLChar; //forward; -function ParamStr( Idx: Integer ): KOLString; -{* Returns command-line parameter by index. This function supersides - standard ParamStr function. } -function ParamCount: Integer; -{* Returns number of parameters in command line. -|
-} -{$ENDIF} -{$ENDIF WIN_GDI} - -{$IFDEF INPACKAGE} - {$IFDEF ASM_VERSION} - {$UNDEF ASM_VERSION} - {$ENDIF} -{$ENDIF} - -{$IFDEF WIN_GDI} -//{$DEFINE CHK_BITBLT} -{$IFDEF CHK_BITBLT} -procedure Chk_BitBlt; -{$ENDIF} -{$IFDEF ASM_VERSION} - {$DEFINE ASM_DC} -{$ENDIF} -{$IFDEF ASM_DC} -procedure StartDC; -procedure FinishDC; -{$ENDIF ASM_VERSION} - -function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; - -var CreatingWindow: PControl; - //ActiveWindow: HWnd; -{$ENDIF WIN_GDI} -{$IFDEF _D2} -// Assert operator was not available in Delphi2. Provide here easy Assert -// procedure for Delphi2. -procedure Assert( Cond: Boolean; const Msg: AnsiString ); - -var AssertErrorProc: procedure( const Message, Filename: AnsiString; LineNumber: Integer ); -{$ENDIF} - -{$IFDEF USE_CUSTOMEXTENSIONS} - {$I CUSTOM_KOL_EXTENSION.inc} // See comments in TControl -{$ENDIF} - -{$IFDEF DEBUG_ENDSESSION} -var EndSession_Initiated: Boolean; -{$ENDIF} - -{$IFDEF WIN_GDI} -var - FMMNotify: procedure( var Msg: TMsg ); - -procedure ClearText( Sender: PControl ); -procedure ClearListbox( Sender: PControl ); -procedure ClearCombobox( Sender: PControl ); -procedure ClearListView( Sender: PControl ); -procedure ClearTreeView( TV: PControl ); - -{$IFDEF COMMANDACTIONS_OBJ} -const OTHER_ACTIONS = 0; - LABEL_ACTIONS = 1; - BUTTON_ACTIONS = 2; - EDIT_ACTIONS = 3; - LIST_ACTIONS = 4; - COMBO_ACTIONS = 5; - LISTVIEW_ACTIONS = 6; - TREEVIEW_ACTIONS = 7; - TABCONTROL_ACTIONS = 8; - RICHEDIT_ACTIONS = 9; - PROGRESS_ACTIONS = 10; - TOOLBAR_ACTIONS = 11; - LAST_ACTIONS = 11; -var AllActions_Objs: array[ 0..LAST_ACTIONS ] of PCommandActionsObj; -{$ENDIF} - -const - {$IFDEF PACK_COMMANDACTIONS} - ButtonActions_Packed: PAnsiChar = Char(BUTTON_ACTIONS) + - #0#0 + //BN_CLICKED - #6#0 + //BN_SETFOCUS - #7#0 + //BN_KILLFOCUS - #225 + //25 нулей - #0#1 + //BS_LEFT - #0#2 + //BS_RIGHT - #0#3 + //BS_CENTER - #0#4 + //0, BS_TOP>>8 - #12#8+ // BS_VCENTER>>8, BS_BOTTOM>>8 - #204 //4 нуля - ; - {$ELSE} - ButtonActions: TCommandActions = ( - aClear: ClearText; - aAddText: nil; - aClick: BN_CLICKED; - aEnter: BN_SETFOCUS; - aLeave: BN_KILLFOCUS; - aChange: 0; - aSelChange: 0; - aGetCount: 0; - aSetCount: 0; - aGetItemLength: 0; - aGetItemText: 0; - aSetItemText: 0; - aGetItemData: 0; - aSetItemData: 0; - aAddItem: 0; - aDeleteItem: 0; - aInsertItem: 0; - aFindItem: 0; - aFindPartial: 0; - bItem2Pos: 0; - bPos2Item: 0; - aGetSelCount: 0; - aGetSelected: 0; - aGetSelRange: 0; - aGetCurrent: 0; - aSetSelected: 0; - aSetCurrent: 0; - aSetSelRange: 0; - aExSetSelRange: 0; - aGetSelection: 0; - aReplaceSel: 0; - aTextAlignLeft: BS_LEFT; - aTextAlignRight: BS_RIGHT; - aTextAlignCenter: BS_CENTER; - bTextAlignMask: 0; - bVertAlignTop: BS_TOP shr 8; //=4 - bVertAlignCenter: BS_VCENTER shr 8; //=12 - bVertAlignBottom: BS_BOTTOM shr 8; //=8 - aDir: 0; - aSetLimit: 0; - aSetImgList: 0; - //-----aAutoSzX: 14; - //-----aAutoSzY: 6; - aSetBkColor: 0; - ); - {$ENDIF} - -const - {$IFDEF PACK_COMMANDACTIONS} - LabelActions_Packed: PAnsiChar = Char( LABEL_ACTIONS ) + - #229 + //29 нулей - #2#0 + // SS_RIGHT - #1#0 + // SS_CENTER - #12#0 + // SS_LEFTNOWORDWRAP, 0 - #2#0 + // SS_CENTERIMAGE>>8, 0 - #205; - {$ELSE} - LabelActions: TCommandActions = ( - aClear: ClearText; - aAddText: nil; - aClick: 0; - aEnter: 0; - aLeave: 0; - aChange: 0; - aSelChange: 0; - aGetCount: 0; - aSetCount: 0; - aGetItemLength: 0; - aGetItemText: 0; - aSetItemText: 0; - aGetItemData: 0; - aSetItemData: 0; - aAddItem: 0; - aDeleteItem: 0; - aInsertItem: 0; - aFindItem: 0; - aFindPartial: 0; - bItem2Pos: 0; - bPos2Item: 0; - aGetSelCount: 0; - aGetSelected: 0; - aGetSelRange: 0; - aGetCurrent: 0; - aSetSelected: 0; - aSetCurrent: 0; - aSetSelRange: 0; - aExSetSelRange: 0; - aGetSelection: 0; - aReplaceSel: 0; - aTextAlignLeft: SS_LEFT; - aTextAlignRight: SS_RIGHT; - aTextAlignCenter: SS_CENTER; - bTextAlignMask: SS_LEFTNOWORDWRAP; - bVertAlignTop: 0; - bVertAlignCenter: SS_CENTERIMAGE shr 8; - bVertAlignBottom: 0; - aDir: 0; - aSetLimit: 0; - aSetImgList: 0; - //---- aAutoSzX: 1; - //---- aAutoSzY: 1; - aSetBkColor: 0; - ); - {$ENDIF} - -const - EN_LINK = $070b; - {$IFDEF PACK_COMMANDACTIONS} - EditActions_Packed: PAnsiChar = Char( EDIT_ACTIONS ) + - #201 + - #0#1 + // EN_SETFOCUS - #0#2 + // EN_KILLFOCUS - #0#3 + // EN_CHANGE - #201 + - #$BA#0 + // EM_GETLINECOUNT - #201 + - #$C1#0 + // EM_LINELENGTH - #$C4#0 + // EM_GETLINE - #$C2#0 + // EM_REPLACESEL - #207 + - #$BB#$C9 + // EM_LINEINDEX, EM_LINEFROMCHAR - #$B0#0 + // EM_GETSEL - #201 + - #$B0#0 + // EM_GETSEL - #$BB#0 + // EM_LINEINDEX - #202 + - #$B1#0 + // EM_SETSEL - #202 + - #$C2#0 + // EM_REPLACESEL - #201 + // ES_LEFT - #2#0 + // ES_RIGHT - #1#0 + // ES_CENTER - #203 + - #$C5#0 + // EM_SETLIMITTEXT - #202 + - #200#214#0; // EM_POSFROMCHAR - {$ELSE} - EditActions: TCommandActions = ( - aClear: ClearText; - aAddText: nil; - aClick: 0; - aEnter: EN_SETFOCUS; - aLeave: EN_KILLFOCUS; - aChange: EN_CHANGE; - aSelChange: 0; - aGetCount: EM_GETLINECOUNT; - aSetCount: 0; - aGetItemLength: EM_LINELENGTH; - aGetItemText: EM_GETLINE; - aSetItemText: EM_REPLACESEL; - aGetItemData: 0; - aSetItemData: 0; - aAddItem: 0; - aDeleteItem: 0; - aInsertItem: 0; - aFindItem: 0; - aFindPartial: 0; - bItem2Pos: EM_LINEINDEX; - bPos2Item: EM_LINEFROMCHAR; - aGetSelCount: EM_GETSEL; - aGetSelected: 0; - aGetSelRange: EM_GETSEL; - aGetCurrent: EM_LINEINDEX; - aSetSelected: 0; - aSetCurrent: 0; - aSetSelRange: EM_SETSEL; - aExSetSelRange: 0; - aGetSelection: 0; - aReplaceSel: EM_REPLACESEL; - aTextAlignLeft: ES_LEFT; - aTextAlignRight: ES_RIGHT; - aTextAlignCenter: ES_CENTER; - bTextAlignMask: 0; - bVertAlignTop: 0; - bVertAlignCenter: 0; - bVertAlignBottom: 0; - aDir: 0; - aSetLimit: EM_SETLIMITTEXT; - aSetImgList: 0; - //---- aAutoSzX: 0; - //---- aAutoSzY: 6; - aSetBkColor: 0; - aItem2XY: EM_POSFROMCHAR; - ); - {$ENDIF} - -const - {$IFDEF PACK_COMMANDACTIONS} - ListActions_Packed: PAnsiChar = Char(LIST_ACTIONS) + - #2#0 + // LBN_DBLCLK - #4#0 + // LBN_SETFOCUS - #5#0 + // LBN_KILLFOCUS - #201 + - #1#0 + // LBN_SELCHANGE - #$8B#1 + // LB_GETCOUNT - #$A7#1 + // LB_SETCOUNT - #$8A#1 + // LB_GETTEXTLEN - #$89#1 + // LB_GETTEXT - #201 + - #$99#1 + // LB_GETITEMDATA - #$9A#1 + // LB_SETITEMDATA - #$80#1 + // LB_ADDSTRING - #$82#1 + // LB_DELETESTRING - #$81#1 + // LB_INSERTSTRING - #$A2#1 + // LB_FINDSTRINGEXACT - #$8F#1 + // LB_FINDSTRING - #201 + - #$90#1 + // LB_GETSELCOUNT - #$87#1 + // LB_GETSEL - #201 + - #$88#1 + // LB_GETCURSEL - #$85#1 + // LB_SETSEL - #$86#1 + // LB_SETCURSEL - #209 + - #$8D#1 + // LB_DIR - #203 + - #$98#1; // LB_GETITEMRECT - {$ELSE} - ListActions: TCommandActions = ( - aClear: ClearListbox; - aAddText: nil; - aClick: LBN_DBLCLK; - aEnter: LBN_SETFOCUS; - aLeave: LBN_KILLFOCUS; - aChange: 0; - aSelChange: LBN_SELCHANGE; - aGetCount: LB_GETCOUNT; - aSetCount: LB_SETCOUNT; - aGetItemLength: LB_GETTEXTLEN; - aGetItemText: LB_GETTEXT; - aSetItemText: 0; - aGetItemData: LB_GETITEMDATA; - aSetItemData: LB_SETITEMDATA; - aAddItem: LB_ADDSTRING; - aDeleteItem: LB_DELETESTRING; - aInsertItem: LB_INSERTSTRING; - aFindItem: LB_FINDSTRINGEXACT; - aFindPartial: LB_FINDSTRING; - bItem2Pos: 0; - bPos2Item: 0; - aGetSelCount: LB_GETSELCOUNT; - aGetSelected: LB_GETSEL; - aGetSelRange: 0; - aGetCurrent: LB_GETCURSEL; - aSetSelected: LB_SETSEL; - aSetCurrent: LB_SETCURSEL; - aSetSelRange: 0; - aExSetSelRange: 0; - aGetSelection: 0; - aReplaceSel: 0; - aTextAlignLeft: 0; - aTextAlignRight: 0; - aTextAlignCenter: 0; - bTextAlignMask: 0; - bVertAlignTop: 0; - bVertAlignCenter: 0; - bVertAlignBottom: 0; - aDir: LB_DIR; - aSetLimit: 0; - aSetImgList: 0; - //---- aAutoSzX: 0; - //---- aAutoSzY: 0; - aSetBkColor: 0; - aItem2XY: LB_GETITEMRECT; - ); - {$ENDIF} - -const - {$IFDEF PACK_COMMANDACTIONS} - ComboActions_Packed: PAnsiChar = Char(COMBO_ACTIONS) + - #2#0 + // CBN_DBLCLK - #3#0 + // CBN_SETFOCUS - #4#0 + // CBN_KILLFOCUS - #5#0 + // CBN_EDITCHANGE - #15#0 + // CM_CBN_SELCHANGE - #$46#1 + // CB_GETCOUNT - #201 + - #$49#1 + // CB_GETLBTEXTLEN - #$48#1 + // CB_GETLBTEXT - #201 + - #$50#1 + // CB_GETITEMDATA - #$51#1 + // CB_SETITEMDATA - #$43#1 + // CB_ADDSTRING - #$44#1 + // CB_DELETESTRING - #$4A#1 + // CB_INSERTSTRING - #$58#1 + // CB_FINDSTRINGEXACT - #$4C#1 + // CB_FINDSTRING - #202 + - #$47#1 + // CB_GETCURSEL - #201 + - #$47#1 + // CB_GETCURSEL - #201 + - #$4E#1 + // CB_SETCURSEL - #209 + - #$45#1 + // CB_DIR - #203; - {$ELSE} - ComboActions: TCommandActions = ( - aClear: ClearCombobox; - aAddText: nil; - aClick: CBN_DBLCLK; - aEnter: CBN_SETFOCUS; - aLeave: CBN_KILLFOCUS; - aChange: CBN_EDITCHANGE; - aSelChange: CM_CBN_SELCHANGE; - aGetCount: CB_GETCOUNT; - aSetCount: 0; - aGetItemLength: CB_GETLBTEXTLEN; - aGetItemText: CB_GETLBTEXT; - aSetItemText: 0; - aGetItemData: CB_GETITEMDATA; - aSetItemData: CB_SETITEMDATA; - aAddItem: CB_ADDSTRING; - aDeleteItem: CB_DELETESTRING; - aInsertItem: CB_INSERTSTRING; - aFindItem: CB_FINDSTRINGEXACT; - aFindPartial: CB_FINDSTRING; - bItem2Pos: 0; - bPos2Item: 0; - aGetSelCount: 0; - aGetSelected: CB_GETCURSEL; - aGetSelRange: 0; - aGetCurrent: CB_GETCURSEL; - aSetSelected: 0; - aSetCurrent: CB_SETCURSEL; - aSetSelRange: 0; - aExSetSelRange: 0; - aGetSelection: 0; - aReplaceSel: 0; - aTextAlignLeft: 0; //ES_LEFT; - aTextAlignRight: 0; //ES_RIGHT; - aTextAlignCenter: 0; //ES_CENTER; - bTextAlignMask: 0; - bVertAlignTop: 0; - bVertAlignCenter: 0; - bVertAlignBottom: 0; - aDir: CB_DIR; - aSetLimit: 0; - aSetImgList: 0; - //---- aAutoSzX: 0; - //---- aAutoSzY: 6; - aSetBkColor: 0; - ); - {$ENDIF} - -const - {$IFDEF PACK_COMMANDACTIONS} - ListViewActions_Packed: PAnsiChar = Char( LISTVIEW_ACTIONS ) + - #203 + - #$9B#$FF + // LVN_ITEMCHANGED - #201 + - #4#$10 + // LVM_GETITEMCOUNT - #47#$10 + // LVM_SETITEMCOUNT - //#211 + - #206 + #8#$10 // LVM_DELETEITEM - + #204 + - #50#$10 + // LVM_GETSELECTEDCOUNT - #44#$10 + // LVM_GETITEMSTATE - #201 + - #12#$10 + // LVM_GENEXTITEM - #213 + - #3#$10 + // LVM_SETIMAGELIST - #1#$10 + // LVM_SETBKCOLOR - #14#$10; // LVM_GETITEMRECT - {$ELSE} - ListViewActions: TCommandActions = ( - aClear: ClearListView; - aAddText: nil; - aClick: 0; - aEnter: 0; - aLeave: 0; - aChange: LVN_ITEMCHANGED; - aSelChange: 0; - aGetCount: LVM_GETITEMCOUNT; - aSetCount: LVM_SETITEMCOUNT; - aGetItemLength: 0; - aGetItemText: 0; - aSetItemText: 0; - aGetItemData: 0; - aSetItemData: 0; - aAddItem: 0; - aDeleteItem: LVM_DELETEITEM; - aInsertItem: 0; - aFindItem: 0; - aFindPartial: 0; - bItem2Pos: 0; - bPos2Item: 0; - aGetSelCount: { $8000 or} LVM_GETSELECTEDCOUNT; - aGetSelected: LVM_GETITEMSTATE; - aGetSelRange: 0; - aGetCurrent: LVM_GETNEXTITEM; - aSetSelected: 0; - aSetCurrent: 0; - aSetSelRange: 0; - aExSetSelRange: 0; - aGetSelection: 0; - aReplaceSel: 0; - aTextAlignLeft: 0; - aTextAlignRight: 0; - aTextAlignCenter: 0; - bTextAlignMask: 0; - bVertAlignTop: 0; - bVertAlignCenter: 0; - bVertAlignBottom: 0; - aDir: 0; - aSetLimit: 0; - aSetImgList: LVM_SETIMAGELIST; - //---- aAutoSzX: 0; - //---- aAutoSzY: 0; - aSetBkColor: LVM_SETBKCOLOR; - aItem2XY: LVM_GETITEMRECT; - ); - {$ENDIF} - -const - {$IFDEF PACK_COMMANDACTIONS} - TreeViewActions_Packed: PAnsiChar = Char( TREEVIEW_ACTIONS ) + - #203 + - {$IFDEF UNICODE_CTRLS} #$34#$FE {$ELSE} #$65#$FE {$ENDIF} + // TVN_ENDLABELEDIT(W) - {$IFDEF UNICODE_CTRLS} #$3E#$FE {$ELSE} #$6E#$FE {$ENDIF} + // TVN_SELCHANGED(W) - #5#$11 + // TVM_GETCOUNT - #207 + - #1#$11 + // TVM_DELETEITEM - #221 + - #9#$11 + // TVM_SETIMAGELIST - #29#$11 + // TVM_SETBKCOLOR - #4#$11; // TVM_GETITEMRECT - {$ELSE} - TreeViewActions: TCommandActions = ( - aClear: ClearTreeView; - aAddText: nil; - aClick: 0; - aEnter: 0; - aLeave: 0; - aChange: TVN_ENDLABELEDIT; - aSelChange: TVN_SELCHANGED; - aGetCount: TVM_GETCOUNT; - aSetCount: 0; - aGetItemLength: 0; - aGetItemText: 0; - aSetItemText: 0; - aGetItemData: 0; - aSetItemData: 0; - aAddItem: 0; - aDeleteItem: TVM_DELETEITEM; - aInsertItem: 0; - aFindItem: 0; - aFindPartial: 0; - bItem2Pos: 0; - bPos2Item: 0; - aGetSelCount: 0; - aGetSelected: 0; - aGetSelRange: 0; - aGetCurrent: 0; - aSetSelected: 0; - aSetCurrent: 0; - aSetSelRange: 0; - aExSetSelRange: 0; - aGetSelection: 0; - aReplaceSel: 0; - aTextAlignLeft: 0; - aTextAlignRight: 0; - aTextAlignCenter: 0; - bTextAlignMask: 0; - bVertAlignTop: 0; - bVertAlignCenter: 0; - bVertAlignBottom: 0; - aDir: 0; //CB_DIR; - aSetLimit: 0; - aSetImgList: TVM_SETIMAGELIST; - //---- aAutoSzX: 0; - //---- aAutoSzY: 0; - aSetBkColor: TVM_SETBKCOLOR; - aItem2XY: TVM_GETITEMRECT; - ); - {$ENDIF} - -const - {$IFDEF PACK_COMMANDACTIONS} - TabControlActions_Packed: PAnsiChar = Char( TABCONTROL_ACTIONS ) + - #203 + - #200#$D9#$FD + // TCN_SELCHANGE - #200#$D9#$FD + // TCN_SELCHANGE - #4#$13 + // TCM_GETITEMCOUNT - #215 + - #11#$13 + // TCM_GETCURSEL - #201 + - #12#$13 + // TCM_SETCURSEL - #211 + - #3#$13 + // TCM_SETIMAGELIST - #201 + - #10#$13; // TCM_GETITEMRECT - {$ELSE} - TabControlActions: TCommandActions = ( - aClear: ClearText; - aAddText: nil; - aClick: 0; - aEnter: 0; - aLeave: 0; - aChange: TCN_SELCHANGE; - aSelChange: TCN_SELCHANGE; - aGetCount: TCM_GETITEMCOUNT; - aSetCount: 0; - aGetItemLength: 0; - aGetItemText: 0; - aSetItemText: 0; - aGetItemData: 0; - aSetItemData: 0; - aAddItem: 0; - aDeleteItem: 0; - aInsertItem: 0; - aFindItem: 0; - aFindPartial: 0; - bItem2Pos: 0; - bPos2Item: 0; - aGetSelCount: 0; - aGetSelected: 0; - aGetSelRange: 0; - aGetCurrent: TCM_GETCURSEL; - aSetSelected: 0; - aSetCurrent: TCM_SETCURSEL; //TCM_SETCURFOCUS; - aSetSelRange: 0; - aExSetSelRange: 0; - aGetSelection: 0; - aReplaceSel: 0; - aTextAlignLeft: 0; - aTextAlignRight: 0; - aTextAlignCenter: 0; - bTextAlignMask: 0; - bVertAlignTop: 0; - bVertAlignCenter: 0; - bVertAlignBottom: 0; - aDir: 0; // CB_DIR; - aSetLimit: 0; - aSetImgList: TCM_SETIMAGELIST; - //---- aAutoSzX: 0; - //---- aAutoSzY: 0; - aSetBkColor: 0; - aItem2XY: TCM_GETITEMRECT; - ); - {$ENDIF} - -{$IFNDEF NOT_USE_RICHEDIT} -const - {$IFDEF PACK_COMMANDACTIONS} - RichEditActions_Packed: PAnsiChar = Char( RICHEDIT_ACTIONS ) + - #201 + - #0#1 + // EN_SETFOCUS - #0#2 + // EN_KILLFOCUS - #0#3 + // EN_CHANGE - #2#7 + // EN_SELCHANGE - #$BA#0 + // EM_GETLINECOUNT - #201 + - #$C1#0 + // EM_LINELENGTH - #$C4#0 + // EM_GETLINE - #$C2#0 + // EM_REPLACESEL - #207 + - #$BB#$C9 + // EM_LINEINDEX, EM_LINEFROMCHAR - #$B0#0 + // EM_GETSEL - #201 + - #$B0#0 + // EM_GETSEL - #$BB#0 + // EM_LINEINDEX - #203 + - #55#4 + // EM_EXSETSEL - #62#4 + // EM_GETSELTEXT - #$C2#0 + // EM_REPLACESEL - #201 + // ES_LEFT - #2#0 + // ES_RIGHT - #1#0 + // ES_CENTER - #203 + - #53#4 + // EM_EXLIMITTEXT - #201 + - #67#4 + // EM_SETBKGNDCOLOR - #200#214#0; // EM_POSFROMCHAR - {$ELSE} - RichEditActions: TCommandActions = ( - aClear: ClearText; - aAddText: nil; - aClick: 0; - aEnter: EN_SETFOCUS; - aLeave: EN_KILLFOCUS; - aChange: EN_CHANGE; - aSelChange: EN_SELCHANGE; - aGetCount: EM_GETLINECOUNT; - aSetCount: 0; - aGetItemLength: EM_LINELENGTH; - aGetItemText: EM_GETLINE; - aSetItemText: EM_REPLACESEL; - aGetItemData: 0; - aSetItemData: 0; - aAddItem: 0; - aDeleteItem: 0; - aInsertItem: 0; - aFindItem: 0; - aFindPartial: 0; - bItem2Pos: EM_LINEINDEX; - bPos2Item: EM_LINEFROMCHAR; - aGetSelCount: EM_GETSEL; - aGetSelected: 0; - aGetSelRange: EM_GETSEL; - aGetCurrent: EM_LINEINDEX; - aSetSelected: 0; - aSetCurrent: 0; - aSetSelRange: 0; - aExSetSelRange: EM_EXSETSEL; - aGetSelection: EM_GETSELTEXT; - aReplaceSel: EM_REPLACESEL; - aTextAlignLeft: ES_LEFT; - aTextAlignRight: ES_RIGHT; - aTextAlignCenter: ES_CENTER; - bTextAlignMask: 0; - bVertAlignTop: 0; - bVertAlignCenter: 0; - bVertAlignBottom: 0; - aDir: 0; - aSetLimit: EM_EXLIMITTEXT; - aSetImgList: 0; - //---- aAutoSzX: 0; - //---- aAutoSzY: 0; - aSetBkColor: EM_SETBKGNDCOLOR; - aItem2XY: EM_POSFROMCHAR; - ); - {$ENDIF} - -{$ENDIF NOT_USE_RICHEDIT} - -const - BaseFileMethods: TStreamMethods = ( - fSeek: SeekFileStream; - fGetSiz: GetSizeFileStream; - fSetSiz: DummySetSize; - fRead: DummyReadWrite; - fWrite: DummyReadWrite; - fClose: CloseFileStream; - fCustom: nil; - ); - - MemoryMethods: TStreamMethods = ( - fSeek: SeekMemStream; - fGetSiz: GetSizeMemStream; - fSetSiz: SetSizeMemStream; - fRead: ReadMemStream; - fWrite: WriteMemStream; - fClose: CloseMemStream; - fCustom: nil; - ); - - ConcatStreamMethods: TStreamMethods = ( - fSeek: SeekConcatStream; - fGetSiz: GetSizeConcatStream; - fSetSiz: SetSizeConcatStream; - fRead: ReadConcatStream; - fWrite: WriteConcatStream; - fClose: CloseConcatStream; - fCustom: nil; - ); - - SubStreamMethods: TStreamMethods = ( - fSeek: SeekSubStream; - fGetSiz: GetSizeSubStream; - fSetSiz: SetSizeSubStream; - fRead: ReadSubStream; - fWrite: WriteSubStream; - fClose: CloseSubStream; - fCustom: nil; - ); -{$ENDIF WIN_GDI} - -{$IFDEF DEBUG_MCK} -procedure dummy_Log( const s: AnsiString ); -var mck_Log: procedure( const s: AnsiString ) = dummy_Log; -{$ENDIF} - -type - TThemedElement = ( - teButton, - teClock, - teComboBox, - teEdit, - teExplorerBar, - teHeader, - teListView, - teMenu, - tePage, - teProgress, - teRebar, - teScrollBar, - teSpin, - teStartPanel, - teStatus, - teTab, - teTaskBand, - teTaskBar, - teToolBar, - teToolTip, - teTrackBar, - teTrayNotify, - teTreeview, - teWindow - ); - -var DrawThemeBackground: function(hTheme: DWORD; hdc: HDC; iPartId, iStateId: Integer; - const pRect: TRect; pClipRect: PRECT): HRESULT; stdcall; - OpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): DWORD; stdcall; - ThemeLibrary: THandle; - IsThemeBackgroundPartiallyTransparent: function(hTheme: DWORD; - iPartId, iStateId: Integer): BOOL; stdcall; - DrawThemeParentBackground: function(hwnd: HWND; hdc: HDC; prc: PRECT): HRESULT; stdcall; - CloseThemeData: function(hTheme: DWORD): HRESULT; stdcall; - DrawThemeText: function(hTheme: DWORD; hdc: HDC; iPartId, iStateId: Integer; - pszText: LPCWSTR; iCharCount: Integer; dwTextFlags, dwTextFlags2: DWORD; - var pRect: TRect): HRESULT; stdcall; - IsThemeActive: function: BOOL; stdcall; - IsAppThemed: function: BOOL; stdcall; - GetThemeColor: function(hTheme: DWORD; iPartId, iStateId, iPropId: Integer; - var pColor: COLORREF): HRESULT; stdcall; - -const - themelib = 'uxtheme.dll'; - -type - PThemedElementDetails = ^TThemedElementDetails; - TThemedElementDetails = record - Element: TThemedElement; - Part, - State: Integer; - end; - TThemedEdit = ( - teEditDontCare, - teEditRoot, - teEditTextNormal, teEditTextHot, teEditTextSelected, teEditTextDisabled, teEditTextFocused, teEditTextReadOnly, teEditTextAssist, - teEditCaret - ); - -type TOverrideScrollbarsProc = procedure(Sender: PControl); -procedure DummyOverrideScrollbars(Sender: PControl); -var OverrideScrollbars: TOverrideScrollbarsProc = DummyOverrideScrollbars; - -{$IFNDEF PAS_ONLY} -function CrackStack_MapInResource( const MapName: KOLString; Max_length: Integer; - HandleSuspiciousAddresses: Boolean ): KOLString; -{* Allows to list all procedures and functions called before current cracking - stack frames. This version loads map-file from the resource. - Important note: you must provide latest map file created at the last - application build in the resource! See also CrackStack_MapInFile below. } -function CrackStack_MapInFile( const MapFileName: KOLString; Max_length: Integer; - HandleSuspiciousAddresses: Boolean ): KOLString; -{* Allows to list all procedures and functions called before current cracking - stack frames. This version loads map-file from the file. - Important note: you must have the latest map file created at the last - application build on a path specified! For example, use path GetStartDir + - appname_wo_extention + '.map' and do not forget to set flag Map file - - Detailed in Project Options | Linker. Use flag HandleSuspiciousAddresses - to show all suspicious addresses found in stack (this may help to find - errors not shown even by Delphi debugger since stack frames in some cases give - no enough data). } -{$ENDIF} -//......... these declarations are here to stop hints from Delphi5 while compiling MCK: -function CallTControlCreateWindow( Ctl: PControl ): Boolean; -function DumpWindowed( c: PControl ): PControl; -{$IFNDEF PAS_ONLY} -function WndProcAppAsm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -{$ENDIF} -//22{$IFDEF ASM_VERSION} -const ButtonClass: array[ 0..6 ] of KOLChar = ( 'B','U','T','T','O','N',#0 ); -//22{$ENDIF ASM_VERSION} -{$IFDEF _D3orHigher} -function WndProcUnicodeChars( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -{$ENDIF} -procedure SetMouseEvent( Self_: PControl ); -function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD ); -function _GetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer ): TColor; -procedure _SetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -//^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -{$IFDEF DEBUG_MONITOR_MESSAGES} -var OnMonitorMessage: procedure( var M: TMsg; Enter_WndFunc: Boolean ) of object = nil; -{$ENDIF} - - -{$IFDEF _D2006orHigher} - {$I MCKfakeClasses200x.inc} // Dufa -{$ENDIF} -implementation - - {$UNDEF CALL_INHERITED} -{$IFDEF _D2orD3} - {$DEFINE CALL_INHERITED} -{$ENDIF} -{$IFnDEF NIL_EVENTS} - {$DEFINE CALL_INHERITED} -{$ENDIF} - -{ -- don't remove this comment!!! - uses - //ShellAPI, - //commdlg // removing reference to commdlg decreases executable about 0.5 K - ; //, commctrl; - // in Delphi3, including of commctrl.pas increases executable - // onto about 30K. So, all needed definitions are copied here - // (see commctrl.inc).} - -{$IFDEF _X_} - {$undef uses_2} - {$IFNDEF NOT_USE_KOLMATH} - {$define uses_2} - {$ENDIF NOT_USE_KOLMATH} - {$IFDEF uses_2} - uses {$IFNDEF NOT_USE_KOLMATH} KOLmath - {$IFNDEF NOT_USE_EXCEPTION} , err - {$IFDEF REDECLARATION_INSERTED_AUTOMATICALLY} - , gdk2, pango, gtk2 - {$ENDIF REDECLARATION_INSERTED_AUTOMATICALLY} - {$ENDIF NOT_USE_EXCEPTION} - {$ENDIF NOT_USE_KOLMATH}; - {$ENDIF uses_2} -{$ELSE} - {$IFDEF USE_GRUSH} - uses ToGRush; - {$ELSE} - {$IFDEF INPACKAGE} - uses mirror, SysUtils; - {$ENDIF INPACKAGE} - {$ENDIF USE_GRUSH} -{$ENDIF _X_} - -{$IFDEF WIN} - {$IFDEF UNICODE_CTRLS} - {$DEFINE implementation_part} {$I KOL_unicode.inc} {$UNDEF implementation_part} - {$ELSE} // ANSI_CTRLS - {$DEFINE implementation_part} {$I KOL_ansi.inc} {$UNDEF implementation_part} - {$ENDIF UNICODE_CTRLS} -{$ENDIF WIN} - -{$IFDEF DEBUG_MCK} -procedure dummy_Log( const s: AnsiString ); -begin - // -end; -{$ENDIF} -{$IFDEF WIN} -type - PSHFileInfoA = ^TSHFileInfoA; - PSHFileInfoW = ^TSHFileInfoW; - PSHFileInfo = PSHFileInfoA; - _SHFILEINFOA = record - hIcon: HICON; { out: icon } - iIcon: Integer; { out: icon index } - dwAttributes: DWORD; { out: SFGAO_ flags } - szDisplayName: array [0..MAX_PATH-1] of AnsiChar; { out: display name (or path) } - szTypeName: array [0..79] of AnsiChar; { out: type name } - end; - _SHFILEINFOW = record - hIcon: HICON; { out: icon } - iIcon: Integer; { out: icon index } - dwAttributes: DWORD; { out: SFGAO_ flags } - szDisplayName: array [0..MAX_PATH-1] of WideChar; { out: display name (or path) } - szTypeName: array [0..79] of WideChar; { out: type name } - end; - _SHFILEINFO = {$IFDEF UNICODE_CTRLS} _SHFILEINFOW {$ELSE} _SHFILEINFOA {$ENDIF}; - TSHFileInfoA = _SHFILEINFOA; - TSHFileInfoW = _SHFILEINFOW; - TSHFileInfo = {$IFDEF UNICODE_CTRLS} TSHFileInfoW {$ELSE} TSHFileInfoA {$ENDIF}; - SHFILEINFOA = _SHFILEINFOA; - SHFILEINFOW = _SHFILEINFOW; - SHFILEINFO = {$IFDEF UNICODE_CTRLS} SHFILEINFOW {$ELSE} SHFILEINFOA {$ENDIF}; - -const - SHGFI_ICON = $000000100; { get icon } - SHGFI_DISPLAYNAME = $000000200; { get display name } - SHGFI_TYPENAME = $000000400; { get type name } - SHGFI_ATTRIBUTES = $000000800; { get attributes } - SHGFI_ICONLOCATION = $000001000; { get icon location } - SHGFI_EXETYPE = $000002000; { return exe type } - SHGFI_SYSICONINDEX = $000004000; { get system icon index } - SHGFI_LINKOVERLAY = $000008000; { put a link overlay on icon } - SHGFI_SELECTED = $000010000; { show icon in selected state } - SHGFI_LARGEICON = $000000000; { get large icon } - SHGFI_SMALLICON = $000000001; { get small icon } - SHGFI_OPENICON = $000000002; { get open icon } - SHGFI_SHELLICONSIZE = $000000004; { get shell size icon } - SHGFI_PIDL = $000000008; { pszPath is a pidl } - SHGFI_USEFILEATTRIBUTES = $000000010; { use passed dwFileAttribute } - -function SHGetFileInfoA(pszPath: PAnsiChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; stdcall; - external 'shell32.dll' name 'SHGetFileInfoA'; -{$IFDEF UNICODE_CTRLS} -function SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; stdcall; - external 'shell32.dll' name 'SHGetFileInfoW'; -{$ENDIF UNICODE_CTRLS} - -type - FILEOP_FLAGS = Word; - PRINTEROP_FLAGS = Word; - - PSHFileOpStructA = ^TSHFileOpStructA; - PSHFileOpStructW = ^TSHFileOpStructW; - PSHFileOpStruct = PSHFileOpStructA; - _SHFILEOPSTRUCTA = packed record - Wnd: HWND; - wFunc: UINT; - pFrom: PAnsiChar; - pTo: PAnsiChar; - fFlags: FILEOP_FLAGS; - fAnyOperationsAborted: BOOL; - hNameMappings: Pointer; - lpszProgressTitle: PAnsiChar; { only used if FOF_SIMPLEPROGRESS } - end; - _SHFILEOPSTRUCTW = packed record - Wnd: HWND; - wFunc: UINT; - pFrom: PWideChar; - pTo: PWideChar; - fFlags: FILEOP_FLAGS; - fAnyOperationsAborted: BOOL; - hNameMappings: Pointer; - lpszProgressTitle: PWideChar; { only used if FOF_SIMPLEPROGRESS } - end; - _SHFILEOPSTRUCT = _SHFILEOPSTRUCTA; - TSHFileOpStructA = _SHFILEOPSTRUCTA; - TSHFileOpStructW = _SHFILEOPSTRUCTW; - TSHFileOpStruct = TSHFileOpStructA; - SHFILEOPSTRUCTA = _SHFILEOPSTRUCTA; - SHFILEOPSTRUCTW = _SHFILEOPSTRUCTW; - SHFILEOPSTRUCT = SHFILEOPSTRUCTA; - -const - FO_MOVE = $0001; - FO_COPY = $0002; - FO_DELETE = $0003; - FO_RENAME = $0004; - - FOF_MULTIDESTFILES = $0001; - FOF_CONFIRMMOUSE = $0002; - FOF_SILENT = $0004; { don't create progress/report } - FOF_RENAMEONCOLLISION = $0008; - FOF_NOCONFIRMATION = $0010; { Don't prompt the user. } - FOF_WANTMAPPINGHANDLE = $0020; { Fill in SHFILEOPSTRUCT.hNameMappings - Must be freed using SHFreeNameMappings } - FOF_ALLOWUNDO = $0040; - FOF_FILESONLY = $0080; { on *.*, do only files } - FOF_SIMPLEPROGRESS = $0100; { means don't show names of files } - FOF_NOCONFIRMMKDIR = $0200; { don't confirm making any needed dirs } - FOF_NOERRORUI = $0400; { don't put up error UI } - - -{$IFDEF UNICODE_CTRLS} -function SHFileOperationW(const lpFileOp: TSHFileOpStructW): Integer; stdcall; - external 'shell32.dll' name 'SHFileOperationW'; -{$ENDIF} - -function SHFileOperationA(const lpFileOp: TSHFileOpStructA): Integer; stdcall; - external 'shell32.dll' name 'SHFileOperationA'; - -type - PNotifyIconDataA = ^TNotifyIconDataA; - PNotifyIconDataW = ^TNotifyIconDataW; - PNotifyIconData = PNotifyIconDataA; - _NOTIFYICONDATAA = record - cbSize: DWORD; - Wnd: HWND; - uID: UINT; - uFlags: UINT; - uCallbackMessage: UINT; - hIcon: HICON; - szTip: array [0..63] of AnsiChar; - end; - _NOTIFYICONDATAW = record - cbSize: DWORD; - Wnd: HWND; - uID: UINT; - uFlags: UINT; - uCallbackMessage: UINT; - hIcon: HICON; - szTip: array [0..63] of WideChar; - end; - _NOTIFYICONDATA = _NOTIFYICONDATAA; - TNotifyIconDataA = _NOTIFYICONDATAA; - TNotifyIconDataW = _NOTIFYICONDATAW; - TNotifyIconData = TNotifyIconDataA; - NOTIFYICONDATAA = _NOTIFYICONDATAA; - NOTIFYICONDATAW = _NOTIFYICONDATAW; - NOTIFYICONDATA = NOTIFYICONDATAA; - -const - NIM_ADD = $00000000; - NIM_MODIFY = $00000001; - NIM_DELETE = $00000002; - - NIF_MESSAGE = $00000001; - NIF_ICON = $00000002; - NIF_TIP = $00000004; - -{$IFDEF UNICODE_CTRLS} -function Shell_NotifyIcon(dwMessage: DWORD; lpData: PNotifyIconDataW): BOOL; stdcall; - external 'shell32.dll' name 'Shell_NotifyIconW'; -{$ELSE} -function Shell_NotifyIcon(dwMessage: DWORD; lpData: PNotifyIconData): BOOL; stdcall; - external 'shell32.dll' name 'Shell_NotifyIconA'; -{$ENDIF UNICODE_CTRLS} - -{$IFDEF UNICODE_CTRLS} -function ExtractIcon(hInst: HINST; lpszExeFileName: PKOLChar; - nIconIndex: UINT): HICON; stdcall; - external 'shell32.dll' name 'ExtractIconW'; -{$ELSE} -function ExtractIcon(hInst: HINST; lpszExeFileName: PKOLChar; - nIconIndex: UINT): HICON; stdcall; - external 'shell32.dll' name 'ExtractIconA'; -{$ENDIF UNICODE_CTRLS} -{$ENDIF WIN} -{$IFDEF WIN_GDI} - -type - HDROP = Longint; - -function DragQueryPoint(Drop: HDROP; var Point: TPoint): BOOL; stdcall; - external 'shell32.dll' name 'DragQueryPoint'; -{$IFDEF UNICODE_CTRLS} -function DragQueryFile(Drop: HDROP; FileIndex: UINT; FileName: PWideChar; cb: UINT): UINT; stdcall; - external 'shell32.dll' name 'DragQueryFileW'; -{$ELSE} -function DragQueryFile(Drop: HDROP; FileIndex: UINT; FileName: PAnsiChar; cb: UINT): UINT; stdcall; - external 'shell32.dll' name 'DragQueryFileA'; -{$ENDIF UNICODE_CTRLS} -procedure DragFinish(Drop: HDROP); stdcall; - external 'shell32.dll' name 'DragFinish'; -procedure DragAcceptFiles(Wnd: HWND; Accept: BOOL); stdcall; - external 'shell32.dll' name 'DragAcceptFiles'; - -const - OFN_READONLY = $00000001; - OFN_OVERWRITEPROMPT = $00000002; - OFN_HIDEREADONLY = $00000004; - OFN_NOCHANGEDIR = $00000008; - OFN_SHOWHELP = $00000010; - OFN_ENABLEHOOK = $00000020; - OFN_ENABLETEMPLATE = $00000040; - OFN_ENABLETEMPLATEHANDLE = $00000080; - OFN_NOVALIDATE = $00000100; - OFN_ALLOWMULTISELECT = $00000200; - OFN_EXTENSIONDIFFERENT = $00000400; - OFN_PATHMUSTEXIST = $00000800; - OFN_FILEMUSTEXIST = $00001000; - OFN_CREATEPROMPT = $00002000; - OFN_SHAREAWARE = $00004000; - OFN_NOREADONLYRETURN = $00008000; - OFN_NOTESTFILECREATE = $00010000; - OFN_NONETWORKBUTTON = $00020000; - OFN_NOLONGNAMES = $00040000; - OFN_EXPLORER = $00080000; - OFN_NODEREFERENCELINKS = $00100000; - OFN_LONGNAMES = $00200000; - OFN_ENABLEINCLUDENOTIFY = $00400000; - OFN_ENABLESIZING = $00800000; - OFN_DONTADDTORECENT = $02000000; - OFN_FORCESHOWHIDDEN = $10000000; // Show All files including System and hidden files - OFN_EX_NOPLACESBAR = $00000001; - OFN_SHAREFALLTHROUGH = 2; - OFN_SHARENOWARN = 1; - OFN_SHAREWARN = 0; -type - POpenFilename = ^TOpenFilename; - tagOFN = packed record - lStructSize: DWORD; - hWndOwner: HWND; - hInstance: HINST; - lpstrFilter: PKOLChar; - lpstrCustomFilter: PKOLChar; - nMaxCustFilter: DWORD; - nFilterIndex: DWORD; - lpstrFile: PKOLChar; - nMaxFile: DWORD; - lpstrFileTitle: PKOLChar; - nMaxFileTitle: DWORD; - lpstrInitialDir: PKOLChar; - lpstrTitle: PKOLChar; - Flags: DWORD; - nFileOffset: Word; - nFileExtension: Word; - lpstrDefExt: PKOLChar; - lCustData: LPARAM; - lpfnHook: function(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall; - lpTemplateName: PKOLChar; - {$IFDEF OpenSaveDialog_Extended} - //---------- added from Windows2000: - pvReserved: Pointer; - dwReserved: DWORD; - FlagsEx: DWORD; - {$ENDIF} - end; - TOpenFilename = tagOFN; - OPENFILENAME = tagOFN; -{$IFDEF UNICODE_CTRLS} -function GetOpenFileName(var OpenFile: TOpenFilename): Bool; stdcall; - external 'comdlg32.dll' name 'GetOpenFileNameW'; -function GetSaveFileName(var OpenFile: TOpenFilename): Bool; stdcall; - external 'comdlg32.dll' name 'GetSaveFileNameW'; -{$ELSE} -function GetOpenFileName(var OpenFile: TOpenFilename): Bool; stdcall; - external 'comdlg32.dll' name 'GetOpenFileNameA'; -function GetSaveFileName(var OpenFile: TOpenFilename): Bool; stdcall; - external 'comdlg32.dll' name 'GetSaveFileNameA'; -{$ENDIF UNICODE_CTRLS} - -type - PChooseColorA = ^TChooseColorA; - PChooseColorW = ^TChooseColorW; - PChooseColor = PChooseColorA; - tagCHOOSECOLORA = packed record - lStructSize: DWORD; - hWndOwner: HWND; - hInstance: HWND; - rgbResult: COLORREF; - lpCustColors: ^COLORREF; - Flags: DWORD; - lCustData: LPARAM; - lpfnHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall; - lpTemplateName: PAnsiChar; - end; - tagCHOOSECOLORW = packed record - lStructSize: DWORD; - hWndOwner: HWND; - hInstance: HWND; - rgbResult: COLORREF; - lpCustColors: ^COLORREF; - Flags: DWORD; - lCustData: LPARAM; - lpfnHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall; - lpTemplateName: PWideChar; - end; - tagCHOOSECOLOR = tagCHOOSECOLORA; - TChooseColorA = tagCHOOSECOLORA; - TChooseColorW = tagCHOOSECOLORW; - TChooseColor = TChooseColorA; - -const - CC_RGBINIT = $00000001; - CC_FULLOPEN = $00000002; - CC_PREVENTFULLOPEN = $00000004; - CC_SHOWHELP = $00000008; - CC_ENABLEHOOK = $00000010; - CC_ENABLETEMPLATE = $00000020; - CC_ENABLETEMPLATEHANDLE = $00000040; - CC_SOLIDCOLOR = $00000080; - CC_ANYCOLOR = $00000100; - -function ChooseColor(var CC: TChooseColor): Bool; stdcall; - external 'comdlg32.dll' name 'ChooseColorA'; - -{$IFDEF GDI} -{$IFDEF CHK_BITBLT} -procedure Chk_BitBlt_ShowError; -var Rslt: Integer; -begin - Rslt := GetLastError; - ShowMessage( 'BitBlt ERROR: ' + Int2Str( Rslt ) - + ' ' + SysErrorMessage( Rslt ) ); -end; - -procedure Chk_BitBlt; -var Rslt: Integer; -begin - asm - MOV Rslt, EAX - end; - if Rslt = 0 then - begin - Chk_BitBlt_ShowError; - asm - int 3; - end; - end; -end; -{$ENDIF CHK_BITBLT} -{$ENDIF GDI} - -{$ifdef _D2} -procedure Assert( Cond: Boolean; const Msg: AnsiString ); -begin - if not Cond then - begin - AssertErrorProc( Msg, '', 0 ); - asm - int 3; - end; - end; -end; - -function CreateDIBSection(DC: HDC; const p2: TBitmapInfo; p3: UINT; - var p4: Pointer; p5: THandle; p6: DWORD): HBITMAP; stdcall; -external gdi32 name 'CreateDIBSection'; - -procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); -asm - { -> EAX pointer to dest } - { EDX source } - { ECX length } - - PUSH EBX - PUSH ESI - PUSH EDI - - MOV EBX,EAX - MOV ESI,EDX - MOV EDI,ECX - - { allocate new string } - - MOV EAX,EDI - - CALL System.@NewAnsiString - MOV ECX,EDI - MOV EDI,EAX - - TEST ESI,ESI - JE @@noMove - - MOV EDX,EAX - MOV EAX,ESI - CALL Move - - { assign the result to dest } - -@@noMove: - MOV EAX,EBX - CALL System.@LStrClr - MOV [EBX],EDI - - POP EDI - POP ESI - POP EBX -end; -{$endif} - -{$IFDEF _D2009orHigher} -{$IFNDEF PAS_ONLY} -procedure _aLStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); -asm - push 0 - CALL System.@LStrFromPCharLen -end; - -procedure _aLStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); -asm - push ecx - xor ecx, ecx - CALL System.@LStrFromPChar - pop ecx -end; -{$ENDIF} -{$ENDIF} - -procedure InitCommonControls; external cctrl name 'InitCommonControls'; - -type - TInitCommonControlsEx = packed record - dwSize: DWORD; - dwICC: DWORD; - end; - PInitCommonControlsEx = ^TInitCommonControlsEx; - -var ComCtl32_Module: HModule; -{$IFDEF ASM_UNICODE} -{$ELSE PASCAL} -procedure DoInitCommonControls( dwICC: DWORD ); -var Proc: procedure( ICC: PInitCommonControlsEx ); stdcall; - ICC: TInitCommonControlsEx; -begin - InitCommonControls; - if ComCtl32_Module = 0 then - ComCtl32_Module := LoadLibrary( 'comctl32' ); - @ Proc := GetProcAddress( ComCtl32_Module, 'InitCommonControlsEx' ); - {$IFDEF SAFE_CODE} // DoInitCommonControls should work usually. If not, the System is - if Assigned( Proc ) then // not in normal state, and should be repaired anyway. - {$ENDIF} - begin - ICC.dwSize := Sizeof( ICC ); - ICC.dwICC := dwICC; - Proc( @ ICC ); - end; -end; -{$ENDIF} - -const size_TRect = 16; // used often in assembler versions of code - -{$IFDEF ASM_VERSION} -const - EmptyString: AnsiString = ''; - -procedure EAX2PChar; -asm - TEST EAX, EAX - JNZ @@exit - MOV EAX, offset[EmptyString] - //LEA EAX, [EmptyString] - //MOV EAX, [EmptyString] -@@exit: -end; - -procedure EDX2PChar; -asm - TEST EDX, EDX - JNZ @@exit - MOV EDX, offset[EmptyString] -@@exit: -end; - -procedure ECX2PChar; -asm - JECXZ @@convert - RET -@@convert: - MOV ECX, offset[EmptyString] -@@exit: -end; - -procedure RemoveStr; -asm { <- [ESP+4] = string to remove - -> ESP := ESP + 4 - EAX = 0 } - POP EAX - XCHG EAX, [ESP] - PUSH EAX - MOV EAX, ESP - CALL System.@LStrClr - POP EAX -end; - -{$IFDEF _D3orHigher} -procedure RemoveWStr; -asm { <- [ESP+4] = string to remove - -> ESP := ESP + 4 - EAX = 0 } - POP EAX - XCHG EAX, [ESP] - PUSH EAX - MOV EAX, ESP - CALL System.@WStrClr - POP EAX -end; -{$ENDIF _D3orHigher} -{$ENDIF ASM_VERSION} - -const PossibleColorBits : array[1..7] of Byte = ( 1, 4, 8, 16, 24, 32, 0 ); - -function FindFilter( const Filter: KOLString): KOLString; forward; -function WriteExMemoryStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; forward; -procedure CreateComboboxWnd( Combo: PControl ); forward; -procedure ComboboxDropDown( Sender: PObj ); forward; -function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; forward; -function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; forward; -function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward; -function CompareAnsiStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward; -function CompareStrListItems_NoCase( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward; -function CompareStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward; -procedure ApplyImageLists2Control( Sender: PControl ); forward; -procedure ApplyImageLists2ListView( Sender: PControl ); forward; -function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer; - stdcall; forward; -function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): - Integer; stdcall; forward; -function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer; - stdcall; forward; -function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo; forward; -procedure PreparePF16bit( DIBHeader: PBitmapInfo ); forward; -procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward; -procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward; -procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward; -procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward; -procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward; -procedure _RotateBitmapRight( SrcBmp: PBitmap ); forward; -procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward; -procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward; -procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward; -procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward; -procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer ); forward; -procedure DetachBitmapFromCanvas( Sender: PBitmap ); forward; -function ColorBits( ColorsCount : Integer ) : Integer; forward; -procedure AlignChildrenProc(Sender: PObj); forward; -function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function CollectTabControls( Form: PControl ): PList; forward; -{$IFNDEF NOT_USE_RICHEDIT} -function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -{$ENDIF NOT_USE_RICHEDIT} -function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; forward; -function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; - forward; -function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; - forward; -function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean; - forward; -procedure Tabulate2Next( Form: PControl; Dir: Integer ); forward; -function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean; - forward; -function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean; forward; - -////////////---------------------------------------------------///////////////// -function WndProcDateTimePickerNotify( Self_: PControl; var Msg: TMsg; - var Rslt: Integer ): Boolean; forward; - -//////////////////////////////////////////////////////////////////////////////// -{$IFNDEF PAS_ONLY} -var MapFile: PKOLStrList; - LineNumbersFrom: Integer; - MaxCrackStackLen: Integer; - HandleSuspicious: Boolean; - BelowBasePtr: PDWORD; - CrackedStack: KOLString; - -function DoCrackSingleFrame( RetAddr: DWORD; BasePtr: DWORD ): Boolean; -var i, j, R: Integer; - A, Prev_A, N, Prev_N: DWORD; - s, CurUnit: KOLString; - Add_string: KOLString; - Line_found: Boolean; -begin - Result := FALSE; - if Length( CrackedStack ) > MaxCrackStackLen then Exit; {>>>>>>>>>>>>>>>>>>} - Result := TRUE; - if RetAddr >= $70000000 then - begin - CrackedStack := CrackedStack + #13#10'$' + Int2Hex( RetAddr, 8 ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := FALSE; - if RetAddr < $400000 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - - if HandleSuspicious then - if (BelowBasePtr <> nil) and (BasePtr <> 0) - and (DWORD( BelowBasePtr ) < BasePtr) then - begin - BelowBasePtr := Pointer( DWORD( BelowBasePtr ) + 4 ); - while DWORD( BelowBasePtr ) < BasePtr do - begin - A := BelowBasePtr^; - if (A > $400000) and (A < $700000) then - DoCrackSingleFrame( A, 0 ); - BelowBasePtr := Pointer( DWORD( BelowBasePtr ) + 4 ); - end; - end; - if BasePtr <> 0 then - BelowBasePtr := Pointer( BasePtr ); - - Add_string := ''; - - // 1st: find - Prev_A := 0; - for i := 0 to MapFile.Count-1 do - begin - s := MapFile.Items[ i ]; - if s = '' then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - R := 0; - j := 1; - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - while (j <= Length( s )) and - ( (s[j] >= '0') and (s[j] <= '9') or - (s[j] >= 'A') and (s[j] <= 'F') ) do - begin - if s[j] <= '9' then R := R * 16 + Ord( s[j] ) - Ord( '0' ) - else R := R * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; - inc( j ); - end; - if (j > Length( s )) or (s[ j ] <> ':') then Exit; {>>>>>>>>>>>>>>>>>>>} - inc( j ); - A := 0; - while (j <= Length( s )) and - ( (s[j] >= '0') and (s[j] <= '9') or - (s[j] >= 'A') and (s[j] <= 'F') ) do - begin - if s[j] <= '9' then A := A * 16 + Ord( s[j] ) - Ord( '0' ) - else A := A * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; - inc( j ); - end; - A := A + $401000; - if (Prev_A <= RetAddr) and (A > RetAddr) and (Prev_A > 0) and (R = 1) then - begin - s := MapFile.Items[ i-1 ]; - j := pos( AnsiString(':'), s ); - if j <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - s := Copy( s, j+1, MaxInt ); - for j := 1 to Length( s ) do - if s[ j ] <= ' ' then - begin - s := Trim( Copy( s, j, MaxInt ) ); - Add_string := #13#10; - if BasePtr = 0 then - Add_string := Add_string + '? ' + Int2Hex( RetAddr, 8 ) + ':'; - Add_string := Add_string + s; - Result := TRUE; - break; - end; - end; - Prev_A := A; - if Result then break; - end; - if not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - - // 2nd: find line no - Line_found := FALSE; - CurUnit := ''; - Prev_N := 0; - Prev_A := 0; - for i := LineNumbersFrom to MapFile.Count-1 do - begin - s := MapFile.Items[ i ]; - if Copy( s, 1, 4 ) = 'Line' then - begin - j := pos( AnsiString('('), s ); - if j > 0 then - begin - s := Copy( s, j+1, MaxInt ); - j := pos( AnsiString(')'), s ); - if j > 0 then - s := Copy( s, 1, j-1 ); - end; - CurUnit := s; - Prev_N := 0; - end else - if s <> '' then - begin - j := 1; - while j < Length( s ) do - begin - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - N := 0; - while (j <= Length( s )) and - (s[j] >= '0') and (s[j] <= '9') do - begin - N := N * 10 + Ord( s[j] ) - Ord( '0' ); - inc( j ); - end; - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - R := 0; - while (j < Length( s )) and - ( (s[j] >= '0') and (s[j] <= '9') or - (s[j] >= 'A') and (s[j] <= 'F') ) do - begin - if s[j] <= '9' then - R := R * 16 + Ord( s[j] ) - Ord( '0' ) - else R := R * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; - inc( j ); - end; - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - if (j <= Length(s)) and (s[ j ] = ':') then inc( j ); - while (j <= Length( s )) and (s[j] <= ' ') do inc( j ); - A := 0; - while (j <= Length( s )) and - ( (s[j] >= '0') and (s[j] <= '9') or - (s[j] >= 'A') and (s[j] <= 'F') ) do - begin - if s[j] <= '9' then - A := A * 16 + Ord( s[j] ) - Ord( '0' ) - else A := A * 16 + Ord( s[j] ) - Ord( 'A' ) + 10; - inc( j ); - end; - A := A + $401000; - if (Prev_A <= RetAddr) and (A > RetAddr) then - begin - if (Prev_A > 0) and (Prev_N > 0) then - begin - Add_string := Add_string + ' in ' + CurUnit + ', line: ' + - Int2Str( Prev_N ); - Line_found := TRUE; - end; - s := ''; - break; - end; - Prev_N := N; - Prev_A := A; - if Line_found then break; - end; - end; - if Line_found then break; - end; - if not Line_found and (BasePtr = 0) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>} - CrackedStack := CrackedStack + Add_string; - if Length( CrackedStack ) > MaxCrackStackLen then - begin - CrackedStack := Copy( CrackedStack, 1, MaxCrackStackLen ); - Result := FALSE; // stop cracking - end; -end; - -procedure DoCrackStack; -asm - mov edx, ebp -@@loop: - mov ecx, [edx] - mov eax, [edx+4] - mov edx, ecx - push edx - call DoCrackSingleFrame - pop edx - test al, al - jnz @@loop -end; - -function CrackStack( Max_length: Integer; HandleSuspiciousAddresses: Boolean ): KOLString; -begin - TRY - MaxCrackStackLen := Max_length; - HandleSuspicious := HandleSuspiciousAddresses; - CrackedStack := ''; - DoCrackStack; - EXCEPT - END; - Result := CrackedStack; -end; - -procedure PrepareMapFile; -var i, j: Integer; - s: KOLString; -begin - for i := 0 to MapFile.Count-1 do - begin - s := MapFile.Items[ i ]; - if pos( AnsiString('Publics by Value'), s ) > 0 then - begin - j := i; - if Trim( MapFile.Items[ j+1 ] ) = '' then - inc( j ); - for j := j downto 0 do - MapFile.Delete( j ); - for j := 0 to MapFile.Count-1 do - begin - s := Trim( MapFile.Items[ j ] ); - if (s = '') and (LineNumbersFrom = 0) then - begin - LineNumbersFrom := j; - end; - if s = 'Bound resource files' then - begin - while MapFile.Count > j do - MapFile.Delete( j ); - break; - end; - end; - break; - end; - end; -end; - -function CrackStack_MapInResource( const MapName: KOLString; Max_length: Integer; - HandleSuspiciousAddresses: Boolean ): KOLString; -var MapStrm: PStream; -begin - Result := ''; - if MapFile = nil then - begin - MapStrm := NewMemoryStream; - TRY - Resource2Stream( MapStrm, hInstance, PKOLChar( MapName ), PKOLChar(RT_RCDATA) ); - if MapStrm.Size = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - MapFile := NewKOLStrList; - MapStrm.Position := 0; - MapFile.LoadFromStream( MapStrm, FALSE ); - PrepareMapFile; - FINALLY - MapStrm.Free; - END; - end; - if MapFile = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := CrackStack( Max_length, HandleSuspiciousAddresses ); -end; - -function CrackStack_MapInFile( const MapFileName: KOLString; Max_length: Integer; - HandleSuspiciousAddresses: Boolean ): KOLString; -begin - Result := ''; - if MapFile = nil then - begin - MapFile := NewKOLStrList; - MapFile.LoadFromFile( MapFileName ); - if MapFile.Count = 0 then - Free_And_Nil( MapFile ) - else PrepareMapFile; - end; - if MapFile = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := CrackStack( Max_length, HandleSuspiciousAddresses ); -end; -{$ENDIF _no_PAS_ONLY} - -{$IFDEF GRAPHCTL_XPSTYLES} - {$I visual_xp_styles.inc} -{$ENDIF} - -{$IFDEF SNAPMOUSE2DFLTBTN} -var FoundMsgBoxWnd: HWnd; - -function EnumProcSnapMouse2DfltBtn( W: HWnd; lParam: Integer ): BOOL; stdcall; -var ClassBuf: array[ 0..31 ] of KOLChar; -begin - GetClassName( W, ClassBuf, Sizeof( ClassBuf ) div Sizeof( KOLChar ) ); - Result := TRUE; - if ClassBuf = '#32770' then - begin - FoundMsgBoxWnd := W; - Result := FALSE; - end; -end; - -function WndProcSnapMouse2DfltBtn( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean; -var W: HWnd; - R: TRect; - P: TPoint; - SnapMouse: Integer; -begin - SnapMouse := 0; - if SystemParametersInfo( {SPI_GETSNAPTODEFBUTTON}95, 0, @ SnapMouse, 0 ) then - if SnapMouse <> 0 then - begin - FoundMsgBoxWnd := 0; - EnumThreadWindows( GetCurrentThreadID, @ EnumProcSnapMouse2DfltBtn, 0 ); - if FoundMsgBoxWnd <> 0 then - begin - W := GetWindow( FoundMsgBoxWnd, GW_CHILD ); - while W <> 0 do - begin - if GetWindowLong( W, GWL_STYLE ) and BS_DEFPUSHBUTTON <> 0 then - begin - GetWindowRect( W, R ); - P.X := (R.Left + R.Right) div 2; - P.Y := (R.Top + R.Bottom) div 2; - SetCursorPos( P.X, P.Y ); - end; - W := GetWindow( W, GW_HWNDNEXT ); - end; - Applet.DetachProc( @WndProcSnapMouse2DfltBtn ); - end; - end; - Result := FALSE; -end; -{$ENDIF SNAPMOUSE2DFLTBTN} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function MsgBox( const S: KOLString; Flags: DWORD ): DWORD; -var Title: PKOLChar; -begin - {$IFnDEF NO_SAFE_CODE} // MsgBox should be called when Applet already created - Title := nil; // (and yet not destroyed) - if assigned( Applet ) then - {$ENDIF} - begin - Title := PKOLChar( Applet.fCaption ); - end; - {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFDEF SAFE_CODE} - if Assigned( Applet ) then - {$ENDIF} - begin - Applet.AttachProc( WndProcSnapMouse2DfltBtn ); - Applet.Postmsg( 0, 0, 0 ); - end; - {$ENDIF} - Result := MessageBox( 0, PKOLChar( S ), Title, Flags ); - {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFnDEF NO_SAFE_CODE} - if Assigned( Applet ) then - {$ENDIF} - Applet.DetachProc( WndProcSnapMouse2DfltBtn ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -procedure MsgOK( const S: KOLString ); -begin - MsgBox( S, MB_OK ); -end; - -{$IFDEF ASM_UNICODE}{$ELSE PASCAL} -function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD; -var Title: PKOLChar; - Wnd: HWnd; -begin - {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFDEF SAFE_CODE} - if Assigned( Applet ) then - {$ENDIF} - Applet.AttachProc( WndProcSnapMouse2DfltBtn ); - {$ENDIF} - {$IFDEF SAFE_CODE} - Title := nil; - Wnd := 0; - if assigned( Applet ) then - {$ENDIF} - begin - Title := PKOLChar( Applet.fCaption ); - //{$IFNDEF SNAPMOUSE2DFLTBTN} - Wnd := Applet.Handle; - //{$ENDIF} - end; - Result := MessageBox( Wnd, PKOLChar( S ), Title, Flags ); - {$IFDEF SNAPMOUSE2DFLTBTN} - {$IFDEF SAFE_CODE} - if Assigned( Applet ) then - {$ENDIF} - Applet.DetachProc( WndProcSnapMouse2DfltBtn ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -procedure ShowMessage( const S: KOLString ); -begin - ShowMsg( S, MB_OK or MB_SETFOREGROUND or MB_DEFBUTTON1 ); -end; -{$ENDIF GDI} - -{$IFDEF WIN_GDI} -{$IFDEF PAS_ONLY} -procedure SpeakerBeep( Freq: Word; Duration: DWORD ); -begin - Windows.Beep( Freq, Duration ); -end; -{$ELSE} -procedure SpeakerBeep( Freq: Word; Duration: DWORD ); -begin - if WinVer >= wvNT then - Windows.Beep( Freq, Duration ) - else - begin - if Freq < 18 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Freq := 1193181 div Freq; - if Freq = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - asm - mov al,0b6H - out 43H,al - mov ax,Freq - //xchg al, ah - out 42h,al - xchg al, ah - out 42h,al - in al,61H - or al,03H - out 61H,al - end {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ; - Sleep(Duration); - asm - in al,61H - and al,0fcH - out 61H,al - end {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ; - end; -end; -{$ENDIF} -{$ENDIF WIN_GDI} - -function SysErrorMessage(ErrorCode: Integer): KOLString; -var - Len: Integer; - Buffer: array[0..255] of KOLChar; -begin - Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or - FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, - SizeOf(Buffer), nil); - while (Len > 0) and ({(Buffer[Len - 1] >= #0) and} (Buffer[Len - 1] <= ' ')) do Dec(Len); - SetString(Result, Buffer, Len); - //Result := Trim( Result ); -end; -{$ENDIF WIN_GDI} - -function GetShiftState: DWORD; -{$IFDEF WIN} -const Buttons: array[0..6] of Byte = ( VK_SHIFT, VK_CONTROL, VK_MENU, VK_LBUTTON, - VK_RBUTTON, VK_MBUTTON, VK_CAPITAL ); - Flags: array[0..6] of Byte = ( MK_SHIFT, MK_CONTROL, MK_ALT, MK_LBUTTON, - MK_RBUTTON, MK_MBUTTON, MK_LOCK ); -var i, mask: Integer; -{$ENDIF WIN} //todo: for Linux / GTK ? -begin - Result := 0; - {$IFDEF WIN} - mask := 1; - for i := High( Buttons ) downto 0 do - begin - if GetKeyState( Buttons[ i ] ) and mask <> 0 then - Result := Result or Flags[ i ]; - mask := $8000; - end; - {$ENDIF WIN} -end; - -function MakeMethod( Data, Code: Pointer ): TMethod; -begin - Result.Data := Data; - Result.Code := Code; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; stdcall; -begin - Result.Left := Left; - Result.Top := Top; - Result.Right:= Right; - Result.Bottom := Bottom; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function RectsEqual( const R1, R2: TRect ): Boolean; -begin - Result := CompareMem( @R1, @R2, Sizeof( TRect ) ); -end; -{$ENDIF PAS_VERSION} - -function RectsIntersected( const R1, R2: TRect ): Boolean; -begin - Result := ((R1.Left <= R2.Left) and (R1.Right > R2.Left ) or - (R1.Left <= R2.Right) and (R1.Right >= R2.Right) or - (R1.Left >= R2.Left) and (R1.Right <= R2.Right)) - and - ((R1.Top <= R2.Top) and (R1.Bottom > R2.Top) or - (R1.Top <= R2.Bottom) and (R1.Bottom >= R2.Bottom) or - (R1.Top >= R2.Top) and (R1.Bottom <= R2.Bottom)) ; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function PointInRect( const P: TPoint; const R: TRect ): Boolean; -begin - Result := (P.x >= R.Left) and (P.x < R.Right) - and (P.y >= R.Top) and (P.y < R.Bottom); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal -function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint; -begin - Result := MakePoint( T.X + dX, T.Y + dY ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal -function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint; -begin - Result.x := T.x + dX; - Result.y := T.y + dY; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal -function Point2SmallPoint( const T: TPoint ): TSmallPoint; -begin - Result.x := T.X; - Result.y := T.Y; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function SmallPoint2Point( const T: TSmallPoint ): TPoint; -begin - Result := MakePoint( T.x, T.y ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function MakePoint( X, Y: Integer ): TPoint; -begin - Result.x := X; - Result.y := Y; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal -function MakeSmallPoint( X, Y: Integer ): TSmallPoint; -begin - Result.x := X; - Result.y := Y; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer; -var I : Integer; - Mask : DWORD; -begin - Result := 0; - Mask := FlgSet^; - for I := 0 to High( FlgArray ) do - begin - if (FlgArray[ I ] < 0) and not LongBool( Mask and 1 ) then - Result := Result or not FlgArray[ I ] - else - if (FlgArray[ I ] >= 0) and LongBool( Mask and 1 ) then - Result := Result or FlgArray[ I ]; - Mask := Mask shr 1; - end; -end; -{$ENDIF PAS_VERSION} - -function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange; -begin - Result.FromDate := D1; - Result.ToDate := D2; -end; - -procedure Swap( var X, Y: Integer ); -{$IFDEF F_P} -var Tmp: Integer; -begin - Tmp := X; - X := Y; - Y := Tmp; -end; -{$ELSE DELPHI} -asm - MOV ECX, [EDX] - XCHG ECX, [EAX] - MOV [EDX], ECX -end; -{$ENDIF F_P/DELPHI} - -function Min( X, Y: Integer ): Integer; -asm - {$IFDEF F_P} - MOV EAX, [X] - MOV EDX, [Y] - {$ENDIF F_P} - {$IFDEF USE_CMOV} - CMP EAX, EDX - CMOVG EAX, EDX - {$ELSE} - CMP EAX, EDX - JLE @@exit - MOV EAX, EDX -@@exit: - {$ENDIF} -end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF}; - -function Max( X, Y: Integer ): Integer; -asm - {$IFDEF F_P} - MOV EAX, [X] - MOV EDX, [Y] - {$ENDIF F_P} - {$IFDEF USE_CMOV} - CMP EAX, EDX - CMOVL EAX, EDX - {$ELSE} - CMP EAX, EDX - JGE @@exit - MOV EAX, EDX -@@exit: - {$ENDIF} -end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF}; - -{$IFDEF REDEFINE_ABS} -function Abs( X: Integer ): Integer; -asm - {$IFDEF F_P} - MOV EAX, [X] - {$ENDIF F_P} - cdq - xor eax, edx - sub eax, edx -end {$IFDEF F_P} [ 'EAX' ] {$ENDIF}; -{$ENDIF} - -function Sgn( X: Integer ): Integer; -asm - CMP EAX, 0 - {$IFDEF USE_CMOV} - MOV EDX, -1 - CMOVL EAX, EDX - MOV EDX, 1 - CMOVG EAX, EDX - {$ELSE} - JZ @@exit - MOV EAX, 1 - JG @@exit - MOV EAX, -1 -@@exit: - {$ENDIF} -end; - -function iSQRT( X: Integer ): Integer; -{$IFDEF _D4orHigher} -// new version is more efficient but code is not compatible with older compilers -var I, N: Int64; -begin - Result := 0; - while Result < X do - begin - I := 1; - while I > 0 do - begin - N := (Result + I) * (Result + I); - if N > X then - begin - I := I shr 1; - break; - end else - if N = X then - begin - Result := Result + I; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - I := I * 2; - end; - if I <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Result + I; - end; -end; -{$ELSE _D3 or below or FPC1} -var m, y, b: DWORD; -begin - m := $40000000; - y := 0; - while m <> 0 do // 16 times - begin - b := y or m; - y := y shr 1; - if x >= b then - begin - x := x - b; - y := y or m; - end; - m := m shr 2; - end; - Result := y; -end; -{$ENDIF} - -function iCbrt( X: DWORD ): Integer; -var s: Integer; - y, b: DWORD; -begin - s := 30; - y := 0; - while s >= 0 do // 11 times - begin - y := 2 * y; - b := (3 * y * (y+1) + 1) shl s; - s := s - 3; - if x >= b then - begin - x := x - b; - y := y + 1; - end; - end; - Result := y; -end; -{$IFDEF WIN_GDI} - -{$IFDEF ASM_DC} -procedure StartDC; -asm - { <- EBX : PBitmap - -> EAX = dc - [ESP+8] = var dc - [ESP+4] = var SaveBmp - } - PUSH 0 - CALL CreateCompatibleDC - POP EDX - PUSH EAX - PUSH EDX - MOV EAX, EBX - CALL [EBX].TBitmap.fDetachCanvas - MOV EAX, EBX - CALL TBitmap.GetHandle - PUSH EAX - PUSH dword ptr [ESP+8] - CALL SelectObject - POP EDX - PUSH EAX - PUSH EDX - MOV EAX, [ESP+8] -end; - -procedure FinishDC; -asm - POP ECX - POP EAX - POP EDX - PUSH ECX - PUSH EDX - PUSH EAX - PUSH EDX - CALL SelectObject - CALL DeleteDC -end; -{$ENDIF ASM_DC} - -function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; - forward; - -{$ENDIF WIN_GDI} - -procedure DummyObjProc( Sender: PObj ); -begin // 1-2-3 parameters, no result -end; - -function DummyProc123_TRUE( Dummy: Pointer; Sender: PControl; param3: Integer ): Boolean; -begin Result := TRUE; // 1-2-3 params, Result = TRUE -end; - -function DummyProc123_0( Dummy: Pointer; Sender: PObj; param3: Integer ): Integer; -begin Result := 0; // 1-2-3 params, Result = 0 -end; - -function DummyProc4_TRUE( Dummy: Pointer; Sender: PControl; p3, p4: Integer ): Boolean; -begin Result := TRUE; // 4 params, result = TRUE -end; - -function DummyProc5_TRUE( Dummy: Pointer; Sender: PControl; p3, p4, p5: Integer): Boolean; -begin Result := TRUE; // 5 params, result = TRUE -end; - -procedure DummyOnLVDataProc( Dummy: Pointer; Sender: PControl; Idx, SubItem: Integer; - var Txt: KOL_String; var ImgIdx: Integer; var State: DWORD; - var Store: Boolean ); -begin // 8 params -end; - -function DummyProc4_0( Dummy: Pointer; Sender: PControl; p3, p4: Integer ): Integer; -begin Result := 0; // 4 params, Result = 0 -end; - -function DummyOnDrawItemProc( Dummy:Pointer; Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer; - DrawAction: TDrawAction; ItemState: TDrawState ): Boolean; -begin Result := FALSE; // 7 params, Result = FALSE -end; - -function DummyOnLVCustomDrawProc( Dummy: Pointer; Sender: PControl; DC: HDC; Stage: DWORD; - ItemIdx, SubItemIdx: Integer; const Rect: TRect; - ItemState: TDrawState; var TextColor, BackColor: TColor ): DWORD; -begin Result := 0; // 10 params, Result = 0 -end; - -function DummyOnSBBeforeScrollProc(Dummy: Pointer; Sender: PControl; - OldPos, NewPos: Integer; Cmd: Word; var AllowChange: Boolean): Boolean; -begin Result := FALSE; // 6 params -end; - -var DummyProcTable: array[ 0..11 ] of Pointer = ( @DummyObjProc, @DummyProc123_TRUE, - @DummyProc123_0, @DummyProc4_TRUE, @DummyProc5_TRUE, @DummyOnLVDataProc, - @DummyProc4_0, @DummyOnDrawItemProc, @DummyOnLVCustomDrawProc, - @DummyOnSBBeforeScrollProc, @WndFunc, - {$IFDEF USE_GRAPHCTLS} @InvalidateWindowed {$ELSE} @DummyObjProc {$ENDIF} ); -const idummy123 = 0; //+ - idummy123_TRUE = 1; //+ - idummy123_0 = 2; //+ - idummy4_TRUE = 3; //+ - idummy5_TRUE = 4; //+ - idummy8 = 5; //+ - idummy4_0 = 6; //+ - idummy7 = 7; //+ - idummy10 = 8; //+ - idummy6 = 9; //+ - iWndFunc = 10; //+ - iInvalidateWindowed = 11; //+ -const InitEventsTable: array[ 0..idx_LastEvent ] of Byte = ( - idummy123_0 + iWndFunc shl 4, //idx_fOnMessage + idx_fWndFunc = 0; idx_fWndFunc = 69; - idummy123_0 + iInvalidateWindowed shl 4, //idx_fOldOnMessage + idx_fDoInvalidate = 1; idx_fDoInvalidate = 70; - idummy123 + idummy123_0 shl 4, //idx_fOnClick = 2; idx_fOnDynHandlers = 71; - idummy123 + idummy123_0 shl 4, //idx_fOnMouseDown = 3; idx_fPass2DefProc = 72; - idummy123 + idummy123_0 shl 4, //idx_fOnMouseUp = 4; idx_fWndProcKeybd = 73; - idummy123 + idummy123_0 shl 4, //idx_fOnMouseMove = 5; idx_fControlClick = 74; - idummy123 + idummy123_0 shl 4, //idx_fOnMouseDblClk = 6; idx_fAutoSize = 75; - idummy123 + idummy123_0 shl 4, //idx_fOnMouseWheel = 7; idx_fGotoControl = 77; - idummy123 + idummy123_0 shl 4, //idx_fOnMouseEnter = 8; idx_fNotifyChild = 78; - idummy123 + idummy123_0 shl 4, //idx_fOnMouseLeave = 9; idx_fScrollChildren = 79; - idummy123_TRUE + idummy123_0 shl 4, //idx_fOnTestMouseOver = 10; idx_fCreateWndExt = 80; - idummy123 + idummy123_0 shl 4, //idx_fGraphCtlMouseEvent = 11; idx_fExMsgProc = 81; - idummy123, //idx_fMouseLeaveProc = 12; - idummy5_TRUE, //idx_fOnScroll = 13; - idummy4_TRUE, //idx_fOnChar = 14; - idummy4_TRUE, //idx_fOnDeadChar = 15; - idummy4_TRUE, //idx_fOnKeyUp = 16; - idummy4_TRUE, //idx_fOnKeyDown = 17; - idummy123, //idx_fOnChangeCtl = 18; - idummy123, //idx_fOnEnter = 19; - idummy123, //idx_fOnLeave = 20; - idummy123, //idx_fLeave = 21; - idummy123, //idx_fOnPaint = 22; - idummy123, //idx_fOnPaint2 = 23; - idummy123, //idx_fOnPrepaint = 24; - idummy123, //idx_fOnPostPaint = 25; - idummy123, //idx_fPaintProc = 26; - idummy123, //idx_fOnEraseBkgnd = 27; - idummy7, //idx_fOnDrawItem = 28; - idummy123_0, //idx_fOnMeasureItem = 29; - idummy6, //idx_fDragCallback = 30; - idummy123, //idx_fOnSelChange = 31; - idummy123, //idx_fOnResize = 32; - idummy123, //idx_fOnHide = 33; - idummy123, //idx_fOnShow = 34; - idummy123, //idx_fOnClose = 35; - idummy123, //idx_fOnMove = 36; - idummy123, //idx_fOnMoving = 37; - idummy4_0, //idx_fOnHelp = 38; - idummy123, //idx_fOnQueryEndSession = 39; - idummy123, //idx_fOnMinimize = 40; - idummy123, //idx_fOnMaximize = 41; - idummy123, //idx_fOnRestore = 42; - idummy10, //idx_fOnLVCustomDraw = 43; - idummy5_TRUE, //idx_fOnEndEditLVITem = 44; - idummy8, //idx_fOnLVData = 45; - idummy4_0, //idx_fOnCompareLVItems = 46; - idummy6, //idx_FOnLVStateChange = 47; - idummy123, //idx_fOnDeleteLVItem = 48; - idummy123, //idx_fOnColumnClick = 49; - idummy6, //idx_FOnSBBeforeScroll = 54; - idummy123, //idx_FOnSBScroll = 55; - idummy123, //idx_FOnDropDown = 56; - idummy123, //idx_FOnCloseUp = 57; - idummy4_TRUE, //idx_FOnSplit = 58; - idummy123, //idx_FOnProgress = 59; - idummy123_0, //idx_FOnBitBtnDraw = 60; - idummy123, //idx_FOnTVBeginDrag = 61; - idummy123_TRUE, //idx_FOnTVBeginEdit = 62; - - idummy4_TRUE, //idx_FOnTVEndEdit = 50; - idummy4_0, //idx_FOnTVExpanding = 52; - idummy4_TRUE, //idx_FOnTVExpanded = 51; - idummy4_TRUE, //idx_FOnTVSelChanging = 53; - - idummy123, //idx_FOnTVDelete = 63; - idummy5_TRUE, //idx_FOnDTPUserString = 64; - idummy123, //idx_FOnREInsModeChg = 65; - idummy123, //idx_FOnREOverURL = 66; - idummy123, //idx_FOnREURLClick = 67; - idummy4_0 //idx_fOnDropFiles = 68; - ); - -{ _TObj } - -procedure Free_And_Nil( var Obj ); -var Obj1: PObj; -begin - Obj1 := PObj( Obj ); - Pointer( Obj ) := nil; - Obj1.Free; -end; - -procedure _TObj.Init; -begin -{$IFDEF _D2orD3} - //FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, 0 ); - ZeroMemory( Pointer( Integer(@Self) + 4 ), Sizeof( Self ) - 4 ); -{$ENDIF} -end; - -function _TObj.VmtAddr: Pointer; -asm - MOV EAX, [EAX] -end; - -{ TObj } - -class function TObj.AncestorOfObject(Obj: Pointer): Boolean; -asm - MOV ECX, [EAX] - MOV EAX, EDX - JMP @@loop1 -@@loop: - MOV EAX,[EAX] -@@loop1: - TEST EAX,EAX - JE @@exit - CMP EAX,ECX - JNE @@loop -@@success: - MOV AL,1 -@@exit: -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -constructor TObj.Create; -begin - Init; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF OLD_REFCOUNT} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TObj.DoDestroy; -begin - {$IFDEF OLD_REFCOUNT} - if fRefCount > 0 then - begin - if not LongBool( fRefCount and 1) then - Dec( fRefCount, 2 ); - RefDec; - end else - Self.Destroy; - if fRefCount <> 0 then - begin - if not LongBool( fRefCount and 1) then - Dec( fRefCount ); - end else - Self.Destroy; - {$ELSE} - if fRefCount > 0 then - RefDec - else Self.Destroy; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} -{$ENDIF OLD_REFCOUNT} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TObj.RefDec: Integer; -begin - Result := 0; // stop Delphi alerting the Warning - if @ Self = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Dec( fRefCount, 2 ); - {$IFDEF OLD_REFCOUNT} - if (fRefCount < 0) and LongBool(fRefCount and 1) then - Destroy; - {$ELSE} - if fRefCount < 0 then - Destroy; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -procedure TObj.RefInc; -begin - Inc( fRefCount, 2 ); -end; - -function TObj.VmtAddr: Pointer; -asm - //MOV EAX, [EAX - 4] - MOV EAX, [EAX] -end; - -function TObj.InstanceSize: Integer; -asm - //MOV EAX, [EAX] - MOV EAX, [EAX-4] -end; - -{$IFDEF OLD_FREE} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure TObj.Free; -begin - RefDec; -end; -{$ENDIF PAS_VERSION} -{$ENDIF OLD_FREE} - -{$UNDEF ASM_LOCAL} -{$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF} -{$IFDEF CRASH_DEBUG} {$UNDEF ASM_LOCAL} {$ENDIF} -{$IFDEF ASM_DEBUG} {$DEFINE ASM_LOCAL} {$ENDIF} - -{$IFDEF ASM_LOCAL} -{$ELSE PAS_VERSION} //Pascal -destructor TObj.Destroy; -begin - Final; - - {$IFDEF DEBUG_ENDSESSION} - if EndSession_Initiated then - LogFileOutput( GetStartDir + 'es_debug.txt', - 'FINALLED: ' + Int2Hex( DWORD( @ Self ), 8 ) - {$IFDEF USE_NAMES} - + ' (name:' + FName + ')' - {$ENDIF} - ); - {$ENDIF} - {$IFDEF USE_NAMES} - fName := ''; - if fNamedObjList <> nil then - Free_And_Nil(fNamedObjList); - {$ENDIF} - {$IFDEF CRASH_DEBUG} - FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, #$DD ); - {$ENDIF} - FreeMem( @ Self ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION} - {$DEFINE ASM_TLIST} -{$IFDEF TLIST_FAST} - {$UNDEF ASM_TLIST} -{$ENDIF} -{$ENDIF} - -{$IFDEF ASM_TLIST} -procedure TObj.Final; -asm //cmd //opd - PUSH EBX - XCHG EBX, EAX - XOR ECX, ECX - XCHG ECX, [EBX].fOnDestroy.TMethod.Code - JECXZ @@freeloop - MOV EDX, EBX - MOV EAX, [EDX].fOnDestroy.TMethod.Data - CALL ECX -@@freeloop: - MOV ECX, [EBX].fAutoFree - JECXZ @@eloop - MOV EDX, [ECX].TList.fItems - MOV ECX, [ECX].TList.fCount - JECXZ @@eloop - MOV EAX, [EDX+ECX*4-4] - MOV EDX, [EDX+ECX*4-8] - PUSH EAX - PUSH EDX - MOV EAX, [EBX].fAutoFree - LEA EDX, [ECX-2] - XOR ECX, ECX - MOV CL, 2 - CALL TList.DeleteRange - POP EDX - POP EAX - CALL EDX - JMP @@freeloop -@@eloop: - XOR EAX, EAX - XCHG [EBX].fAutoFree, EAX - CALL TObj.RefDec -@@exit: - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -procedure TObj.Final; -var N: Integer; - ProcMethod: TMethod; - {$IFDEF _D2orD3} - Proc: TObjectMethod; - {$ELSE} - Proc: TObjectMethod Absolute ProcMethod; - {$ENDIF} -var Destroy_evnt: TOnEvent; -begin - if Assigned( fOnDestroy ) then - begin - Destroy_evnt := fOnDestroy; - fOnDestroy := nil; - Destroy_evnt( @Self ); - end; - while (fAutoFree <> nil) and (fAutoFree.fCount > 0) do - begin - N := fAutoFree.fCount - 2; - ProcMethod.Code := fAutoFree.Items[ N ]; - ProcMethod.Data := fAutoFree.Items[ N + 1 ]; - fAutoFree.DeleteRange( N, 2 ); - {$IFDEF _D2orD3} - Proc := TObjectMethod( ProcMethod ); - {$ENDIF} - Proc; - end; - fAutoFree.Free; - fAutoFree := nil; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TObj.Add2AutoFree(Obj: PObj); -begin - if fAutoFree = nil then - fAutoFree := NewList; - fAutoFree.Insert( 0, Obj ); - fAutoFree.Insert( 0, Pointer( @TObj.RefDec ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod ); -{$IFDEF F_P} -var Ptr1, Ptr2: Pointer; -{$ENDIF F_P} -begin - if fAutoFree = nil then - fAutoFree := NewList; - {$IFDEF F_P} - asm - MOV EAX, [Proc] - MOV [Ptr1], EAX - MOV EAX, [Proc+4] - MOV [Ptr2], EAX - end [ 'EAX' ]; - fAutoFree.Insert( 0, Ptr2 ); - fAutoFree.Insert( 0, Ptr1 ); - {$ELSE DELPHI} - fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Data ) ); - fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Code ) ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure TObj.RemoveFromAutoFree(Obj: PObj); -var i: Integer; -begin - if fAutoFree <> nil then - begin - i := fAutoFree.IndexOf( Obj ); - if i >= 0 then - begin - fAutoFree.DeleteRange( i and not 1, 2 ); - if fAutoFree.Count = 0 then - Free_And_Nil( fAutoFree ); - end; - end; -end; -{$ENDIF PAS_VERSION} - -procedure TObj.RemoveFromAutoFreeEx(Proc: TObjectMethod); -var i: Integer; -begin - if fAutoFree <> nil then - begin - for i := 0 to fAutoFree.Count-2 do - if (fAutoFree.Items[ i ] = TMethod( Proc ).Data) and - (fAutoFree.Items[ i+1 ] = TMethod( Proc ).Code) then - begin - fAutoFree.Delete( i ); - fAutoFree.Delete( i ); - break; - end; - end; -end; - -{$IFDEF USE_NAMES} -procedure TObj.SetName( NewOwnerObj: PObj; NewName: AnsiString ); -{$IFDEF UNIQUE_NAMES} -var i: Integer; -{$ENDIF} -begin - if (FOwnerObj <> nil) then - if FOwnerObj <> NewOwnerObj then - begin - FOwnerObj.fNamedObjList.Remove( @ Self ); - end; - FOwnerObj := NewOwnerObj; - if NewOwnerObj = nil then - begin - if NewName = '' then - begin - fName := ''; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - // здесь тот случай, когда в приложении без Applet'а устанавливается - // имя для главной формы (наверное) - FOwnerObj := @ Self; // владельцем списка именованных объектов становится - // сам объект. Для вышеозначенного случая - главная форма держит себя и - // другие формы. - end; - if FOwnerObj.fNamedObjList = nil then - FOwnerObj.fNamedObjList := NewList; - {$IFDEF UNIQUE_NAMES} - for i := 0 to FOwnerObj.fNamedObjList.Count-1 do - begin - if PObj( FOwnerObj.fNamedObjList.Items[ i ] ).FName = NewName then - begin - NewName := ''; - break; - end; - end; - {$ENDIF} - FName := NewName; - if FName = '' then - FOwnerObj.fNamedObjList.Remove( @ Self ) - else if FOwnerObj.fNamedObjList.IndexOf( @ Self ) < 0 then - FOwnerObj.fNamedObjList.Add( @ Self ); -end; - -function TObj.FindObj(const ObjName: Ansistring): PObj; -var i: Integer; - Obj: PObj; -begin - if fNamedObjList <> nil then - for i := 0 to fNamedObjList.Count-1 do - begin - Obj := fNamedObjList.Items[ i ]; - if ObjName = Obj.FName then - begin - Result := Obj; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := nil; -end; -{$ENDIF} - -{ TList } - -{$IFDEF USE_CONSTRUCTORS} -procedure TList.Init; -begin - {$IFDEF CALL_INHERITED} - inherited; - {$ENDIF} - fAddBy := 4; - {$IFDEF TLIST_FAST} - {$IFNDEF DFLT_TLIST_NOUSE_BLOCKS} // for debug only - fUseBlocks := TRUE; - {$ENDIF} - {$ENDIF} -end; - -function NewList: PList; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - fObjKind := 'TList'; - {$ENDIF} -end; - -{$ELSE not_USE_CONSTRUCTORS} -function NewList: PList; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TList'; - {$ENDIF} - Result.fAddBy := 4; - {$IFDEF TLIST_FAST} - {$IFNDEF DFLT_TLIST_NOUSE_BLOCKS} // for debug only - Result.fUseBlocks := TRUE; - {$ENDIF} - {$ENDIF} -end; -{$ENDIF USE_CONSTRUCTORS} - -{$IFDEF _D4orHigher} -function NewListInit( const AItems: array of Pointer ): PList; -var i: Integer; -begin - Result := NewList; - Result.Capacity := Length( AItems ); - for i := 0 to High( AItems ) do - Result.Add( AItems[ i ] ); -end; -{$ENDIF} - -{$IFNDEF PAS_ONLY} -procedure HelpFastIncNum2Els( DataArray: Pointer; Value, Count: Integer ); -asm - PUSH ESI - PUSH EDI - {$IFDEF F_P} - MOV ESI, [DataArray] - MOV EDX, [Value] - MOV ECX, [Count] - {$ELSE DELPHI} - MOV ESI, EAX - {$ENDIF F_P/DELPHI} - MOV EDI, ESI - CLD - -@@1: - LODSD - ADD EAX, EDX - STOSD - LOOP @@1 - - POP EDI - POP ESI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; - -{$IFNDEF TLIST_FAST} -procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer ); -begin - HelpFastIncNum2Els( @List.fItems[ FromIdx ], Value, Count ); -end; -{$ENDIF} -{$ENDIF PAS_ONLY} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TList.Destroy; -begin - Clear; - inherited; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -procedure TList.Release; -asm - TEST EAX, EAX - JZ @@e - MOV ECX, [EAX].fCount - JECXZ @@e - MOV EDX, [EAX].fItems - PUSH EAX -@@1: - MOV EAX, [EDX+ECX*4-4] - TEST EAX, EAX - JZ @@2 - PUSH EDX - PUSH ECX - CALL System.@FreeMem - POP ECX - POP EDX -@@2: LOOP @@1 - POP EAX -@@e: CALL TObj.RefDec -end; -{$ELSE PAS_VERSION} //Pascal -procedure TList.Release; -var I: Integer; -begin - if @ Self = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - for I := 0 to fCount - 1 do - if {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ] <> nil then - FreeMem( {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ] ); - Free; -end; -{$ENDIF PAS_VERSION} - -procedure TList.ReleaseObjects; -var I: Integer; -begin - if @ Self = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - for I := fCount-1 downto 0 do - PObj( {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} [ I ] ).Free; - Free; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TList.SetCapacity( Value: Integer ); -begin - {$IFDEF TLIST_FAST} - if fUseBlocks and (fBlockList <> nil) then - begin - if Value > 256 then // Capacitity в обычном смысле работает только для первого - Value := 256; // блока - до 256 элементов, далее оно смысла не имеет, - fCapacity := Value; // т.к. все прочие блоки всегда содержат по 256 позиций - // для элементов, независимо от процента использования. - end else - {$ENDIF} - begin - if Value < Count then - Value := Count; - if Value = fCapacity then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ReallocMem( fItems, Value * Sizeof( Pointer ) ); - fCapacity := Value; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TList.Clear; -{$IFDEF TLIST_FAST} -var i: Integer; -{$ENDIF} -begin - if fItems <> nil then - FreeMem( fItems ); - fItems := nil; - fCount := 0; - fCapacity := 0; - {$IFDEF TLIST_FAST} - if fBlockList <> nil then - begin - for i := 0 to fBlockList.Count div 2 - 1 do - FreeMem( fBlockList.Items[ i*2 ] ); - Free_And_Nil( fBlockList ); - end; - fLastKnownBlockIdx := 0; - fLastKnownCountBefore := 0; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -procedure TList.SetAddBy(Value: Integer); -begin - if Value < 1 then Value := 1; - fAddBy := Value; -end; - -{$IFDEF ASM_NO_VERSION} /// ASM-version disabled due some problems - 20-May-2010 -{$ELSE PAS_VERSION} //Pascal -procedure TList.Add( Value: Pointer ); -{$IFDEF TLIST_FAST} -var LastBlockCount: Integer; - LastBlockStart: Pointer; -{$ENDIF} -begin - {$IFDEF TLIST_FAST} - if fUseBlocks and ((fCount >= 256) or ( fBlockList <> nil )) then - begin - if fBlockList = nil then - begin - fBlockList := NewList; - fBlockList.fUseBlocks := FALSE; - fBlockList.Add( fItems ); - fBlockList.Add( Pointer( fCount ) ); - fItems := nil; - end; - if fBlockList.fCount = 0 then - begin - fBlockList.Add( nil ); - fBlockList.Add( nil ); - LastBlockCount := 0; - end else - begin - LastBlockCount := Integer( fBlockList.Items[ fBlockList.fCount-1 ] ); - if LastBlockCount >= 256 then - begin - fBlockList.Add( nil ); - fBlockList.Add( nil ); - LastBlockCount := 0; - end; - end; - LastBlockStart := fBlockList.Items[ fBlockList.fCount-2 ]; - if LastBlockStart = nil then - begin - GetMem( LastBlockStart, 256 * Sizeof( Pointer ) ); - fBlockList.Items[ fBlockList.fCount-2 ] := LastBlockStart; - end; - fBlockList.Items[ fBlockList.fCount-1 ] := Pointer( LastBlockCount+1 ); - PDWORD( Integer(LastBlockStart) + Sizeof(Pointer)*LastBlockCount )^ := - DWORD( Value ); - end else - {$ENDIF} - begin - if fCapacity <= fCount then - begin - if fAddBy <= 0 then - Capacity := fCount + Min( 1000, fCount div 4 + 1 ) - else Capacity := fCount + fAddBy; - end; - fItems[ fCount ] := Value; - end; - Inc( fCount ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF _D4orHigher} -procedure TList.AddItems(const AItems: array of Pointer); -var i: Integer; -begin - Capacity := Count + Length( AItems ); - for i := 0 to High( AItems ) do - Add( AItems[ i ] ); -end; -{$ENDIF} - -procedure TList.Delete( Idx: Integer ); -begin - DeleteRange( Idx, 1 ); -end; - -{$IFDEF ASM_TLIST} -procedure TList.DeleteRange(Idx, Len: Integer); -asm //cmd //opd - TEST ECX, ECX - JLE @@exit - CMP EDX, [EAX].fCount - JGE @@exit - PUSH EBX - XCHG EBX, EAX - LEA EAX, [EDX+ECX] - CMP EAX, [EBX].fCount - JBE @@1 - MOV ECX, [EBX].fCount - SUB ECX, EDX -@@1: - MOV EAX, [EBX].fItems - PUSH [EBX].fCount - SUB [EBX].fCount, ECX - MOV EBX, EDX - LEA EDX, [EAX+EDX*4] - LEA EAX, [EDX+ECX*4] - ADD EBX, ECX - POP ECX - SUB ECX, EBX - SHL ECX, 2 - CALL System.Move - POP EBX -@@exit: -end; -{$ELSE PAS_VERSION} //Pascal -procedure TList.DeleteRange(Idx, Len: Integer); -{$IFDEF TLIST_FAST} -var i, DelFromBlock: Integer; - CountBefore, CountCurrent: Integer; - BlockStart: Pointer; -{$ENDIF} -begin - if Len <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Idx >= Count then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF KOL_ASSERTIONS} - Assert( (Idx >= 0), 'TList.DeleteRange: index out of bounds' ); - {$ENDIF KOL_ASSERTIONS} - if DWORD( Idx + Len ) > DWORD( Count ) then - Len := Count - Idx; - {$IFDEF TLIST_FAST} - if fUseBlocks and ( fBlockList <> nil ) then - begin - CountBefore := 0; - i := 0; - if (fLastKnownBlockIdx > 0) and - (Idx >= fLastKnownCountBefore) then - begin - i := fLastKnownBlockIdx; - CountBefore := fLastKnownCountBefore; - end; - while i < fBlockList.fCount div 2 do - begin - BlockStart := fBlockList.fItems[ i * 2 ]; - CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] ); - if (Idx >= CountBefore) and (Idx < CountBefore + CountCurrent) then - begin - DelFromBlock := CountBefore + CountCurrent - Idx; - if DelFromBlock > Len then - DelFromBlock := Len; - if DelFromBlock < CountCurrent then - begin - fNotOptimized := TRUE; - move( Pointer( Integer( BlockStart ) + (Idx - CountBefore + DelFromBlock) * Sizeof( Pointer ) )^, - Pointer( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^, - (CountCurrent - (Idx - CountBefore) - DelFromBlock) * Sizeof( Pointer ) ); - dec( CountCurrent, DelFromBlock ); - fBlockList.fItems[ i * 2 + 1 ] := Pointer( CountCurrent ); - dec( fCount, DelFromBlock ); - dec( Len, DelFromBlock ); - if Len <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end else - begin // delete entire block - //++ fix added: 21.06.08 ++ VK - fLastKnownBlockIdx := 0; - fLastKnownCountBefore := 0; - //++++++++++++++++++++++++++++ - FreeMem( BlockStart ); - fBlockList.DeleteRange( i * 2, 2 ); - dec( fCount, CountCurrent ); - dec( Len, CountCurrent ); - if Len <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - CountCurrent := 0; - dec( i ); - end; - end; - inc( i ); - inc( CountBefore, CountCurrent ); - end; - end else - {$ENDIF} - begin - Move( fItems[ Idx + Len ], fItems[ Idx ], Sizeof( Pointer ) * (Count - Idx - Len) ); - Dec( fCount, Len ); - end; -end; -{$ENDIF PAS_VERSION} - -procedure TList.Remove(Value: Pointer); -var I: Integer; -begin - I := IndexOf( Value ); - if I >= 0 then - Delete( I ); -end; - -function TList.ItemAddress(Idx: Integer): Pointer; -{$IFDEF TLIST_FAST} -var i: Integer; - BlockStart: Pointer; - CountBefore, CountCurrent: Integer; -{$ENDIF} -begin - {$IFDEF TLIST_FAST} - if fUseBlocks and ( fBlockList <> nil ) then - begin - CountBefore := 0; - i := 0; - if (fLastKnownBlockIdx > 0) and - (Idx >= fLastKnownCountBefore) then - begin - CountBefore := fLastKnownCountBefore; - i := fLastKnownBlockIdx; - end; - CountCurrent := CountBefore + Integer( fBlockList.fItems[ i*2+1 ] ); - if Idx - CountCurrent > fCount - CountCurrent then - begin // поиск в обратном направлении может оказаться быстрее - CountBefore := fCount; - i := fBlockList.fCount div 2 - 1; - while TRUE do - begin - BlockStart := fBlockList.fItems[ i * 2 ]; - CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] ); - if (CountBefore - CountCurrent <= Idx) and (Idx < CountBefore) then - begin - Result := Pointer( Integer( BlockStart ) + - (Idx - (CountBefore - CountCurrent))*Sizeof( Pointer ) ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - dec( CountBefore, CountCurrent ); - dec( i ); - end; - end; - while TRUE { i < fBlockList.Count div 2 } do - begin - BlockStart := fBlockList.fItems[ i * 2 ]; - CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] ); - if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then - begin - Result := Pointer( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - inc( CountBefore, CountCurrent ); - inc( i ); - end; - end else - {$ENDIF} - Result := Pointer( Integer( fItems ) + Idx * Sizeof( Pointer ) ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure TList.Put( Idx: Integer; Value: Pointer ); -{$IFDEF TLIST_FAST} -var i: Integer; - BlockStart: Pointer; - CountBefore, CountCurrent: Integer; -{$ENDIF} -begin - if Idx < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Idx >= Count then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF TLIST_FAST} - if fUseBlocks and ( fBlockList <> nil ) then - begin - CountBefore := 0; - i := 0; - if (fLastKnownBlockIdx > 0) and - (Idx >= fLastKnownCountBefore) then - begin - i := fLastKnownBlockIdx; - CountBefore := fLastKnownCountBefore; - end; - while i < fBlockList.fCount div 2 do - begin - BlockStart := fBlockList.fItems[ i * 2 ]; - CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] ); - if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then - begin - fLastKnownBlockIdx := i; - fLastKnownCountBefore := CountBefore; - PDWORD( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ := - DWORD( Value ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - inc( CountBefore, CountCurrent ); - inc( i ); - end; - end else - {$ENDIF} - fItems[ Idx ] := Value; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function TList.Get( Idx: Integer ): Pointer; -{$IFDEF TLIST_FAST} -var i: Integer; - BlockStart: Pointer; - CountBefore, CountCurrent: Integer; -{$ENDIF} -begin - Result := nil; - if Idx < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Idx >= fCount then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF TLIST_FAST} - if fUseBlocks and ( fBlockList <> nil ) then - begin - if fNotOptimized then - begin - CountBefore := 0; - i := 0; - if (fLastKnownBlockIdx > 0) and - (Idx >= fLastKnownCountBefore) then - begin - i := fLastKnownBlockIdx; - CountBefore := fLastKnownCountBefore; - end; - while {i < fBlockList.fCount div 2} TRUE do - begin - BlockStart := fBlockList.fItems[ i * 2 ]; - CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] ); - if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then - begin - fLastKnownBlockIdx := i; - fLastKnownCountBefore := CountBefore; - Result := Pointer( PDWORD( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - inc( CountBefore, CountCurrent ); - inc( i ); - end; - end else - begin // optimized! - i := Idx shr 8; - BlockStart := fBlockList.fItems[ i * 2 ]; - i := Idx and 255; - Result := Pointer( PDWORD( Integer( BlockStart ) + i * Sizeof( Pointer ) )^ ); - end; - end else - {$ENDIF} - Result := fItems[ Idx ]; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -function TList.IndexOf( Value: Pointer ): Integer; -asm - PUSH EDI - - MOV EDI, [EAX].fItems - MOV ECX, [EAX].fCount - PUSH EDI - DEC EAX // make "NZ" - EAX always <> 1 - MOV EAX, EDX - REPNZ SCASD - POP EDX - {$IFDEF USE_CMOV} - CMOVNZ EDI, EDX - {$ELSE} - JZ @@succ - MOV EDI, EDX -@@succ: {$ENDIF} - - MOV EAX, EDI - STC - SBB EAX, EDX - SAR EAX, 2 - - POP EDI -end; -{$ELSE PAS_VERSION} //Pascal -function TList.IndexOf( Value: Pointer ): Integer; -var I: Integer; - {$IFDEF TLIST_FAST} - BlockStart: PDWORD; - j: Integer; - CountBefore, CountCurrent: Integer; - {$ENDIF} -begin - Result := -1; - {$IFDEF DEBUG_ANY} - TRY - {$ENDIF} - {$IFDEF TLIST_FAST} - if fUseBlocks and ( fBlockList <> nil ) then - begin - CountBefore := 0; - for I := 0 to fBlockList.fCount div 2 - 1 do - begin - BlockStart := fBlockList.fItems[ I * 2 ]; - CountCurrent := Integer( fBlockList.fItems[ I * 2 + 1 ] ); - for j := 0 to CountCurrent-1 do - begin - if BlockStart^ = DWORD( Value ) then - begin - Result := CountBefore + j; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - inc( BlockStart ); - end; - inc( CountBefore, CountCurrent ); - end; - end else - {$ENDIF} - begin - for I := 0 to fCount - 1 do - begin - if fItems[ I ] = Value then - begin - Result := I; - break; - end; - end; - end; - {$IFDEF DEBUG_ANY} - EXCEPT - END; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -procedure TList.Insert(Idx: Integer; Value: Pointer); -asm - PUSH ECX - PUSH EAX - PUSH [EAX].fCount - PUSH EDX - CALL TList.Add // don't matter what to add - POP EDX // EDX = Idx, Eax = Count-1 - POP EAX - SUB EAX, EDX - - SAL EAX, 2 - MOV ECX, EAX // ECX = (Count - Idx - 1) * 4 - POP EAX - MOV EAX, [EAX].fItems - LEA EAX, [EAX + EDX*4] - JL @@1 - PUSH EAX - LEA EDX, [EAX + 4] - CALL System.Move - - POP EAX // EAX = @fItems[ Idx ] -@@1: - POP ECX // ECX = Value - MOV [EAX], ECX -end; -{$ELSE PAS_VERSION} //Pascal -procedure TList.Insert(Idx: Integer; Value: Pointer); -{$IFDEF TLIST_FAST} -var i: Integer; - CountBefore, CountCurrent: Integer; - BlockStart, NewBlock: Pointer; -{$ENDIF} -begin - {$IFDEF KOL_ASSERTIONS} - Assert( (Idx >= 0) and (Idx <= FCount+1), 'List index out of bounds' ); - {$ENDIF KOL_ASSERTIONS} - {$IFDEF TLIST_FAST} - if fUseBlocks and (( fBlockList <> nil ) or (fCount >= 256)) then - begin - if ( fBlockList = nil ) then - begin - fBlockList := NewList; - fBlockList.fUseBlocks := FALSE; - fBlockList.Add( fItems ); - fBlockList.Add( Pointer( fCount ) ); - fItems := nil; - end; - if fBlockList.fCount = 0 then - begin - fNotOptimized := FALSE; - GetMem( NewBlock, 256 * Sizeof( Pointer ) ); - fBlockList.Add( NewBlock ); - fBlockList.Add( nil ); - end; - CountBefore := 0; - i := 0; - if (fLastKnownBlockIdx > 0) and - (Idx >= fLastKnownCountBefore) then - begin - i := fLastKnownBlockIdx; - CountBefore := fLastKnownCountBefore; - end; - while TRUE {i < fBlockList.fCount div 2} do - begin - CountCurrent := Integer( fBlockList.Items[ i * 2 + 1 ] ); - if (Idx >= CountBefore) and - ((Idx < CountBefore + CountCurrent) or - (Idx = CountBefore + CountCurrent) and - (CountCurrent < 256)) then // insert in block i - begin - BlockStart := fBlockList.fItems[ i * 2 ]; - if BlockStart = nil then - begin - GetMem( BlockStart, 256 * Sizeof( Pointer ) ); - fBlockList.fItems[ i * 2 ] := BlockStart; - end; - Idx := Idx - CountBefore; - if CountCurrent < 256 then - begin - if Idx < CountCurrent then - Move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^, - Pointer( Integer( BlockStart ) + (Idx+1) * Sizeof( Pointer ) )^, - (CountCurrent - Idx) * Sizeof( Pointer ) ); - PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ := - DWORD( Value ); - fBlockList.fItems[ i * 2 + 1 ] := Pointer( CountCurrent + 1 ); - end else // new block is created since current block is full 256 items - begin - fNotOptimized := TRUE; - GetMem( NewBlock, 256 * Sizeof( Pointer ) ); - fBlockList.Insert( (i+1)*2, Pointer( 256-Idx ) ); - fBlockList.Insert( (i+1)*2, NewBlock ); - move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^, - NewBlock^, (256 - Idx) * Sizeof( Pointer ) ); - PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ := - DWORD( Value ); - fBlockList.fItems[ i * 2 + 1 ] := Pointer( Idx + 1 ); - end; - fLastKnownBlockIdx := i; - fLastKnownCountBefore := CountBefore; - inc( fCount ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - inc( CountBefore, CountCurrent ); - inc( i ); - if i >= fBlockList.fCount div 2 then - begin - fBlockList.Add( nil ); - fBlockList.Add( nil ); - end; - end; - end else - {$ENDIF} - begin - Add( nil ); - if fCount > Idx then - Move( FItems[ Idx ], FItems[ Idx + 1 ], (fCount - Idx - 1) * Sizeof( Pointer ) ); - FItems[ Idx ] := Value; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION} {$DEFINE MoveItem_ASM} {$ENDIF} -{$IFDEF TLIST_FAST} {$UNDEF MoveItem_ASM} {$ENDIF} - -{$IFDEF MoveItem_ASM} -{$ELSE PAS_VERSION} //Pascal -procedure TList.MoveItem(OldIdx, NewIdx: Integer); -var Item: Pointer; -begin - if OldIdx = NewIdx then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if NewIdx >= Count then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Item := Items[ OldIdx ]; - Delete( OldIdx ); - Insert( NewIdx, Item ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -function TList.Last: Pointer; -asm //cmd //opd - MOV ECX, [EAX].fCount - JECXZ @@0 - MOV EAX, [EAX].fItems - DEC ECX - MOV ECX, [EAX + ECX*4] -@@0: XCHG EAX, ECX -end; -{$ELSE PAS_VERSION} //Pascal -function TList.Last: Pointer; -begin - if Count = 0 then - Result := nil - else Result := Items[ Count-1 ]; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -procedure TList.Swap(Idx1, Idx2: Integer); -asm - MOV EAX, [EAX].fItems - PUSH dword ptr [EAX + EDX*4] - PUSH ECX - MOV ECX, [EAX + ECX*4] - MOV [EAX + EDX*4], ECX - POP ECX - POP EDX - MOV [EAX + ECX*4], EDX -end; -{$ELSE PAS_VERSION} //Pascal -procedure TList.Swap(Idx1, Idx2: Integer); -var Tmp: DWORD; - AItem1, AItem2: PDWORD; -begin - {$IFDEF TLIST_FAST} - AItem1 := ItemAddress( Idx1 ); - AItem2 := ItemAddress( Idx2 ); - {$ELSE} - AItem1 := Pointer( Integer( fItems ) + Idx1 * Sizeof( Pointer ) ); - AItem2 := Pointer( Integer( fItems ) + Idx2 * Sizeof( Pointer ) ); - {$ENDIF} - Tmp := AItem1^; - AItem1^ := AItem2^; - AItem2^ := Tmp; -end; -{$ENDIF PAS_VERSION} - -procedure TList.SetCount(const Value: Integer); -begin - if Value >= Count then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fCount := Value; -end; - -procedure TList.Assign(SrcList: PList); -{$IFDEF TLIST_FAST} -var i, CountCurrent: Integer; - SrcBlock, DstBlock: Pointer; -{$ENDIF} -begin - Clear; - if SrcList.fCount > 0 then - begin - {$IFDEF TLIST_FAST} - if SrcList.fUseBlocks and ( SrcList.fBlockList <> nil ) then - begin - fBlockList := NewList; - fBlockList.Assign( SrcList.fBlockList ); - for i := 0 to fBlockList.Count div 2 - 1 do - begin - SrcBlock := SrcList.fBlockList.fItems[ i*2 ]; - CountCurrent := Integer( fBlockList.fItems[ i*2+1 ] ); - GetMem( DstBlock, 256 * Sizeof( Pointer ) ); - fBlockList.fItems[ i*2 ] := DstBlock; - move( SrcBlock^, DstBlock^, CountCurrent ); - end; - end else - {$ENDIF} - begin - Capacity := SrcList.fCount; - Move( SrcList.FItems[ 0 ], FItems[ 0 ], Sizeof( Pointer ) * SrcList.fCount ); - end; - end; - fCount := SrcList.fCount; -end; - -{$IFDEF WIN_GDI} - -{$UNDEF ASM_LOCAL} -{$IFDEF ASM_noVERSION} - {$IFNDEF _D2orD3} - {$DEFINE ASM_LOCAL} - {$ENDIF} -{$ENDIF} - -{$IFDEF ASM_LOCAL} //!!//!! -function CallCtlWndProc( Ctl: PControl; var Msg: TMsg ): Integer; -begin - Result := Ctl.WndProc( Msg ); -end; - -{ -- Window procedure -- } -function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer ) - : Integer; stdcall; -const size_TMsg = sizeof( TMsg ); -asm - ADD ESP, -size_TMsg - MOV EDX, ESP - - PUSH ESI - PUSH EDI - - MOV EDI, EDX - LEA ESI, [W] - - MOVSD - MOVSD - MOVSD - MOVSD - - MOV EDI, EDX - MOV EAX, [EDI] - TEST EAX, EAX - JZ @@self_is_nil - - MOV ECX, [CreatingWindow] - JECXZ @@get_self_prop - - MOV [ECX].TControl.fHandle, EAX - - PUSH ECX - PUSH ECX - {$IFDEF USE_PROP} - PUSH Offset[ID_SELF] - PUSH EAX - CALL SetProp - {$ELSE} - PUSH GWL_USERDATA - PUSH EAX - CALL SetWindowLong - {$ENDIF} - - XOR EAX, EAX - MOV [CreatingWindow], EAX - POP EAX // EAX = self_ - JMP @@self_got - -@@get_self_prop: - {$IFDEF USE_PROP} - PUSH Offset[ID_SELF] - PUSH EAX - CALL GetProp - {$ELSE} - PUSH GWL_USERDATA - PUSH EAX - CALL GetWindowLong - {$ENDIF} - TEST EAX, EAX - JNZ @@self_got - -@@self_is_nil: - OR EAX, [ Applet ] - JNZ @@self_got - - POP EDI - POP ESI - MOV ESP, EBP - POP EBP - JMP DefWindowProc - -@@self_got: - MOV ESI, EAX - INC WORD PTR [ESI].TControl.fNestedMsgHandling - MOV EDX, EDI - CALL CallCtlWndProc - DEC WORD PTR [ESI].TControl.fNestedMsgHandling - JA @@1 - {$IFDEF USE_FLAGS} - TEST [ESI].TControl.fFlagsG2, (1 shl G2_BeginDestroying) - JZ @@1 - {$ELSE} - CMP [ESI].TControl.fBeginDestroying, 0 - JZ @@1 - {$ENDIF} - CMP [ESI].TObj.fRefCount, 0 - JNZ @@1 - CMP ESI, [Applet] - JZ @@1 - XCHG EAX, ESI - CALL TObj.Free - XCHG ESI, EAX -@@1: - - POP EDI - POP ESI - - MOV ESP, EBP -end; -{$ELSE PAS_VERSION} //Pascal -function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer ) - : Integer; stdcall; -var M: TMsg; - self_: PControl; -begin - {$IFDEF INPACKAGE} - Log( '->WndFunc ' + Int2Hex( Msg, 4 ) + ' (' + Int2Str( Msg ) + ')' ); - TRY - {$ENDIF INPACKAGE} - - M.hwnd := W; - M.message := Msg; - M.wParam := wParam; - M.lParam := lParam; - - {$IFDEF DEBUG_MONITOR_MESSAGES} - if Assigned( OnMonitorMessage ) then - OnMonitorMessage( M, TRUE ); - {$ENDIF} - - {$IFDEF DEBUG_ENDSESSION} - if EndSession_Initiated then - begin - LogFileOutput( GetStartDir + 'es_debug.txt', - 'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) + - ' WParam: ' + Int2Str( wParam ) + '($' + Int2Hex( wParam, 8 ) + ')' + - ' LParam: ' + Int2Str( lParam ) + '($' + Int2Hex( lParam, 8 ) + ')' ); - end; - {$ENDIF} - - self_ := nil; - if W <> 0 then - begin - if CreatingWindow <> nil then - begin - {$IFDEF INPACKAGE} - Log( '//// CreatingWindow <> nil' ); - {$ENDIF INPACKAGE} - {$IFDEF DEBUG_CREATEWINDOW} - LogFileOutput( GetStartDir + 'Session.log', - 'WndFunc: Creating window = ' + Int2Hex( Integer( CreatingWindow ), 4 ) + - ' hwnd=' + Int2Str( M.hwnd ) + - ' message=' + Int2Hex( M.message, 4 ) + - ' wParam=' + Int2Str( M.wParam ) + '=$' + Int2Hex( M.wParam, 4 ) + - ' lParam=' + Int2Str( M.lParam ) + '=$' + Int2Hex( M.lParam, 4 ) - ); - {$ENDIF DEBUG_CREATEWINDOW} - self_ := CreatingWindow; - CreatingWindow.fHandle := W; - {$IFDEF USE_PROP} - {$IFDEF INPACKAGE} - Log( '//// SetProp' ); - {$ENDIF INPACKAGE} - SetProp( W, ID_SELF, THandle( CreatingWindow ) ); - {$ELSE} - SetWindowLong( W, GWL_USERDATA, Integer( CreatingWindow ) ); - {$ENDIF} - CreatingWindow := nil; - end else - {$IFDEF USE_PROP} - self_ := Pointer( GetProp( W, ID_SELF ) ); - {$ELSE} - self_ := Pointer( GetWindowLong( W, GWL_USERDATA ) ); - {$ENDIF} - end; - - if self_ <> nil then - begin - {$IFDEF INPACKAGE} - Log( '//// self_ <> nil, calling self_.WndProc' ); - {$ENDIF INPACKAGE} - //self_.RefInc; - //TRY - Result := self_.WndProc( M ); - //FINALLY - // self_.RefDec; - //END; - end else - if Applet <> nil then - Result := Applet.WndProc( M ) - else Result := DefWindowProc( W, Msg, wParam, lParam ); - {$IFDEF DEBUG_ENDSESSION} - if EndSession_Initiated then - begin - LogFileOutput( GetStartDir + 'es_debug.txt', - 'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) + - ' Result: ' + Int2Str( Result ) + '($' + Int2Hex( Result, 8 ) + ')' ); - end; - {$ENDIF} - {$IFDEF INPACKAGE} - LogOK; - FINALLY - Log( '<-WndFunc' ); - END; - {$ENDIF INPACKAGE} - {$IFDEF DEBUG_MONITOR_MESSAGES} - if Assigned( OnMonitorMessage ) then - OnMonitorMessage( M, FALSE ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -procedure TList.OptimizeForRead; -{$IFDEF TLIST_FAST} -var i, j, N: Integer; - NewBlocksList: PList; - BlockStart: PPointer; -{$ENDIF} -begin - {$IFDEF TLIST_FAST} - if fNotOptimized and fUseBlocks then - begin - NewBlocksList := NewList; - NewBlocksList.UseBlocks := FALSE; - i := 0; - while i < Count do - begin - N := 256; - if N > Count-i then - N := Count-i; - GetMem( BlockStart, 256 * Sizeof(Pointer) ); - NewBlocksList.Add( BlockStart ); - NewBlocksList.Add( Pointer(N) ); - for j := i to i+N-1 do - begin - BlockStart^ := Items[j]; - inc( BlockStart ); - end; - inc( i, 256 ); - end; - N := Count; - Clear; - Free_And_Nil( fBlockList ); - fBlockList := NewBlocksList; - fCount := N; - fNotOptimized := FALSE; - end; - {$ENDIF} -end; - -var - IdleHandlers: PList; - ProcessIdle: procedure ( Sender: PObj ) = DummyObjProc; - -procedure ProcessIdleProc( Sender: PObj ); -var - i: integer; - m: TMethod; -begin - if AppletTerminated then exit; // YS + >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - i := 0; - with IdleHandlers^ do - while i < Count do begin - m.Code:=Items[i]; - Inc(i); - m.Data:=Items[i]; - Inc(i); - TOnEvent(m)(Sender); - end; -end; - -function FindIdleHandler( const OnIdle: TOnEvent ): integer; -var - i: integer; -begin - i := 0; - if not AppletTerminated then //+ {Maxim Pushkar} - with TMethod(OnIdle), IdleHandlers^ do - while i < Count do begin - if (Items[i] = Code) and (Items[i + 1] = Data) then - begin - Result := i; - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Inc(i, 2); - end; - Result := -1; -end; - -procedure RegisterIdleHandler( const OnIdle: TOnEvent ); -begin - if IdleHandlers = nil then begin - IdleHandlers := NewList; - if Applet <> nil then - Applet.Add2AutoFree(IdleHandlers); - end; - with TMethod(OnIdle) do - begin - IdleHandlers.Add(Code); - IdleHandlers.Add(Data); - end; - ProcessIdle := @ProcessIdleProc; -end; - -procedure UnRegisterIdleHandler( const OnIdle: TOnEvent ); -var - i: integer; -begin - i := FindIdleHandler(OnIdle); - if i <> -1 then - with IdleHandlers^ do - begin - Delete(i); - Delete(i); - end; -end; - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure TerminateExecution( var AppletCtl: PControl ); -var App: PControl; - Appalreadyterminated: Boolean; -begin - Appalreadyterminated := AppletTerminated; - AppletTerminated := TRUE; - AppletRunning := FALSE; - App := Applet; - Applet := nil; - if (App <> nil) {and (App.RefCount >= 0)} then - begin - App.RefInc; - if not Appalreadyterminated then - begin - App.ProcessMessages; - App.Perform( WM_CLOSE, 0, 0 ); - end; - AppletCtl := nil; - App.Free; - App.RefDec; - end; -end; -{$ENDIF PAS_VERSION} - -//22{$IFDEF ASM_VERSION} -function CallTControlCreateWindow( Ctl: PControl ): Boolean; -begin - {$IFDEF SAFE_CODE} - Result := FALSE; - TRY - if Ctl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Ctl.CreateWindow; - EXCEPT - END; - {$ELSE} - Result := Ctl.CreateWindow; - {$ENDIF} -end; -//22{$ENDIF} -{$ENDIF GDI} -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure Run( var AppletCtl: PControl ); - {$IFDEF PSEUDO_THREADS} -var n: Integer; - i: Integer; - T: PThread; - u: DWORD; - M: TMsg; - {$ENDIF} -begin - if AppletCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - AppletRunning := True; - Applet := AppletCtl; - AppletCtl.CreateWindow; //virtual!!! - //Applet_Wnd := AppletCtl.Handle; - while not AppletTerminated do - begin - {$IFDEF PSEUDO_THREADS} - if MainThread <> nil then - begin - while not PeekMessage( M, 0, 0, 0, pm_noremove ) do - begin - u := GetTickCount; - n := 0; - for i := 1 to MainThread.AllThreads.Count-1 do - begin - T := MainThread.AllThreads.Items[ i ]; - if not T.Suspended and not T.Terminated and (T.DoNotWakeUntil < u) then - begin - inc( n ); - break; - end; - end; - if n = 0 then WaitMessage - else MainThread.NextThread; - end; - end else - WaitMessage; - {$ELSE} - WaitMessage; - {$ENDIF} - AppletCtl.ProcessMessages; - {$IFDEF USE_OnIdle} - ProcessIdle( AppletCtl ); - {$ENDIF} - end; - if Assigned( AppletCtl ) then - TerminateExecution( AppletCtl ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} - PROCEDURE Run( var AppletWnd: PControl ); - BEGIN - AppletRunning := True; - Applet := AppletWnd; - AppletWnd.VisualizyWindow; // for GTK, show all windows having Visible = TRUE, recursively - gtk_main( ); - IF AppletWnd <> nil THEN - //TerminateExecution( AppletWnd ); - Free_And_Nil( AppletWnd ); - END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -{$IFDEF GDI} -procedure AppletMinimize; -begin - if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Applet.Perform( WM_SYSCOMMAND, SC_MINIMIZE, 0 ); -end; - -procedure AppletHide; -begin - if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - AppletMinimize; - Applet.Hide; -end; - -procedure AppletRestore; -begin - if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Applet.Show; - Applet.Perform( WM_SYSCOMMAND, SC_RESTORE, 0 ); -end; - -function ScreenWidth: Integer; -begin - Result := GetSystemMetrics( SM_CXSCREEN ); -end; - -function ScreenHeight: Integer; -begin - Result := GetSystemMetrics( SM_CYSCREEN ); -end; -{$ENDIF GDI} - -//22{$IFDEF ASM_VERSION} -//function WndProcAppAsm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -//22{$ENDIF} -function WndProcAppPas( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function WndProcForm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward; -var fGlobalProcKeybd: function( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean = - WndProcDummy; - -{ -- Graphics support -- } - -{$ENDIF WIN_GDI} -function _NewGraphicTool: PGraphicTool; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TGraphicTool'; - {$ENDIF} -end; -{$IFDEF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION PAS_VERSION} -function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush; -{$IFDEF STORE_fTmpBrushColorRGB}{$ELSE} -var tmpRGBColor: TColor; -{$ENDIF} -begin - if (Sender.fParent <> nil) and (Sender.fColor = Sender.fParent.fColor) then - Result := SimpleGetCtlBrushHandle( Sender.fParent ) - else - begin - {$IFDEF GDI} - {$IFDEF STORE_fTmpBrushColorRGB} - if (Sender.fTmpBrush <> 0) and - (Color2RGB( Sender.fColor ) <> Sender.fTmpBrushColorRGB) then - begin - DeleteObject( Sender.fTmpBrush ); - Sender.fTmpBrush := 0; - end; - {$ENDIF} - if Sender.fTmpBrush = 0 then - begin - {$IFDEF STORE_fTmpBrushColorRGB} - Sender.fTmpBrushColorRGB := Color2RGB( Sender.fColor ); - Sender.fTmpBrush := CreateSolidBrush( Sender.fTmpBrushColorRGB ); - {$ELSE} - tmpRGBColor := Color2RGB( Sender.fColor ); - Sender.fTmpBrush := CreateSolidBrush( tmpRGBColor ); - {$ENDIF} - end; - Result := Sender.fTmpBrush; - {$ELSE} Result := 0; - {$ENDIF GDI} - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE notASM_VERSION} -function NormalGetCtlBrushHandle( Sender: PControl ): HBrush; -var B: PGraphicTool; - //P: PControl; -begin - {$IFDEF GDI} - B := Sender.Brush; - //P := Sender.fParent; - //if P <> nil then - if Sender.fParent <> nil then - B.fParentGDITool := Sender.fParent.Brush; //P.Brush; - Result := B.Handle; - {$ELSE} Result := 0; - {$ENDIF GDI} -end; -{$ENDIF PAS_VERSION} - -function MakeFontHandle( Self_: PGraphicTool ): THandle; forward; -function MakeBrushHandle( Self_: PGraphicTool ): THandle; forward; -function MakePenHandle( Self_: PGraphicTool ): THandle; forward; -function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle; forward; - -{$ENDIF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewBrush: PGraphicTool; -begin - {$IFDEF GDI} - Global_GetCtlBrushHandle := NormalGetCtlBrushHandle; - {$ENDIF GDI} - Result := _NewGraphicTool; - with Result^ do - begin - fNewProc := @ NewBrush; - fType := gttBrush; - {$IFDEF GDI} - fMakeHandleProc := @ MakeBrushHandle; - {$ENDIF GDI} - Result.fData.Color := clBtnFace; - Result.fData.Brush.Style := bsSolid; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewPen: PGraphicTool; -begin - Result := _NewGraphicTool; - with Result^ do - begin - fNewProc := @ NewPen; - fType := gttPen; - {$IFDEF GDI} - fMakeHandleProc := @ MakePenHandle; - {$ENDIF GDI} - fData.Pen.Mode := pmCopy; - end; -end; -{$ENDIF PAS_VERSION} - -var ApplyFont2Wnd_Proc: procedure( _Self: PObj ) = DummyObjProc; -procedure DoApplyFont2Wnd( _Self: PControl ); forward; - -const size_FontData = sizeof( Integer {fFontHeight} ) + sizeof( Integer {fFontWidth} ) + - sizeof( TFontPitch ) + sizeof( TFontStyle ) + - sizeof( Integer {fFontOrientation} ) + - sizeof( Integer {fFontWeight} ) + sizeof( TFontCharset ) + - sizeof( TFontQuality ); - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewFont: PGraphicTool; -begin - ApplyFont2Wnd_Proc := @ DoApplyFont2Wnd; - Result := _NewGraphicTool; - with Result^ do - begin - fNewProc := @ NewFont; - fType := gttFont; - {$IFDEF GDI} - fMakeHandleProc := @ MakeFontHandle; - fData.Color := DefFontColor; - Move( DefFont, fData.Font, Sizeof( TGDIFont ) ); - {$ENDIF GDI} - {$IFDEF GTK} - fData.Font.Weight := 400; - {$ENDIF GTK} - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function Color2RGB( Color: TColor ): TColor; -begin - if Color < 0 then - Result := GetSysColor(Color and $7F) - else Result := Color; -end; -{$ENDIF PAS_VERSION} - -function RGB2BGR( Color: TColor ): TColor; -begin - Result := ((Color shr 16) or (Color shl 16) or Color and $00FF00) - and $FFFFFF; -end; - -function ColorsMix( Color1, Color2: TColor ): TColor; -{$IFDEF F_P} -begin - Result := ((Color2RGB( Color1 ) and $FEFEFE) shr 1) + - ((Color2RGB( Color2 ) and $FEFEFE) shr 1); -end; -{$ELSE DELPHI} -asm - //PUSH EDX - CALL Color2Rgb - //POP EDX - XCHG EAX, EDX - //PUSH EDX - CALL Color2Rgb - //POP EDX - MOV ECX, $0FEFEFE - AND EAX, ECX - AND EDX, ECX - ADD EAX, EDX - ROR EAX, 1 -end; -{$ENDIF F_P/DELPHI} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function Color2RGBQuad( Color: TColor ): TRGBQuad; -var C: Integer; -begin - C := Color2RGB( Color ); - C := ((C shr 16) and $FF) - or ((C shl 16) and $FF0000) - or (C and $FF00); - Result := TRGBQuad( C ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function Color2Color16( Color: TColor ): WORD; -begin - Color := Color2RGB( Color ); - Result := (Color shr 19) and $1F or - (Color shr 5) and $7E0 or - (Color shl 8) and $F800; -end; -{$ENDIF PAS_VERSION} - -function Color2Color15( Color: TColor ): WORD; -begin - Color := Color2RGB( Color ); - Result := (Color shr 19) and $1F or - (Color shr 6) and $3E0 or - (Color shl 7) and $7C00; -end; - -{$ENDIF WIN_GDI} -{ TGraphicTool } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function TGraphicTool.Assign(Value: PGraphicTool): PGraphicTool; -var _Self: PGraphicTool; -begin - Result := nil; - if Value = nil then - begin - {$IFDEF OLD_REFCOUNT} - if @Self <> nil then - DoDestroy; - {$ELSE} - Free; - {$ENDIF} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - _Self := @Self; - if _Self = nil then - _Self := Value.fNewProc(); - Result := _Self; - if _Self = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // to avoid infinite loop when assigning to itself - {$IFDEF GDI} - if _Self.fHandle <> 0 then - if Value.fHandle = _Self.fHandle then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF GDI} - _Self.Changed; // to destroy handle if allocated and release it from the canvas (if any uses it) - {$IFDEF KOL_ASSERTIONS} - Assert( Value.fType = _Self.fType, 'Attempt to assign to different GDI tool type' ); - {$ENDIF KOL_ASSERTIONS} - Move( Value.fData, _Self.fData, Sizeof( fData ) ); - _Self.Changed; // to inform owner control, that its tool (font, brush) changed -end; -{$ENDIF PAS_VERSION} -{$IFDEF WIN_GDI} - -procedure TGraphicTool.AssignHandle(NewHandle: Integer); -begin - if fHandle <> 0 then // - DeleteObject( fHandle ); // - fHandle := NewHandle; - GetObject( fHandle, Sizeof( TGDIFont ), @ fData.Font ); - Changed; -end; - -{$ENDIF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TGraphicTool.Changed; -{$IFDEF GDI} var H: THandle; {$ENDIF GDI} -begin - {$IFDEF GDI} - H := 0; - if fHandle <> 0 then - begin - H := fHandle; - fHandle := 0; - end; - //////////////////////////////// - if Assigned( TMethod( fOnGTChange ).Data ) then - fOnGTChange( @Self ); - //////////////////////////////// - if H <> 0 then - begin - DeleteObject( H ); - {$IFDEF DEBUG_GDIOBJECTS} - case fType of - gttBrush: Dec( BrushCount ); - gttFont: Dec( FontCount ); - gttPen: Dec( PenCount ); - end; - {$ENDIF} - end; - {$ENDIF GDI} - {$IFDEF GTK} - IF Assigned( fPangoFontDesc ) THEN - BEGIN - pango_font_description_free( fPangoFontDesc ); - fPangoFontDesc := nil; - END; - ///////////////////////////////// - IF Assigned( fOnGTChange ) THEN - ///////////////////////////////// - fOnGTChange( @Self ); - {$ENDIF GTK} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TGraphicTool.Destroy; -begin - {$IFDEF GDI} - case fType of - gttBrush: if fData.Brush.Bitmap <> 0 then - DeleteObject( fData.Brush.Bitmap ); - gttPen: if fData.Pen.BrushBitmap <> 0 then - DeleteObject( fData.Pen.BrushBitmap ) - end; - if fHandle <> 0 then - begin - DeleteObject( fHandle ); - {$IFDEF DEBUG_GDIOBJECTS} - case fType of - gttPen: Dec( PenCount ); - gttBrush: Dec( BrushCount ); - gttFont: Dec( FontCount ); - end; - {$ENDIF} - //fHandle := 0; Why to do this? It is now destroying! - end; - {$ENDIF GDI} - inherited; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN_GDI} -function TGraphicTool.HandleAllocated: Boolean; -begin - Result := fHandle <> 0; -end; - -{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION PAS_VERSION} -function TGraphicTool.ReleaseHandle: Integer; -begin - Changed; - Result := fHandle; - fHandle := 0; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TGraphicTool.SetInt( const Index: Integer; Value: Integer ); -var Where: PInteger; -begin - Where := Pointer( Integer( @ fData ) + Index ); - if Where^ = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Where^ := Value; - Changed; -end; -{$ENDIF PAS_VERSION} - -function TGraphicTool.GetInt(const Index: Integer): Integer; -var Where: PInteger; -begin - Where := Pointer( Integer( @ fData ) + Index ); - Result := Where^; -end; -{$IFDEF WIN_GDI} - -{$ENDIF WIN_GDI} -procedure TGraphicTool.SetColor( Value: TColor ); -begin - SetInt( go_Color, Value ); - fColorRGB := Color2RGB( Value ); -end; -{$IFDEF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TGraphicTool.IsFontTrueType: Boolean; -var OldFont: HFont; - DC: HDC; -begin - Result := False; - if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DC := GetDC( 0 ); - OldFont := SelectObject( DC, fHandle ); - if GetFontData( DC, 0, 0, nil, 0 ) <> GDI_ERROR then - Result := True; - SelectObject( DC, OldFont ); - ReleaseDC( 0, DC ); -end; -{$ENDIF PAS_VERSION} - -function TGraphicTool.GetBrushBitmap: HBitmap; -begin - Result := fData.Brush.Bitmap; // for BCB only -end; - -procedure TGraphicTool.SetBrushBitmap(const Value: HBitmap); -begin - if fData.Brush.Bitmap = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fData.Brush.Bitmap <> 0 then - begin - Changed; // !!! - DeleteObject( fData.Brush.Bitmap ); - end; - fData.Brush.Bitmap := Value; - Changed; -end; - -function TGraphicTool.GetBrushStyle: TBrushStyle; -begin - Result := fData.Brush.Style; // for BCB only -end; - -{$ENDIF WIN_GDI} -procedure TGraphicTool.SetBrushStyle(const Value: TBrushStyle); -begin - if fData.Brush.Style = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Brush.Style := Value; - Changed; -end; -{$IFDEF WIN_GDI} - -function TGraphicTool.GetFontCharset: TFontCharset; -begin - Result := fData.Font.CharSet; // for BCB only -end; - -procedure TGraphicTool.SetFontCharset(const Value: TFontCharset); -begin - if fData.Font.Charset = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Font.Charset := Value; - Changed; -end; - -function TGraphicTool.GetFontQuality: TFontQuality; -begin - Result := fData.Font.Quality; // for BCB only -end; - -procedure TGraphicTool.SetFontQuality(const Value: TFontQuality); -begin - if fData.Font.Quality = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Font.Quality := Value; - Changed; -end; -{$ENDIF WIN_GDI} - -function TGraphicTool.GetFontName: KOLString; -begin - Result := fData.Font.Name; - {$IFDEF GTK} - IF Result = '' THEN - Result := 'Sans Serif'; - {$ENDIF GTK} -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -procedure TGraphicTool.SetFontName(const Value: KOLString); -begin - if KOLString(fData.Font.Name) = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>} - //FillChar( fData.Font.Name[ 0 ], LF_FACESIZE, #0 ); - //ZeroMemory( @fData.Font.Name[ 0 ], LF_FACESIZE ); - {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF} - ( PKOLChar(@fData.Font.Name[0]), PKOLChar( Value ), Length(Value) * SizeOf(KOLChar) {LF_FACESIZE} ); - Changed; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TextAreaEx( Sender: PCanvas; var Sz : TSize; var Pt : TPoint ); -var Orient : Integer; - Pts : array[ 1..4 ] of TPoint; - MinX, MinY, I : Integer; - A : Double; -begin - if not Sender.Font.IsFontTrueType then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Orient := Sender.Font.FontOrientation; - Pt.x := 0; Pt.y := 0; - if Orient = 0 then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - A := Orient / 1800.0 * PI; - Pts[ 1 ] := Pt; - Pts[ 2 ].x := Round( Sz.cx * cos( A ) ); - Pts[ 2 ].y := - Round( Sz.cx * sin( A ) ); - Pts[ 4 ].x := - Round( Sz.cy * cos( A + PI / 2 ) ); - Pts[ 4 ].y := Round( Sz.cy * sin( A + PI / 2 ) ); - Pts[ 3 ].x := Pts[ 2 ].x + Pts[ 4 ].x; - Pts[ 3 ].y := Pts[ 2 ].y + Pts[ 4 ].y; - MinX := 0; MinY := 0; - for I := 2 to 4 do - begin - if Pts[ I ].x < MinX then - MinX := Pts[ I ].x; - if Pts[ I ].y < MinY then - MinY := Pts[ I ].y; - end; - Sz.cx := 0; - Sz.cy := 0; - for I := 1 to 4 do - begin - Pts[ I ].x := Pts[ I ].x - MinX; - Pts[ I ].y := Pts[ I ].y - MinY; - if Pts[ I ].x > Sz.cx then - Sz.cx := Pts[ I ].x; - if Pts[ I ].y > Sz.cy then - Sz.cy := Pts[ I ].y; - end; - Pt := Pts[ 1 ]; -end; -{$ENDIF PAS_VERSION} - -function TGraphicTool.GetFontOrientation: Integer; -begin - Result := fData.Font.Orientation; // for BCB only -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TGraphicTool.SetFontOrientation(Value: Integer); -begin - GlobalGraphics_UseFontOrient := True; - TOnTextArea( GlobalCanvas_OnTextArea ) := TextAreaEx; - Value := Value mod 3600; // -3599..+3599 - SetInt( go_FontOrientation, Value ); - SetInt( go_FontEscapement, Value ); -end; -{$ENDIF PAS_VERSION} - -function TGraphicTool.GetFontPitch: TFontPitch; -begin - Result := fData.Font.Pitch; // for BCB only -end; - -procedure TGraphicTool.SetFontPitch(const Value: TFontPitch); -begin - if fData.Font.Pitch = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Font.Pitch := Value; - Changed; -end; -{$ENDIF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TGraphicTool.GetFontStyle: TFontStyle; -type PFontStyle = ^TFontStyle; -begin - Result := [ ]; - if fData.Font.Weight >= 700 then Result := [ fsBold ]; - if fData.Font.Italic then include( Result, fsItalic ); - if fData.Font.Underline then include( Result, fsUnderline ); - if fData.Font.StrikeOut then include( Result, fsStrikeOut ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TGraphicTool.SetFontStyle(const Value: TFontStyle); -begin - if FontStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fsBold in Value then - begin - if fData.Font.Weight < 700 then - fData.Font.Weight := 700; - end else - begin - if fData.Font.Weight >= 700 then - fData.Font.Weight := 0; - end; - fData.Font.Italic := fsItalic in Value; - fData.Font.Underline := fsUnderline in Value; - fData.Font.StrikeOut := fsStrikeOut in Value; - Changed; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN_GDI} -function TGraphicTool.GetPenMode: TPenMode; -begin - Result := fData.Pen.Mode; // for BCB only -end; - -procedure TGraphicTool.SetPenMode(const Value: TPenMode); -begin - if fData.Pen.Mode = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Pen.Mode := Value; - Changed; -end; - -function TGraphicTool.GetPenStyle: TPenStyle; -begin - Result := fData.Pen.Style; // for BCB only -end; - -procedure TGraphicTool.SetPenStyle(const Value: TPenStyle); -begin - if fData.Pen.Style = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Pen.Style := Value; - Changed; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TGraphicTool.GetHandle: THandle; -begin - Result := fHandle; - if Result <> 0 then - begin - if Color2RGB( fData.Color ) <> fColorRGB then - begin - DeleteObject( ReleaseHandle ); - Result := 0; - end; - end; - if Result = 0 then - begin - if ( fParentGDITool <> nil ) then - begin - if CompareMem( @ fData, @ fParentGDITool.fData, Sizeof( fData ) ) then - begin - Result := fParentGDITool.Handle; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - fColorRGB := Color2RGB( fData.Color ); - fMakeHandleProc( @Self ); - Result := fHandle; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function MakeBrushHandle( Self_: PGraphicTool ): THandle; -var - LogBrush: TLogBrush; -begin - if Self_.fHandle = 0 then - begin - LogBrush.lbColor := Color2RGB( Self_.fData.Color ); - if Self_.fData.Brush.Bitmap <> 0 then - begin - LogBrush.lbStyle := BS_PATTERN; - LogBrush.lbHatch := Self_.fData.Brush.Bitmap; - end else - begin - LogBrush.lbHatch := 0; - case Self_.fData.Brush.Style of - bsSolid: LogBrush.lbStyle := BS_SOLID; - bsClear: LogBrush.lbStyle := BS_NULL; - else LogBrush.lbStyle := BS_HATCHED; - LogBrush.lbHatch := Ord(Self_.fData.Brush.Style)-Ord(bsHorizontal); - LogBrush.lbColor := Color2RGB( Self_.fData.Brush.LineColor ); - end; - end; - Self_.fHandle := CreateBrushIndirect(LogBrush); - {$IFDEF DEBUG_GDIOBJECTS} - if Self_.fHandle <> 0 then - Inc( BrushCount ) - else ShowMessage( 'Could not create brush, error ' + Int2Str( GetLastError ) + - ': ' + SysErrorMessage( GetLastError ) ); - {$ENDIF} - end; - Result := Self_.fHandle; -end; -{$ENDIF PAS_VERSION} - -{$UNDEF ASM_LOCAL} -{$IFNDEF UNICODE_CTRLS} - {$IFDEF ASM_VERSION} - {$IFNDEF AUTO_REPLACE_CLEARTYPE} - {$DEFINE ASM_LOCAL} - {$ENDIF AUTO_REPLACE_CLEARTYPE} - {$ENDIF PAS_VERSION} -{$ENDIF} - -{$IFDEF ASM_LOCAL} -function MakeFontHandle( Self_: PGraphicTool ): THandle; -asm - XCHG EDX, EAX - MOV EAX, [EDX].TGraphicTool.fHandle - TEST EAX, EAX - JNZ @@exit - PUSH EDX - LEA ECX, [EDX].TGraphicTool.fData.Font - PUSH ECX - CALL CreateFontIndirect - POP EDX - MOV [EDX].TGraphicTool.fHandle, EAX -@@exit: -end; -{$ELSE PAS_VERSION} //Pascal -function MakeFontHandle( Self_: PGraphicTool ): THandle; -{$IFDEF AUTO_REPLACE_CLEARTYPE} -var LF: TLogFont; -{$ENDIF} -begin - with Self_^ do - begin - if fHandle = 0 then - begin - {$IFDEF AUTO_REPLACE_CLEARTYPE} - Move( fData.Font, LF, Sizeof( LF ) ); - if WinVer < wvXP then - begin - if LF.lfQuality > ANTIALIASED_QUALITY then - LF.lfQuality := ANTIALIASED_QUALITY; - end; - fHandle := CreateFontIndirect( LF ); - {$ELSE} - fHandle := CreateFontIndirect( PLogFont( @ fData.Font )^ ); - {$ENDIF} - {$IFDEF DEBUG_GDIOBJECTS} - Inc( FontCount ); - {$ENDIF} - end; - Result := fHandle; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function MakePenHandle( Self_: PGraphicTool ): THandle; -var - LogPen: TLogPen; -begin - with Self_^ do - begin - //GlobalGraphics_OnObjectCreating( @Self ); - if fHandle = 0 then - with LogPen do - begin - lopnStyle := Byte( fData.Pen.Style ); - lopnWidth.X := fData.Pen.Width; - lopnColor := Color2RGB( fData.Color ); - fHandle := CreatePenIndirect( LogPen ); - {$IFDEF DEBUG_GDIOBJECTS} - Inc( PenCount ); - {$ENDIF} - end; - //GlobalGraphics_OnObjectCreated( @Self ); - Result := fHandle; - end; -end; -{$ENDIF PAS_VERSION} - -function TGraphicTool.GetGeometricPen: Boolean; -begin - Result := fData.Pen.Geometric; // for BCB only -end; - -procedure TGraphicTool.SetGeometricPen(const Value: Boolean); -begin - if fData.Pen.Geometric = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Pen.Geometric := Value; - fMakeHandleProc := MakeGeometricPenHandle; - Changed; -end; - -function TGraphicTool.GetPenEndCap: TPenEndCap; -begin - Result := fData.Pen.EndCap; // for BCB only -end; - -procedure TGraphicTool.SetPenEndCap(const Value: TPenEndCap); -begin - if fData.Pen.EndCap = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Pen.EndCap := Value; - Changed; -end; - -function TGraphicTool.GetPenJoin: TPenJoin; -begin - Result := fData.Pen.Join; // for BCB only -end; - -procedure TGraphicTool.SetPenJoin(const Value: TPenJoin); -begin - if fData.Pen.Join = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Pen.Join := Value; - Changed; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle; -const - PenStyles: array[ TPenStyle ] of Word = - (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL, - PS_INSIDEFRAME); - PenEndCapStyles: array[ TPenEndCap ] of Word = - (PS_ENDCAP_ROUND, PS_ENDCAP_SQUARE, PS_ENDCAP_FLAT); - PenJoinStyles: array[ TPenJoin ] of Word = - (PS_JOIN_ROUND, PS_JOIN_BEVEL, PS_JOIN_MITER ); -var - LogBrush: TLogBrush; -begin - if Self_.fHandle = 0 then - with Self_^, LogBrush do - begin - lbColor := Color2RGB( fData.Color ); - lbHatch := 0; - if fData.Pen.BrushBitmap <> 0 then - begin - lbStyle := BS_PATTERN; - lbHatch := fData.Pen.BrushBitmap; - end else - case fData.Pen.BrushStyle of - bsSolid: lbStyle := BS_SOLID; - bsClear: lbStyle := BS_NULL; - else lbStyle := BS_HATCHED; - case fData.Pen.BrushStyle of - bsHorizontal: lbHatch := HS_HORIZONTAL; - bsVertical: lbHatch := HS_VERTICAL; - bsFDiagonal: lbHatch := HS_FDIAGONAL; - bsBDiagonal: lbHatch := HS_BDIAGONAL; - bsCross: lbHatch := HS_CROSS; - bsDiagCross: lbHatch := HS_DIAGCROSS; - end; - end; - end; - Self_.fHandle := ExtCreatePen( PS_GEOMETRIC or Byte( Self_.fData.Pen.Style ) or - PenEndCapStyles[ Self_.fData.Pen.EndCap ] or - PenJoinStyles[ Self_.fData.Pen.Join ], - Self_.fData.Pen.Width, LogBrush, 0, nil ); - {Assert( Self_.fHandle <> 0, 'Error ' + Int2Str( GetLastError ) + - ': ' + SysErrorMessage( GetLastError ) );} - {$IFDEF DEBUG_GDIOBJECTS} - Inc( PenCount ); - {$ENDIF} - Result := Self_.fHandle; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} -function TGraphicTool.GetFontWeight: Integer; -begin - Result := fData.Font.Weight; // for BCB only -end; - -procedure TGraphicTool.SetFontWeight(const Value: Integer); -begin - if fData.Font.Weight = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fData.Font.Weight := Value; - Changed; -end; -{$IFDEF WIN_GDI} - -procedure TGraphicTool.SetLogFontStruct(const Value: TLogFont); -begin - if CompareMem(@fData.Font, @Value, SizeOf(TLogFont)) then Exit; {>>>>>>>>>>>} - Move(Value, fData.Font, SizeOF(TLogFont)); - Changed; -end; - -function TGraphicTool.GetLogFontStruct: TLogFont; -begin - Move(fData.Font, Result, SizeOf(TLogFont)); -end; -{$ENDIF WIN_GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TGraphicTool.GetPangoFontDesc: PPangoFontDescription; -VAR s: AnsiString; - i: Integer; - FUNCTION IfThen( cond: Boolean; CONST s: AnsiString ): AnsiString; - BEGIN - Result := ''; - IF cond THEN Result := s; - END; -{const Weights: array[0..9] of String = ( 'Ultralight', - 'Ultralight', 'Ultralight', - 'Light', 'Normal', 'Normal', 'Normal', - 'Bold', 'Ultrabold', 'Heavy' );} -BEGIN - IF NOT Assigned( fPangoFontDesc ) THEN - BEGIN - s := FontName; { + ' ' + - IfThen( FontWeight <> 400, Weights[ FontWeight div 100 ] + ' ' ) + - IfThen( fsItalic in FontStyle, 'Italic ' ) {+ - Int2Str( FontHeight )}; - fPangoFontDesc := pango_font_description_from_string( PAnsiChar( s ) ); - i := FontHeight; - IF i > 0 THEN - pango_font_description_set_absolute_size( fPangoFontDesc, i * PANGO_SCALE ); - //i := pango_font_description_get_size( fPangoFontDesc ); - i := PANGO_STYLE_NORMAL; - IF fsItalic IN FontStyle THEN i := PANGO_STYLE_ITALIC; - pango_font_description_set_style( fPangoFontDesc, i ); - pango_font_description_set_weight( fPangoFontDesc, FontWeight ); - END; - Result := fPangoFontDesc; -END; - -FUNCTION Color2GDKColor( Color: TColor ): TGdkColor; -BEGIN - Color := Color2RGB( Color ); - Result.pixel := 0; - Result.red := (Color and $FF) shl 8; - Result.green := Color and $FF00; - Result.blue := (Color shr 8) and $FF00; -END; -{$ENDIF GTK} -{$ENDIF _X_} -{$IFDEF WIN_GDI} - -{ TCanvas } - -type - TStock = Packed Record - StockPen: HPEN; - StockBrush: HBRUSH; - StockFont: HFONT; - end; - -var - Stock: TStock; - -destructor TCanvas.Destroy; -begin - Handle := 0; - fPen.Free; - fBrush.Free; - fFont.Free; - inherited; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TCanvas.Assign(SrcCanvas: PCanvas): Boolean; -begin - fFont := fFont.Assign( SrcCanvas.fFont ); - fBrush := fBrush.Assign( SrcCanvas.fBrush ); - fPen := fPen.Assign( SrcCanvas.fPen ); - AssignChangeEvents; - Result := (fFont <> nil) or (fBrush <> nil) or (fPen <> nil); - if (SrcCanvas.PenPos.x <> PenPos.x) or (SrcCanvas.PenPos.y <> PenPos.y) then - begin - Result := True; - PenPos := SrcCanvas.PenPos; - end; - if SrcCanvas.ModeCopy <> ModeCopy then - begin - Result := True; - ModeCopy := SrcCanvas.ModeCopy; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.CreateBrush; -begin - if assigned( fBrush ) then - begin - SelectObject( GetHandle, fBrush.Handle ); - AssignChangeEvents; - if fBrush.fData.Brush.Style = bsSolid then - begin - SetBkColor( fHandle, Color2RGB( fBrush.fData.Color ) ); - SetBkMode( fHandle, OPAQUE ); - end else - begin - { Win95 doesn't draw brush hatches if bkcolor = brush color } - { Since bkmode is transparent, nothing should use bkcolor anyway } - SetBkColor( fHandle, not Color2RGB( fBrush.fData.Color ) ); - SetBkMode( fHandle, TRANSPARENT ); - end; - end else - if Assigned( fOwnerControl ) then - begin - SetBkColor( GetHandle, Color2RGB( PControl( fOwnerControl ).fColor ) ); - SetBkMode( fHandle, OPAQUE ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.CreateFont; -begin - if ( fFont <> nil ) then - begin - SelectObject( GetHandle, fFont.Handle ); - SetTextColor( fHandle, Color2RGB( fFont.fData.Color ) ); - AssignChangeEvents; - end else - if ( fOwnerControl <> nil ) then - begin - SetTextColor( fHandle, - Color2RGB( PControl( fOwnerControl ).fTextColor ) ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.CreatePen; -begin - if ( fPen <> nil ) then - begin - SelectObject( GetHandle, fPen.Handle ); - SetROP2( fHandle, Ord( fPen.fData.Pen.Mode ) + 1 ); - AssignChangeEvents; - end; -end; -{$ENDIF PAS_VERSION} - -function TCanvas.GetPixels(X, Y: Integer): TColor; -begin - RequiredState( HandleValid ); - Result := Windows.GetPixel(FHandle, X, Y); -end; - -procedure TCanvas.SetPixels(X, Y: Integer; const Value: TColor); -begin - Changing; - RequiredState( HandleValid ); - Windows.SetPixel(FHandle, X, Y, Color2RGB( Value )); -end; - -procedure TCanvas.OffsetAndRotate(Xoff, Yoff: Integer; Angle: Double); -var F: TXForm; -begin - SetGraphicsMode( fHandle, GM_ADVANCED ); - F.eM11 := cos( Angle ); - F.eM12 := sin( Angle ); - F.eM21 := -F.eM12; - F.eM22 := F.eM11; - F.eDx := Xoff; - F.eDy := Yoff; - SetWorldTransform( fHandle, F ); - if (Angle = 0) and (Xoff = 0) and (Yoff = 0) then - SetGraphicsMode( fHandle, GM_COMPATIBLE ); -end; - -{$ENDIF WIN_GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.SaveState; -BEGIN - gdk_gc_get_values( fHandle, @ fSavedState ); -END; - -PROCEDURE TCanvas.RestoreState; -VAR mask: DWORD; -BEGIN - mask := $1FFFF; - if fSavedState.font = nil then mask := mask and not GDK_GC_FONT; - if fSavedState.stipple = nil then mask := mask and not GDK_GC_STIPPLE; - gdk_gc_set_values( fHandle, @ fSavedState, mask ); - DeselectHandles; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.DeselectHandles; -begin - if (fHandle <> 0) and - LongBool(fState and (PenValid or BrushValid or FontValid)) then - with Stock do - begin - if StockPen = 0 then - begin - StockPen := GetStockObject(BLACK_PEN); - StockBrush := GetStockObject(HOLLOW_BRUSH); - StockFont := GetStockObject(SYSTEM_FONT); - end; - SelectObject( fHandle, StockPen ); - SelectObject( fHandle, StockBrush ); - SelectObject( fHandle, StockFont ); - fState := fState and not( PenValid or BrushValid or FontValid ); - end; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.DeselectHandles; -BEGIN - IF ( fFont <> nil ) AND ( fFont.fPangoFontDesc <> nil ) THEN - BEGIN - pango_font_description_free( fFont.fPangoFontDesc ); - fFont.fPangoFontDesc := nil; - END; - fState := fState and not( PenValid or BrushValid or FontValid ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TCanvas.RequiredState(ReqState: DWORD): HDC; stdcall; -var - NeededState: Byte; -begin - if Boolean(ReqState and ChangingCanvas) then - Changing; - ReqState := ReqState and 15; - NeededState := Byte( ReqState ) and not fState; - Result := 0; - if Boolean(ReqState and HandleValid) then - begin - if GetHandle = 0 then Exit; // Important! {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if NeededState <> 0 then - begin - if Boolean( NeededState and FontValid ) then - CreateFont; - if Boolean( NeededState and PenValid ) then - begin - CreatePen; - if ( fPen <> nil ) then - if fPen.fData.Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then - NeededState := NeededState or BrushValid; - end; - if Boolean( NeededState and BrushValid ) then - CreateBrush; - fState := fState or NeededState; - end; - Result := fHandle; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN_GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.ForeBack(fg_color, bk_color: TColor); // install colors just before drawing -BEGIN - fg_color := RGB2BGR( Color2RGB( fg_color ) ); - bk_color := RGB2BGR( Color2RGB( bk_color ) ); - gdk_rgb_gc_set_foreground( fHandle, fg_color ); - gdk_rgb_gc_set_background( fHandle, bk_color ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.SetHandle(Value: HDC); -{$IFDEF F_P} -var Ptr1: Pointer; -{$ENDIF F_P} -begin - if fHandle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fHandle <> 0 then - begin - DeselectHandles; - {$IFDEF GDI} - if (fOwnerControl = nil) or - (PControl(fOwnerControl).fPaintDC <> fHandle) then - begin - {$IFDEF F_P} - Ptr1 := Self; - asm - MOV EAX, [Ptr1] - MOV EAX, [EAX].TCanvas.fOnGetHandle - MOV [Ptr1], EAX - end [ 'EAX' ]; - if Ptr1 = @ TControl.DC2Canvas then - {$ELSE DELPHI} - //////////////////// SLAG - if TMethod(fOnGetHandle).Code = - @TControl.Dc2Canvas then - {$ENDIF F_P/DELPHI} - ReleaseDC( PControl(fOwnerControl).Handle, fHandle ) - else - if not (fIsAlienDC or fIsPaintDC) then - DeleteDC( fHandle ); - //////////////////// - end; - {$ENDIF GDI} - fHandle := 0; - fIsPaintDC := False; - fState := fState and not HandleValid; - end; - if Value <> 0 then - begin - fState := fState or HandleValid; - fHandle := Value; - SetPenPos( fPenPos ); - end; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.SetPenPos(const Value: TPoint); -begin - fPenPos := Value; - {$IFDEF GDI} - MoveTo( Value.x, Value.y ); - {$ENDIF GDI} -end; -{$ENDIF PAS_VERSION} -{$IFDEF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.Changing; -begin - if Assigned( fOnChangeCanvas ) then - fOnChangeCanvas( @Self ); -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall; -begin - RequiredState( HandleValid or PenValid or ChangingCanvas ); - Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4); -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); STDCALL; -VAR C: TPoint; - angle1, angle2: Integer; - A1, A2: Double; -BEGIN - ////RequiredState( {HandleValid or} PenValid or ChangingCanvas ); - C := MakePoint( (X1 + X2) div 2, (Y1 + Y2) div 2 ); - {$IFDEF NOT_USE_EXCEPTION} - A1 := ArcTan2( Y3-C.Y, X3-C.X ); - A2 := ArcTan2( Y4-C.Y, X4-C.X ); - {$ELSE USE_EXCEPTION} - TRY - A1 := ArcTan2( Y3-C.Y, X3-C.X ); - EXCEPT - A1 := 0; - END; - TRY - A2 := ArcTan2( Y4-C.Y, X4-C.X ); - EXCEPT - A2 := 0; - END; - {$ENDIF NOT_USE_EXCEPTION} - angle1 := -Round(A1 * 180 * 64 / PI); - angle2 := -Round(A2 * 180 * 64 / PI); - IF Brush.BrushStyle <> bsClear THEN - BEGIN - ForeBack( Brush.Color, Brush.Color ); - gdk_draw_arc( fDrawable, fHandle, 1, X1, Y1, X2-X1, Y2-Y1, angle1, angle2 ); - END; - ForeBack( Pen.Color, Brush.Color ); - gdk_draw_arc( fDrawable, fHandle, 0, X1, Y1, X2-X1, Y2-Y1, angle1, angle2 ); -END; -{$ENDIF GTK} -{$ENDIF _X_} -{$IFDEF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall; -begin - RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas ); - Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.CopyRect(const DstRect: TRect; SrcCanvas: PCanvas; - const SrcRect: TRect); -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - SrcCanvas.RequiredState( HandleValid or BrushValid ); - StretchBlt( fHandle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, - DstRect.Bottom - DstRect.Top, SrcCanvas.Handle, SrcRect.Left, SrcRect.Top, - SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, ModeCopy); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); -begin - RequiredState( HandleValid or BrushValid or FontValid or ChangingCanvas ); - Windows.DrawFocusRect(FHandle, Rect); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer); -begin - RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas ); - Windows.Ellipse(FHandle, X1, Y1, X2, Y2); -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); -var Br: HBrush; -begin - RequiredState( HandleValid or BrushValid or ChangingCanvas ); - if fBrush <> nil then - begin - Windows.FillRect(fHandle, Rect, fBrush.Handle); - end else - if ( fOwnerControl <> nil ) then - begin - {$IFDEF GDI} - if ( PControl( fOwnerControl ).fBrush <> nil ) then - Windows.FillRect( fHandle, Rect, PControl( fOwnerControl ).fBrush.Handle ) - else - begin - Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) ); - Windows.FillRect(fHandle, Rect, Br ); - DeleteObject( Br ); - end; - {$ENDIF GDI} - end else - Windows.FillRect(fHandle, Rect, HBrush(COLOR_WINDOW + 1) ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); -BEGIN - if (fBrush <> nil) and (fBrush.BrushStyle = bsClear) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ForeBack( Brush.Color, Brush.Color ); - gdk_draw_rectangle( fDrawable, fHandle, 1, Rect.Left, Rect.Top, - Rect.Right-Rect.Left, Rect.Bottom-Rect.Top ); -END; -{$ENDIF GTK} -{$ENDIF _X_} -{$IFDEF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.FillRgn(const Rgn: HRgn); -var Br : HBrush; -begin - RequiredState( HandleValid or BrushValid or ChangingCanvas ); - if ( fBrush <> nil ) then - Windows.FillRgn(FHandle, Rgn, fBrush.Handle ) - else if ( fOwnerControl <> nil ) then - begin - {$IFDEF GDI} - if ( PControl( fOwnerControl ).fBrush <> nil ) then - Windows.FillRgn( FHandle, Rgn, PControl( fOwnerControl ).fBrush.Handle ) - else - begin - Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) ); - Windows.FillRgn( fHandle, Rgn, Br ); - DeleteObject( Br ); - end; - {$ENDIF GDI} - end else - begin - Br := CreateSolidBrush( DWORD(clWindow) ); - Windows.FillRgn( fHandle, Rgn, Br ); - DeleteObject( Br ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor; - FillStyle: TFillStyle); -const - FillStyles: array[TFillStyle] of Word = - (FLOODFILLSURFACE, FLOODFILLBORDER); -begin - RequiredState( HandleValid or BrushValid or ChangingCanvas ); - Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect); -var SolidBr : HBrush; -begin - RequiredState( HandleValid or ChangingCanvas ); - if fBrush <> nil then - SolidBr := CreateSolidBrush( Color2RGB( fBrush.fData.Color ) ) - else - if fOwnerControl <> nil then - SolidBr := CreateSolidBrush( PControl(fOwnerControl).fColor ) - else SolidBr := CreateSolidBrush( clWhite ); - Windows.FrameRect(FHandle, Rect, SolidBr); - DeleteObject( SolidBr ); -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.LineTo(X, Y: Integer); -begin - RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas ); - Windows.LineTo( fHandle, X, Y ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.LineTo(X, Y: Integer); -BEGIN - ForeBack( Pen.Color, Brush.Color ); - gdk_draw_line( fDrawable, fHandle, fPenPos.X, fPenPos.Y, X, Y ); - fPenPos := MakePoint( X, Y ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.MoveTo(X, Y: Integer); -begin - RequiredState( HandleValid ); - Windows.MoveToEx( fHandle, X, Y, nil ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.MoveTo(X, Y: Integer); -BEGIN - fPenPos := MakePoint( X, Y ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -procedure TCanvas.ObjectChanged(Sender: PGraphicTool); -begin - DeselectHandles; -end; - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); stdcall; -begin - RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas ); - Windows.Pie( fHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.Polygon(const Points: array of TPoint); -type - PPoints = ^TPoints; - TPoints = array[0..0] of TPoint; -begin - RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas ); - {$IFDEF F_P} Windows_Polygon - {$ELSE DELPHI} Windows.Polygon - {$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.Polyline(const Points: array of TPoint); -type - PPoints = ^TPoints; - TPoints = array[0..0] of TPoint; -begin - RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas ); - {$IFDEF F_P}Windows_Polyline - {$ELSE DELPHI}Windows.Polyline - {$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer); -begin - RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas ); - Windows.Rectangle( fHandle, X1, Y1, X2, Y2); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer); -begin - RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas ); - Windows.RoundRect( fHandle, X1, Y1, X2, Y2, X3, Y3); -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.TextArea(const Text: KOLString; var Sz: TSize; - var P0: TPoint); -begin - Sz := TextExtent( Text ); - P0.x := 0; P0.y := 0; - TOnTextArea( GlobalCanvas_OnTextArea )( @Self, Sz, P0 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF _D3orHigher} -procedure TCanvas.WTextArea(const Text: KOLWideString; var Sz: TSize; - var P0: TPoint); -begin - Sz := WTextExtent( Text ); - P0.x := 0; P0.y := 0; - TOnTextArea( GlobalCanvas_OnTextArea )( @Self, Sz, P0 ); -end; -{$ENDIF _D3orHigher} - -{$IFDEF GDI} -{$IFDEF TEXT_EXTENT_OLD} -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TCanvas.TextExtent(const Text: KOLString): TSize; -var DC : HDC; - ClearHandle : Boolean; -begin - ClearHandle := False; - RequiredState( HandleValid or FontValid ); - DC := fHandle; - if DC = 0 then - begin - DC := CreateCompatibleDC( 0 ); - ClearHandle := True; - SetHandle( DC ); - If Not (fIsAlienDC or fIsPaintDC) then - ClearHandle := True; //************ // Added By Gerasimov - end; - RequiredState( HandleValid or FontValid ); - GetTextExtentPoint32( fHandle, PKOLChar(Text), Length(Text), Result); - {$IFDEF FIX_ITALIC_TEXT_WIDTH} - if fsItalic in Font.FontStyle then - begin - inc( Result.cx, Result.cy div 4 ); - end; - {$ENDIF} - if ClearHandle then - SetHandle( 0 ); - { DC must be freed here automatically (never leaks): - if Canvas created on base of existing DC, no memDC created, - if Canvas has fHandle:HDC = 0, it is not fIsPaintDC always. } -end; -{$ENDIF PAS_VERSION} -{$ELSE TEXT_EXTENT_NEW} -{$IFDEF ASM_UNICODE}{$ELSE notASM_VERSION} -function TCanvas.TextExtent(const Text: KOLString): TSize; -begin - RequiredState( HandleValid or FontValid ); - GetTextExtentPoint32( fHandle, PKOLChar(Text), Length(Text), Result); - {$IFDEF FIX_ITALIC_TEXT_WIDTH} - if Font.fData.Font.Italic then - inc( Result.cx, Result.cy div 4 ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} -{$ENDIF TEXT_EXTENT_NEW} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TCanvas.TextExtent(const Text: KOLString): TSize; -VAR layout: PPangoLayout; - context: PPangoContext; -BEGIN - //RequiredState( HandleValid or FontValid ); - IF fOwnerControl <> nil THEN - BEGIN - context := nil; - layout := gtk_widget_create_pango_layout( - PControl( fOwnerControl ).fEventboxHandle, nil ); - END ELSE - BEGIN //todo: seems not working in such way... What to do for memory bitmap? - context := pango_context_new; - //layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) ); - layout := pango_layout_new( context ); - END; - pango_layout_set_font_description( layout, Font.FontHandle ); - pango_layout_set_text( layout, PAnsiChar( Text ), Length( Text ) ); - pango_layout_get_size( layout, @ Result.cx, @ Result.cy ); - g_object_unref( layout ); - IF context <> nil THEN g_object_unref( context ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -function TCanvas.TextHeight(const Text: KOLString): Integer; -begin - Result := TextExtent(Text).cY; -end; - -{$IFDEF GDI} -procedure TCanvas.TextOutA(X, Y: Integer; const Text: AnsiString); stdcall; -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - Windows.TextOutA(FHandle, X, Y, PAnsiChar(Text), Length(Text)); -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.TextOut(X, Y: Integer; const Text: KOLString); stdcall; -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - {$IFDEF UNICODE_CTRLS}Windows.TextOutW - {$ELSE} Windows.TextOutA - {$ENDIF}(FHandle, X, Y, PKOLChar(Text), Length(Text)); -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.TextOut(X, Y: Integer; CONST Text: AnsiString); STDCALL; -VAR Options: Integer; -BEGIN - Options := 0; - if Brush.BrushStyle <> bsClear then Options := ETO_OPAQUE; - ExtTextOut( X, Y, Options, MakeRect( 0,0,0,0 ), Text, [ ] ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: Ansistring); -var - Options: Integer; -begin - //Changing; - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - Options := ETO_CLIPPED; - if ( fBrush <> nil ) and (fBrush.fData.Brush.Style <> bsClear) - or ( fBrush = nil ) then Inc(Options, ETO_OPAQUE); - Windows.ExtTextOutA( fHandle, X, Y, Options, - @Rect, PAnsiChar(Text), - Length(Text), nil); // KOL_ANSI -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.TextRect(CONST Rect: TRect; X, Y: Integer; CONST Text: Ansistring); -VAR Options: Integer; -BEGIN - Options := ETO_CLIPPED; - IF Brush.BrushStyle <> bsClear THEN Options := Options or ETO_OPAQUE; - ExtTextOut( X, Y, Options, Rect, Text, [] ); // KOL_ANSI -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -procedure TCanvas.ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: AnsiString; - const Spacing: array of Integer ); -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - windows.ExtTextOutA(FHandle, X, Y, Options, @Rect, PAnsiChar(Text), Length(Text), @Spacing[ 0 ]); // KOL_ANSI have not Ex -end; -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TCanvas.ExtTextOut( X, Y: Integer; Options: DWORD; CONST Rect: TRect; - CONST Text: AnsiString; CONST Spacing: ARRAY of Integer ); -VAR context: PPangoContext; - layout: PPangoLayout; - w, h: Integer; - pixmap: PGdkPixmap; -BEGIN - ////RequiredState( {HandleValid or} FontValid or BrushValid or ChangingCanvas ); - w := Rect.Right - Rect.Left; - h := Rect.Bottom - Rect.Top; - IF fOwnerControl <> nil THEN - BEGIN - context := nil; - layout := gtk_widget_create_pango_layout( - PControl( fOwnerControl ).fEventboxHandle, nil ); - END ELSE - BEGIN //todo: seems not working in such way... What to do for memory bitmap? - context := pango_context_new; - //layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) ); - layout := pango_layout_new( context ); - END; - pango_layout_set_font_description( layout, Font.FontHandle ); - pango_layout_set_text( layout, PAnsiChar( Text ), Length( Text ) ); - IF Options AND ETO_CLIPPED = 0 THEN - BEGIN - pango_layout_get_size( layout, @ w, @ h ); - w := w div PANGO_SCALE; - h := h div PANGO_SCALE; - END; - pixmap := gdk_pixmap_new( PControl( fOwnerControl ).fEventboxHandle.window, - w, h, -1 ); //todo: use MainForm - IF Options AND ETO_OPAQUE <> 0 THEN - BEGIN - ForeBack( Brush.Color, Brush.Color ); - gdk_draw_rectangle( GDK_DRAWABLE( pixmap ), fHandle, 1, 0, 0, w, h ); - END ELSE - BEGIN - gdk_draw_drawable( GDK_DRAWABLE( pixmap ), fHandle, fDrawable, - Rect.Left, Rect.Top, 0, 0, w, h ); - END; - ForeBack( Font.Color, Brush.Color ); - gdk_draw_layout( GDK_DRAWABLE( pixmap ), fHandle, X, Y, layout ); - g_object_unref( layout ); - gdk_draw_drawable( fDrawable, fHandle, GDK_DRAWABLE( pixmap ), - 0, 0, Rect.Left, Rect.Top, w, h ); - g_object_unref( pixmap ); - IF context <> nil THEN - g_object_unref( context ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE} -procedure TCanvas.DrawText(Text: AnsiString; var Rect:TRect; Flags:DWord); -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - Windows.DrawTextA(Handle, PAnsiChar(Text), -1, Rect, Flags); // KOL_ANSI -end; -{$ENDIF PAS_VERSION} - -function TCanvas.ClipRect: TRect; -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - GetClipBox(Handle, Result); -end; -{$ENDIF WIN_GDI} - -function TCanvas.TextWidth(const Text: KOLString): Integer; -begin - Result := TextExtent(Text).cX; -end; - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TCanvas.GetBrush: PGraphicTool; -begin - if ( fBrush = nil ) then - begin - fBrush := NewBrush; - if ( fOwnerControl <> nil ) then - begin - fBrush.fData.Color := PControl(fOwnerControl).fColor; - if ( PControl(fOwnerControl).fBrush <> nil ) then - fBrush.Assign( PControl(fOwnerControl).fBrush ); - // both statements above needed - end; - AssignChangeEvents; - end; - Result := fBrush; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TCanvas.GetBrush: PGraphicTool; -BEGIN - IF ( fBrush = nil ) THEN - BEGIN - fBrush := NewBrush; - IF ( fOwnerControl <> nil ) THEN - BEGIN - fBrush.fData.Color := PControl(fOwnerControl).fColor; - IF ( PControl(fOwnerControl).fBrush <> nil ) THEN - fBrush.Assign( PControl(fOwnerControl).fBrush ); - // both statements above needed - END; - AssignChangeEvents; - END; - Result := fBrush; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TCanvas.GetFont: PGraphicTool; -begin - if ( fFont = nil ) then - begin - fFont := NewFont; - if ( fOwnerControl <> nil ) then - begin - fFont.Color := PControl(fOwnerControl).fTextColor; - if ( PControl(fOwnerControl).fFont <> nil ) then - fFont.Assign( PControl(fOwnerControl).fFont ); - end; - AssignChangeEvents; - end; - Result := fFont; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TCanvas.GetPen: PGraphicTool; -begin - if ( fPen = nil ) then - begin - fPen := NewPen; - AssignChangeEvents; - end; - Result := fPen; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TCanvas.GetHandle: HDC; -begin - ///////////////////////////////// - if Assigned( fOnGetHandle ) then - ///////////////////////////////// - begin - Result := fOnGetHandle( @Self ); - SetHandle( Result ); - end else - Result := fHandle; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TCanvas.GetHandle: HDC; -BEGIN - //////////////////////////////// - IF Assigned( fOnGetHandle ) THEN - //////////////////////////////// - fHandle := fOnGetHandle( @Self ); - Result := fHandle; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TCanvas.AssignChangeEvents; -begin - if ( fBrush <> nil ) then - fBrush.fOnGTChange := ObjectChanged; - if ( fPen <> nil ) then - fPen.fOnGTChange := ObjectChanged; - if ( fFont <> nil ) then - fFont.fOnGTChange := ObjectChanged; -end; -{$ENDIF PAS_VERSION} -{$IFDEF WIN_GDI} - -{$IFNDEF _FPC} -{$IFNDEF _D2} -procedure TCanvas.WDrawText(WText: KOLWideString; var Rect: TRect; - Flags: DWord); -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - Windows.DrawTextW(Handle,PWideChar(WText),-1,Rect,Flags); -end; - -procedure TCanvas.WExtTextOut(X, Y: Integer; Options: DWORD; - const Rect: TRect; const WText: KOLWideString; - const Spacing: array of Integer); -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - Windows.ExtTextOutW(FHandle, X, Y, Options, @Rect, PWideChar(WText), Length(WText), @Spacing[ 0 ]); -end; - -procedure TCanvas.WTextOut(X, Y: Integer; const WText: KOLWideString); -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - Windows.TextOutW(FHandle, X, Y, PWideChar(WText), Length(WText)); - MoveTo(X + WTextWidth(WText), Y); -end; - -procedure TCanvas.WTextRect(const Rect: TRect; X, Y: Integer; - const WText: KOLWideString); -var - Options: Integer; -begin - RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - Options := ETO_CLIPPED; - if ( fBrush <> nil ) and (fBrush.fData.Brush.Style <> bsClear) - or ( fBrush = nil ) then Inc(Options, ETO_OPAQUE); - Windows.ExtTextOutW( fHandle, X, Y, Options, - @Rect, PWideChar(WText), - Length(WText), nil); -end; - -function TCanvas.WTextExtent(const WText: KOLWideString): TSize; -var DC : HDC; - ClearHandle : Boolean; -begin - ClearHandle := False; - RequiredState( HandleValid or FontValid ); - DC := fHandle; - if DC = 0 then - begin - DC := CreateCompatibleDC( 0 ); - ClearHandle := True; - SetHandle( DC ); - end; - RequiredState( HandleValid or FontValid ); - Windows.GetTextExtentPoint32W( fHandle, PWideChar(WText), Length(WText), Result); - if ClearHandle then - SetHandle( 0 ); -end; - -function TCanvas.WTextHeight(const WText: KOLWideString): Integer; -begin - Result := WTextExtent( WText ).cy; -end; - -function TCanvas.WTextWidth(const WText: KOLWideString): Integer; -begin - Result := WTextExtent( WText ).cx; -end; -{$ENDIF _D2} -{$ENDIF _FPC} - -{$ENDIF WIN_GDI} -function MakeInt64( Lo, Hi: DWORD ): I64; -begin - Result.Lo := Lo; - Result.Hi := Hi; -end; - -{$IFDEF PAS_ONLY} -{$ELSE} -function Int2Int64( X: Integer ): I64; -asm - MOV [EDX], EAX - MOV ECX, EDX - CDQ - MOV [ECX+4], EDX -end; - -procedure IncInt64( var I64: I64; Delta: Integer ); -asm - ADD [EAX], EDX - ADC dword ptr [EAX+4], 0 -end; - -procedure DecInt64( var I64: I64; Delta: Integer ); -asm - SUB [EAX], EDX - SBB dword ptr [EDX], 0 -end; - -function Add64( const X, Y: I64 ): I64; -asm - PUSH ESI - XCHG ESI, EAX - LODSD - ADD EAX, [EDX] - MOV [ECX], EAX - LODSD - ADC EAX, [EDX+4] - MOV [ECX+4], EAX - POP ESI -end; - -function Sub64( const X, Y: I64 ): I64; -asm - PUSH ESI - XCHG ESI, EAX - LODSD - SUB EAX, [EDX] - MOV [ECX], EAX - LODSD - SBB EAX, [EDX+4] - MOV [ECX+4], EAX - POP ESI -end; - -function Neg64( const X: I64 ): I64; -asm - MOV ECX, [EAX] - NEG ECX - MOV [EDX], ECX - MOV ECX, 0 - SBB ECX, [EAX+4] - MOV [EDX+4], ECX -end; - -function Mul64EDX( const X: I64; M: Integer ): I64; -asm - PUSH ESI - PUSH EDI - XCHG ESI, EAX - MOV EDI, ECX - MOV ECX, EDX - LODSD - MUL ECX - STOSD - XCHG EDX, ECX - LODSD - MUL EDX - ADD EAX, ECX - STOSD - POP EDI - POP ESI -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function Mul64i( const X: I64; Mul: Integer ): I64; -var Minus: Boolean; -begin - Minus := FALSE; - if Mul < 0 then - begin - Minus := TRUE; - Mul := -Mul; - end; - Result := Mul64EDX( X, Mul ); - if Minus then - Result := Neg64( Result ); -end; -{$ENDIF PAS_VERSION} - -function Div64EDX( const X: I64; D: Integer ): I64; -asm - PUSH ESI - PUSH EDI - XCHG ESI, EAX - MOV EDI, ECX - MOV ECX, EDX - MOV EAX, [ESI+4] - CDQ - DIV ECX - MOV [EDI+4], EAX - LODSD - DIV ECX - STOSD - POP EDI - POP ESI -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function Div64i( const X: I64; D: Integer ): I64; -var Minus: Boolean; -begin - Minus := FALSE; - if D < 0 then - begin - D := -D; - Minus := TRUE; - end; - Result := X; - if Sgn64( Result ) < 0 then - begin - Result := Neg64( Result ); - Minus := not Minus; - end; - Result := Div64EDX( Result, D ); - if Minus then - Result := Neg64( Result ); -end; -{$ENDIF PAS_VERSION} - -function Mod64i( const X: I64; D: Integer ): Integer; -begin - Result := Sub64( X, Mul64i( Div64i( X, D ), D ) ).Lo; -end; - -function Sgn64( const X: I64 ): Integer; -asm - XOR EDX, EDX - CMP [EAX+4], EDX - XCHG EAX, EDX - JG @@ret_1 - JL @@ret_neg - CMP [EDX], EAX - JZ @@exit -@@ret_1: - INC EAX - RET -@@ret_neg: - DEC EAX -@@exit: -end; - -function Cmp64( const X, Y: I64 ): Integer; -begin - Result := Sgn64( Sub64( X, Y ) ); -end; - -function Int64_2Str( X: I64 ): AnsiString; -var M: Boolean; - Y: Integer; - Buf: array[ 0..31 ] of AnsiChar; - I: Integer; -begin - M := FALSE; - case Sgn64( X ) of - -1: begin M := TRUE; X := Neg64( X ); end; - 0: begin Result := '0'; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - I := 31; - Buf[ 31 ] := #0; - while Sgn64( X ) > 0 do - begin - Dec( I ); - Y := Mod64i( X, 10 ); - Buf[ I ] := AnsiChar( Y + Integer( '0' ) ); - X := Div64i( X, 10 ); - end; - if M then - begin - Dec( I ); - Buf[ I ] := '-'; - end; - Result := PAnsiChar( @Buf[ I ] ); -end; - -function Int64_2Hex( X: I64; MinDigits: Integer ): KOLString; -begin - if (MinDigits <= 8) and (X.Hi <> 0) then - Result := Int2Hex( X.Hi, 1 ) + Int2Hex( X.Lo, 8 ) - else if X.Hi <> 0 then - Result := Int2Hex( X.Hi, MinDigits - 8 ) + Int2Hex( X.Lo, 8 ) - else Result := Int2Hex( X.Lo, MinDigits ); -end; - -function Str2Int64( const S: AnsiString ): I64; -var I: Integer; - M: Boolean; -begin - Result.Lo := 0; - Result.Hi := 0; - I := 1; - if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - M := FALSE; - if S[ 1 ] = '-' then - begin - M := TRUE; - Inc( I ); - end else if S[ 1 ] = '+' then - Inc( I ); - while I <= Length( S ) do - begin - if (S[ I ] < '0') or (S[ I ] > '9') then - break; - Result := Mul64i( Result, 10 ); - IncInt64( Result, Integer( S[ I ] ) - Integer( '0' ) ); - Inc( I ); - end; - if M then - Result := Neg64( Result ); -end; - -function Int64_2Double( const X: I64 ): Double; -asm - FILD qword ptr [EAX] - FSTP @Result -end; - -function Double2Int64( D: Double ): I64; -asm - FLD D - FISTP qword ptr [EAX] -end; -{$ENDIF PAS_ONLY} - -function IsNan(const AValue: Double): Boolean; -{$IFDEF _D2orD3} -type PI64 = ^I64; -{$ENDIF} -begin - Result := (PI64(@AValue).Hi and $7FF00000 = $7FF00000) and - ((PI64(@AValue).Hi and $000FFFFF <> 0) or (PI64(@AValue).Lo <> 0)); -end; - -function IsInfinity(const AValue: Double): Boolean; -{$IFDEF _D2orD3} -type PI64 = ^I64; -{$ENDIF} -begin - Result := (PI64(@AValue).Hi and $7FF00000 = $7FF00000) and - (PI64(@AValue).Hi and $000FFFFF = $00000000); -end; - -{$IFDEF PAS_ONLY} {$DEFINE PAS_INTPOW} {$ENDIF} -{$IFDEF F_P} {$DEFINE PAS_INTPOW} {$ENDIF} - -function IntPower(Base: Extended; Exponent: Integer): Extended; -{$IFDEF PAS_ONLY} -begin - Result := 1.0; - if Exponent = 0 then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Exponent < 0 then begin - Exponent := -Exponent; - Base := 1.0 / Base; - end; - REPEAT - Result := Result * Base; - Dec( Exponent ); - UNTIL Exponent=0; -end; -{$ELSE DELPHI} -// This version of code by Galkov: Changes in comparison to Delphi standard: -// no Overflow exception if Exponent is very big negative value -// (just 0 in result in such case). -asm - fld1 { Result := 1 } - test eax,eax // check Exponent for 0, return 0 ** 0 = 1 - jz @@3 // (though Mathematics says that this is not so...) - fld Base - jg @@2 - fdivr ST,ST(1) { Base := 1 / Base } - neg eax - jmp @@2 -@@1: fmul ST,ST { X := Base * Base } -@@2: shr eax,1 - jnc @@1 - fmul ST(1),ST { Result := Result * X } - jnz @@1 - fstp st { pop X from FPU stack } -@@3: fwait -end; -{$ENDIF PAS_ONLY} - -function NextPowerOf2( n: DWORD ): DWORD; -begin - Result := 1; - while (Result < n) and (Result <> 0) do - Result := Result shl 1; -end; - -function Str2Double( const S: KOLString ): Double; -var I: Integer; - M, Pt: Boolean; - D: Double; - Ex: Integer; -begin - Result := 0.0; - if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - M := FALSE; - I := 1; - if S[ 1 ] = '-' then - begin - M := TRUE; - Inc( I ); - end; - Pt := FALSE; - D := 1.0; - while I <= Length( S ) do - begin - case S[ I ] of - '.' {$IFNDEF SMALLEST_CODE}, ','{$ENDIF}: - if not Pt then Pt := TRUE else break; - '0'..'9': if not Pt then - Result := Result * 10 + Integer( S[ I ] ) - Integer( '0' ) - else - begin - D := D * 0.1; - Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D; - end; - 'e', 'E': begin - Ex := Str2Int( CopyEnd( S, I + 1 ) ); - Result := Result * IntPower( 10.0, Ex ); - break; - end; - end; - Inc( I ); - end; - if M then - Result := -Result; -end; - -function Str2Extended( const S: KOLString ): Extended; -var I: Integer; - M, Pt: Boolean; - D: Extended; - Ex: Integer; -begin - Result := 0.0; - if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - M := FALSE; - I := 1; - if S[ 1 ] = '-' then - begin - M := TRUE; - Inc( I ); - end; - Pt := FALSE; - D := 1.0; - while I <= Length( S ) do - begin - case S[ I ] of - '.' {$IFNDEF SMALLEST_CODE}, ','{$ENDIF}: - if not Pt then Pt := TRUE else break; - '0'..'9': if not Pt then - Result := Result * 10 + Integer( S[ I ] ) - Integer( '0' ) - else - begin - D := D * 0.1; - Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D; - end; - 'e', 'E': begin - Ex := Str2Int( CopyEnd( S, I + 1 ) ); - Result := Result * IntPower( 10.0, Ex ); - break; - end; - end; - Inc( I ); - end; - if M then - Result := -Result; -end; - -{$IFNDEF PAS_ONLY} -function TruncD( D: Double ): Double; -asm - FLD D - PUSH ECX - FNSTCW [ESP] - POP ECX - PUSH ECX - OR byte ptr [ESP+1], $0C - FLDCW [ESP] - PUSH ECX - FRNDINT - FSTP @Result - FLDCW [ESP] - POP ECX - POP ECX -end; -{$ENDIF} - -function IfThenElseBool( t, e: Boolean; Cond: Boolean ): Boolean; -begin - if cond then Result := t else Result := e; -end; -function IfThenElseInt( t, e: Integer; Cond: Boolean ): Integer; -begin - if cond then Result := t else Result := e; -end; -function IfThenElseStr( const t, e: AnsiString; Cond: Boolean ): AnsiString; -begin - if cond then Result := t else Result := e; -end; -{$IFDEF _D5orHigher} -function IfThenElse( t, e: Boolean; Cond: Boolean ): Boolean; overload; -begin - if cond then Result := t else Result := e; -end; -function IfThenElse( t, e: Integer; Cond: Boolean ): Integer; overload; -begin - if cond then Result := t else Result := e; -end; -function IfThenElse( t, e: AnsiString; Cond: Boolean ): AnsiString; overload; -begin - if cond then Result := t else Result := e; -end; -function IfThenElse( t, e: Double; Cond: Boolean ): Double; overload; -begin - if cond then Result := t else Result := e; -end; -{$ENDIF} - -// Precision 15 -function Extended2Str( E: Extended ): KOLString; - function UnpackFromBuf( const Buf: array of Byte; N: Integer ): KOLString; - var I, J, K, L: Integer; - begin - SetLength( Result, 16 ); - J := 1; - for I := 7 downto 0 do - begin - K := Buf[ I ] shr 4; - Result[ J ] := KOLChar( Ord('0') + K ); - Inc( J ); - K := Buf[ I ] and $F; - Result[ J ] := KOLChar( Ord('0') + K ); - Inc( J ); - end; - //Assert( Result[ 1 ] = '0', 'error!' ); - Delete( Result, 1, 1 ); - if N <= 0 then - begin - while N < 0 do - begin - Result := '0' + Result; - Inc( N ); - end; - Result := '0.' + Result; - end else - if N < Length( Result ) then - begin - Result := Copy( Result, 1, N ) + '.' + CopyEnd( Result, N + 1 ); - end else - begin - while N > Length( Result ) do - begin - Result := Result + '0'; - end; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - L := Length( Result ); - while L > 1 do - begin - if (Result[ L ] <> '0') - and (Result[ L ] <> '.') then - break; - Dec( L ); - if Result[ L + 1 ] = '.' then break; - end; - if L < Length( Result ) then Delete( Result, L + 1, MaxInt ); - end; -var - S: Boolean; -var F: Extended; - N: Integer; - Buf1: array[ 0..9 ] of Byte; - I10: Integer; -begin - Result := '0'; - if E = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - S := E < 0; - if S then E := -E; - - N := 15; - F := 5E12; - I10 := 10; - while E < F do - begin - Dec( N ); - E := E * I10; - end; - if N = 15 then - while E >= 1E13 do - begin - Inc( N ); - E := E / I10; - end; - - while TRUE do - begin - {$IFDEF PAS_ONLY} - if TRUNC(Abs(E)) >= 10000000 then - break; - {$ELSE} - asm - FLD [E] - FBSTP [Buf1] - end; - if Buf1[ 7 ] <> 0 then break; - {$ENDIF} - E := E * I10; - Dec( N ); - end; - Result := UnpackFromBuf( Buf1, N ); - if S then Result := '-' + Result; -end; - -function Extended2StrDigits( D: Double; n: Integer ): KOLString; -var i, m: Integer; -label start; -begin -start: - Result := Extended2Str( D ); - i := IndexOfChar( Result, '.' ); //pos( '.', Result ); - if n <= 0 then - begin - if i <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - delete( Result, i, MaxInt ); - end else - begin - if i <= 0 then - begin - i := Length( Result ) + 1; - Result := Result + '.'; - end; - if Length( Result ) - i < n then - Result := Result + StrRepeat( '0', n + i - Length( Result ) ) - else - begin - m := i + n; - if Length( Result ) <= m then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (Result[m+1] > '5') - or (Length( Result ) > m+1) - and (Result[m+2] > '0') then - begin - n := m; - inc( Result[n] ); - while Result[n] > '9' do - begin - Result[n] := '0'; - dec( n ); - if n = 0 then - begin - Result := '1' + Result; - break; - end; - if Result[n] = '.' then dec(n); - inc( Result[n] ); - end; - end; - delete( Result, m+1, MaxInt ); - end; - end; -end; - -function Double2Str( D: Double ): KOLString; -begin - Result := Extended2Str( D ); -end; - -function Double2StrEx( D: Double ): KOLString; -var E, E1, E2: Double; - S: KOLString; -begin - Result := Double2Str( D ); - E := Str2Double( Result ); - E1 := E - D; - if E1 < 0.0 then E1 := -E1; - if E1 < 1e-307 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - while TRUE do - begin - E := D - (E - D) * 0.3; - S := Double2Str( E ); - if S = Result then break; - E := Str2Double( S ); - E2 := E - D; - if E2 < 0.0 then E2 := -E2; - if E2 > E1 * 0.75 then break; - Result := S; - if E2 < E1 * 0.1 then break; - end; -end; - -function GetBits( N: DWORD; first, last: Byte ): DWord; -{$IFDEF F_P} -begin - Result := 0; - if last > 31 then last := 31; - if first > last then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := (N and not ($FFFFFFFF shl last)) shr first; -end; -{$ELSE DELPHI} -asm - XCHG EAX, EDX // (1) EDX=N, AL=first - {$IFDEF PARANOIA} DB $3C, 31 {$ELSE} CMP AL, 31 {$ENDIF} // first(AL) > 31 ? - JBE @@1 // (2) если да, то Result := 0; -@@0: - XOR EAX, EAX // (2) - RET // (1) -@@1: - - XCHG EAX, ECX // (1) AL = last CL = first - SHR EDX, CL // (2) EDX = N shr first - SUB AL, CL // (2) AL = last - first - JL @@0 // (2) если last < first то Result := 0; - - {$IFDEF PARANOIA} DB $3C, 32 {$ELSE} CMP AL, 32 {$ENDIF} // (2) last - first >= 32 ? - XCHG ECX, EAX // (1) CL = last - first - XCHG EAX, EDX // (1) EAX = N shr first - JAE @@exit // (2) если last - first > 31, то Result := EAX; - SBB EDX, EDX // (2) EDX = -1 - DEC EDX // (1) EDX = 1111...10 = -2 - SHL EDX, CL // (2) EDX = 111...100..0 (где n(0)=last-first+1) - NOT EDX // (2) EDX = маска 000..0111...1 (где n(1)=last-first+1) - AND EAX, EDX // (2) -@@exit: - // EAX = результат, (1 байт на команду RET) -end; -{$ENDIF F_P/DELPHI} - -function GetBitsL( N: DWORD; from, len: Byte ): DWord; -{$IFDEF F_P} -begin - Result := GetBits( N, from, from + len - 1 ); -end; -{$ELSE DELPHI} -asm - ADD CL, DL - DEC CL - JMP GetBits -end; -{$ENDIF F_P/DELPHI} - -{$IFNDEF FPC} -function MulDiv( A, B, C: Integer ): Integer; -asm - IMUL EDX - IDIV ECX -end; -{$ENDIF} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -function Int2Hex( Value : DWord; Digits : Integer ) : KOLString; -const - HexDigitChr: array[ 0..15 ] of KOLChar = ( '0','1','2','3','4','5','6','7', - '8','9','A','B','C','D','E','F' ); -var Buf: array[ 0..8 ] of KOLChar; - Dest : PKOLChar; -begin - Dest := @Buf[ 8 ]; - Dest^ := #0; - repeat - Dec( Dest ); - Dest^ := '0'; - if Value <> 0 then - begin - Dest^ := HexDigitChr[ Value and $F ]; - Value := Value shr 4; - end; - Dec( Digits ); - until (Value = 0) and (Digits <= 0); - Result := Dest; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function Hex2Int( const Value : KOLString) : Integer; -var I : Integer; -begin - Result := 0; - I := 1; - if Value = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Value[ 1 ] = '$' then Inc( I ); - while I <= Length( Value ) do - begin - if (Value[ I ] >= '0') - and (Value[ I ] <= '9') then - Result := (Result shl 4) or (Ord(Value[I]) - Ord('0')) - else if (Value[ I ] >= 'A') - and (Value[ I ] <= 'F') then - Result := (Result shl 4) or (Ord(Value[I]) - Ord('A') + 10) - else if (Value[ I ] >= 'a') - and (Value[ I ] <= 'f') then - Result := (Result shl 4) or (Ord(Value[I]) - Ord('a') + 10) - else break; - Inc( I ); - end; -end; -{$ENDIF PAS_VERSION} - -function Octal2Int( const Value: AnsiString ) : Integer; -var I: Integer; -begin - Result := 0; - for I := 1 to Length( Value ) do - begin - if (Value[ I ] >= '0') and (Value[ I ] <= '7') then - Result := Result * 8 + Ord( Value[ I ] ) - Ord( '0' ) - else break; - end; -end; - -function Binary2Int( const Value: AnsiString ) : Integer; -var I: Integer; -begin - Result := 0; - for I := 1 to Length( Value ) do - begin - if (Value[ I ] = '0') or (Value[ I ] = '1') then - Result := Result * 2 + Ord( Value[ I ] ) - Ord( '0' ) - else break; - end; -end; - -function ToRadix( number: Radix_Int; radix: Integer; min_digits: Integer ): KOLString; -var Buf: array[ 0..64 ] of KOLChar; - p: PKOLChar; - n: Integer; - {$IFDEF _D5orHigher} - numd: Extended; - {$ENDIF} -begin - {$IFDEF KOL_ASSERTIONS} - Assert( (radix >= 2) and (radix <= 36), 'Radix base must be between 2 and 36' ); - Assert( min_digits <= 64, 'Maximum possible digits number is 64' ); - {$ENDIF KOL_ASSERTIONS} - p := @ Buf[ 64 ]; - p^ := #0; - while (number <> 0) do - begin - dec( p ); - {$IFDEF _D5orHigher} - if number < 0 then - begin - numd := 1.0 * I64( number ).Hi * $10000 * $10000 + I64( number ).Lo; - number := Round( numd / radix ); - n := Round( numd - 1.0 * number * radix ); - if n < 0 then - begin - n := radix + n; - dec( number ); - end; - end else - {$ENDIF} - begin - n := number mod radix; - number := number div radix; - end; - if n <= 9 then p^ := KOLChar( n + Ord( '0' ) ) - else p^ := KOLChar( n - 10 + Ord( 'A' ) ); - dec( min_digits ); - end; - while (min_digits > 0) do - begin - dec( p ); - p^ := '0'; - dec( min_digits ); - end; - Result := p; -end; - -function FromRadixStr( var Rslt: Radix_int; s: PKOLChar; radix: Integer ): PKOLChar; -var n: Integer; -begin - {$IFDEF KOL_ASSERTIONS} - Assert( (radix >= 2) and (radix <= 36), 'Radix base must be between 2 and 36' ); - {$ENDIF KOL_ASSERTIONS} - Rslt := 0; - while s^ <> #0 do - begin - CASE s^ OF - '0'..'9': n := Ord( s^ ) - Ord( '0' ); - 'a'..'z': n := Ord( s^ ) - Ord( 'a' ) + 10; - 'A'..'Z': n := Ord( s^ ) - Ord( 'A' ) + 10; - else n := 100; - END; - if n >= radix then break; - Rslt := Rslt * radix + n; - inc( s ); - end; - Result := s; -end; - -function FromRadix( const s: AnsiString; radix: Integer ): Radix_int; -begin - Result := 0; - if s = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FromRadixStr( Result, @ s[ 1 ], radix ); -end; - -function InsertSeparators( const s: KOLString; chars_between: Integer; Separator: KOLChar ): KOLString; -var L, from_L, n: Integer; -begin - if (s = '') or (chars_between <= 0) then - begin - Result := s; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - From_L := Length( s ); - L := From_L + From_L div chars_between; - SetLength( Result, L ); - while L >= 1 do - begin - for n := 1 to chars_between do - begin - Result[ L ] := s[ from_L ]; - dec( L ); - dec( from_L ); - if L < 1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result[ L ] := Separator; - dec( L ); - end; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function cHex2Int( const Value : KOLString) : Integer; -begin - if (Length(Value)>2) and (Value[1]='0') - and ((Value[2]='x') or (Value[2]='X')) then - Result := Hex2Int( CopyEnd( Value, 3 ) ) - else Result := Hex2Int( Value ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function Int2Str( Value : Integer ) : KOLString; -var Buf : Array[ 0..15 ] of KOLChar; - Dst : PKOLChar; - Minus : Boolean; - D: DWORD; -begin - Dst := @Buf[ 15 ]; - Dst^ := #0; - Minus := False; - if Value < 0 then - begin - Value := -Value; - Minus := True; - end; - D := Value; - repeat - Dec( Dst ); - Dst^ := KOLChar( (D mod 10) + Byte( '0' ) ); - D := D div 10; - until D = 0; - if Minus then - begin - Dec( Dst ); - Dst^ := '-'; - end; - Result := Dst; -end; -{$ENDIF PAS_VERSION} - -procedure Int2PChar( s: PAnsiChar; Value: Integer ); -var Buf : array[ 0..15 ] of AnsiChar; - Dst : PAnsiChar; - Minus : Boolean; - D: DWORD; -begin - Dst := @Buf[ 15 ]; - Dst^ := #0; - Minus := False; - if Value < 0 then - begin - Value := -Value; - Minus := True; - end; - D := Value; - repeat - Dec( Dst ); - Dst^ := AnsiChar( (D mod 10) + Byte( '0' ) ); - D := D div 10; - until D = 0; - if Minus then - begin - Dec( Dst ); - Dst^ := '-'; - end; - StrCopy( s, Dst ); -end; - -function UInt2Str( Value: DWORD ): AnsiString; -var Buf : Array[ 0..15 ] of AnsiChar; - Dst : PAnsiChar; - D: DWORD; -begin - Dst := @Buf[ 15 ]; - Dst^ := #0; - D := Value; - repeat - Dec( Dst ); - Dst^ := AnsiChar( (D mod 10) + Byte( '0' ) ); - D := D div 10; - until D = 0; - Result := Dst; -end; - -function Int2StrEx( Value, MinWidth: Integer ): KOLString; -begin - Result := Int2Str( Value ); - while Length( Result ) < MinWidth do - Result := ' ' + Result; -end; - -function Int2Rome( Value: Integer ): KOLString; -const RomeDigs = KOLString('IVXLCDMT'); - function RomeNum( N, FromIdx: Integer ): KOLString; - begin - CASE N OF - 1, 2, 3: Result := StrRepeat( RomeDigs[ FromIdx ], N ); - 4: Result := KOLString('') + KOLString(RomeDigs[ FromIdx ]) + - KOLString(RomeDigs[ FromIdx + 1 ]); - 5, 6, 7, 8: Result := KOLString(RomeDigs[ FromIdx + 1 ]) + - StrRepeat( RomeDigs[ FromIdx ], N - 5 ); - 9: Result := KOLString('') + KOLString(RomeDigs[ FromIdx ]) + - KOLString(RomeDigs[ FromIdx + 2 ]); - else Result := ''; - END; - end; -var I, J: Integer; -begin - Result := ''; - if Value < 1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Value > 8999 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // maximum possible is TMMMCMXCIX, i.e. 8999 - J := 1; - for I := 1 to 3 do - begin - Result := RomeNum( Value mod 10, J ) + Result; - Value := Value div 10; - if Value = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Inc( J, 2 ); - end; -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -function Int2Ths( I : Integer ): KOLString; -var S : KOLString; -begin - S := Int2Str( I ); - Result := ''; - while S <> '' do - begin - if Result <> '' then - Result := KOLString(ThsSeparator) + Result; - Result := CopyTail( S, 3 ) + Result; - S := Copy( S, 1, Length( S ) - 3 ); - end; - if Copy( Result, 1, 2 ) = KOLString('-') + KOLString(ThsSeparator) then - Result := '-' + CopyEnd( Result, 3 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function Int2Digs( Value, Digits : Integer ) : KOLString; -var M : KOLString; -begin - Result := Int2Str( Value ); - M := ''; - if Value < 0 then - begin - M := '-'; - Result := CopyEnd( Result, 2 ); - end; - if Digits >= 0 then - while Length( M + Result ) < Digits do - Result := '0' + Result - else - while Length( Result ) < -Digits do - Result := '0' + Result; - Result := M + Result; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -{$IFDEF _D2009orHigher} const Suffix: AnsiString = 'KMGT'; -{$ELSE} const Suffix = 'KMGT'; {$ENDIF} -function Num2Bytes( Value : Double ) : KOLString; -var V, I : Integer; -begin - Result := ''; - I := 0; - while (Value >= 1024) and (I < 4) do - begin - Inc( I ); - Value := Value / 1024.0; - end; - Result := Int2Str( Trunc( Value ) ); - V := Trunc( (Value - Trunc( Value )) * 100 ); - if V <> 0 then - begin - if (V mod 10) = 0 then - V := V div 10; - Result := Result + ',' + Int2Str( V ); - end; - if I > 0 then - Result := Result + KOLString( Suffix[ I ] ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function S2Int( S: PKOLChar ): Integer; -var M : Integer; -begin - Result := 0; - if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - M := 1; - if S^ = '-' then - begin - M := -1; - Inc( S ); - end else - if S^ = '+' then - Inc( S ); - while (S^>='0') and (S^<='9') do - begin - Result := Result * 10 + Integer( S^ ) - Integer( '0' ); - Inc( S ); - end; - if M < 0 then Result := -Result; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function Str2Int(const Value : KOLString) : Integer; -begin - Result := S2Int( PKOLChar( Value ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF PAS_ONLY} -function StrCopy( Dest, Source: PAnsiChar ): PAnsiChar; -var L: Integer; -begin - L := StrLen(Source); - Move(Source^, Dest^, L+1); - Result := Dest; -end; -{$ELSE} -function StrCopy( Dest, Source: PAnsiChar ): PAnsiChar; assembler; -asm - {$IFDEF F_P} - MOV EAX, [Dest] - MOV EDX, [Source] - {$ENDIF F_P} - PUSH EDI - PUSH ESI - MOV ESI,EAX - MOV EDI,EDX - OR ECX, -1 - XOR AL,AL - REPNE SCASB - NOT ECX - MOV EDI,ESI - MOV ESI,EDX - MOV EDX,ECX - MOV EAX,EDI - SHR ECX,2 - REP MOVSD - MOV ECX,EDX - AND ECX,3 - REP MOVSB - POP ESI - POP EDI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF PAS_ONLY} - -function StrCat( Dest, Source: PAnsiChar ): PAnsiChar; -begin - StrCopy( StrScan( Dest, #0 ), Source ); - Result := Dest; -end; - -{$IFDEF PAS_ONLY} -function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; -begin - while Str^ <> Chr do - begin - if Str^ = #0 then break; - inc(Str); - end; - Result := Str; -end; -{$ELSE} -function StrScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; assembler; -asm - {$IFDEF F_P} - MOV EAX, [Str] - MOVZX EDX, [Chr] - {$ENDIF} - PUSH EDI - PUSH EAX - MOV EDI,Str - OR ECX, -1 - XOR AL,AL - REPNE SCASB - NOT ECX - POP EDI - XCHG EAX, EDX - REPNE SCASB - - XCHG EAX, EDI - POP EDI - - JE @@1 - XOR EAX, EAX - RET - -@@1: DEC EAX -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF PAS_ONLY} - -{$IFDEF PAS_ONLY} -function StrRScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; -begin - Result := nil; - while Str^ <> #0 do - begin - if Str^ = Chr then Result := Str; - inc(Str); - end; - if Result = nil then - Result := Str; -end; -{$ELSE} -function StrRScan(Str: PAnsiChar; Chr: AnsiChar): PAnsiChar; assembler; -asm - {$IFDEF F_P} - MOV EAX, [Str] - MOVZX EDX, [Chr] - {$ENDIF F_P} - PUSH EDI - MOV EDI,Str - MOV ECX,0FFFFFFFFH - XOR AL,AL - REPNE SCASB - NOT ECX - STD - DEC EDI - MOV AL,Chr - REPNE SCASB - MOV EAX,0 - JNE @@1 - MOV EAX,EDI - INC EAX -@@1: CLD - POP EDI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF PAS_ONLY} - -{$IFDEF PAS_ONLY} -function StrScanLen(Str: PAnsiChar; Chr: AnsiChar; Len: Integer): PAnsiChar; -begin - while (Str^ <> #0) and (Len > 0) do - begin - if Str^ = Chr then break; - inc(Str); - dec(Len); - end; - Result := Str; -end; -{$ELSE} -function StrScanLen(Str: PAnsiChar; Chr: AnsiChar; Len: Integer): PAnsiChar; assembler; -asm - {$IFDEF F_P} - MOV EAX, [Str] - MOVZX EDX, [Chr] - MOV ECX, [Len] - {$ENDIF F_P} - PUSH EDI - XCHG EDI, EAX - XCHG EAX, EDX - REPNE SCASB - XCHG EAX, EDI - POP EDI - { -> EAX => to next character after found or to the end of Str, - ZF = 0 if character found. } -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TrimLeft(const S: KOLString): KOLString; -var - I, L: Integer; -begin - L := Length(S); - I := 1; - while (I <= L) and (S[I] <= ' ') do Inc(I); - Result := Copy(S, I, Maxint); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TrimRight(const S: KOLString): KOLString; -var - I: Integer; -begin - I := Length(S); - while (I > 0) and (S[I] <= ' ') do Dec(I); - Result := Copy(S, 1, I); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function Trim( const S : KOLString): KOLString; -begin - Result := TrimLeft( TrimRight( S ) ); -end; -{$ENDIF PAS_VERSION} - -function RemoveSpaces( const S: KOLString ): KOLString; -var I: Integer; -begin - Result := S; - for I := Length( S ) downto 1 do - if S[ I ] <= ' ' then Delete( Result, I, 1 ); -end; - -{$IFDEF PAS_ONLY} -procedure Str2LowerCase( S: PAnsiChar ); -begin - while S^ <> #0 do - begin - if (S^ >= 'A') and (S^ <= 'Z') then - S^ := AnsiChar(Ord(S^)+32); - inc(S); - end; -end; -{$ELSE} -procedure Str2LowerCase( S: PAnsiChar ); -asm - {$IFDEF F_P} - MOV EAX, [S] - {$ENDIF} - XOR ECX, ECX -@@1: - MOV CL, byte ptr [EAX] - JECXZ @@exit {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SUB CL, 'A' - CMP CL, 'Z'-'A' - JA @@2 - ADD byte ptr [EAX], 32 -@@2: INC EAX - JMP @@1 -@@exit: -end {$IFDEF F_P} [ 'EAX', 'ECX' ] {$ENDIF}; -{$ENDIF PAS_ONLY} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function LowerCase(const S: Ansistring): Ansistring; -var I : Integer; -begin - Result := S; - for I := 1 to Length( S ) do - if (Result[ I ] >= 'A') and (Result[ I ] <= 'Z') then - Inc( Result[ I ], 32 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function UpperCase(const S: Ansistring): Ansistring; -var I : Integer; -begin - Result := S; - for I := 1 to Length( S ) do - if (Result[ I ] >= 'a') and (Result[ I ] <= 'z') then - Dec( Result[ I ], 32 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF F_P} -function DummyStrFun( const S: AnsiString ): AnsiString; -begin - Result := S; -end; -{$ENDIF F_P} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString; -begin - Result := Copy( S, Idx, MaxInt ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function CopyTail( const S : KOLString; Len : Integer ) : KOLString; -var L : Integer; -begin - L := Length( S ); - if L < Len then - Len := L; - Result := ''; - if Len = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Copy( S, L - Len + 1, Len ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure DeleteTail( var S : KOLString; Len : Integer ); -var L : Integer; -begin - L := Length( S ); - if Len > L then - Len := L; - Delete( S, L - Len + 1, Len ); -end; -{$ENDIF PAS_VERSION} - -{$IFNDEF TEST_INDEXOFCHARS_COMPAT} -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer; -var //P, F : PChar; - i, l : integer; -begin - Result := -1; - if S = '' then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - l := Length(S); - for I := 1 to l do - begin - if S[I] = Chr then - begin - Result := I; - break; - end; - end; -end; -{$ENDIF PAS_VERSION} -{$ELSE TEST_INDEXOFCHARS_COMPAT}//////////////////////////////////////////////// -function IndexOfChar_Old( const S : AnsiString; Chr : AnsiChar ) : Integer; -var P, F : PAnsiChar; -begin - P := PAnsiChar( S ); - F := StrScan( P, Chr ); - Result := -1; - if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Integer( F ) - Integer( P ) + 1; -end; /////////////////////////////////////////////////////////////////////////// -function IndexOfChar_New( const S : AnsiString; Chr : AnsiChar ) : Integer; -var P, F : PAnsiChar; -begin - P := PAnsiChar( S ); - F := StrScanLen( P, Chr, Length( S ) ); - Result := -1; - if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Integer( F ) - Integer( P ); - if {(Result > Length(S)) or} (S[ Result ] <> Chr) then - Result := -1; -end; /////////////////////////////////////////////////////////////////////////// -function Replace0with_( const s: AnsiString ): AnsiString; -var i: Integer; -begin - Result := s; - for i := 1 to Length( s ) do - if s[i] = #0 then Result[i] := '_'; -end; -function IndexOfChar( const S : KOLString; Chr : KOLChar ) : Integer; -begin - Result := IndexOfChar_Old( S, Chr ); - if Result <> IndexOfChar_New( S, Chr ) then - begin - LogFileOutput( 'c:\kol\TEST_INDEXOFCHARS_COMPAT.txt', - 'S=' + Replace0with_( S ) + #13#10 + - 'C=' + Replace0with_( Chr ) + ' Old=' + Int2Str( Result ) + - ' New=' + Int2Str( IndexOfChar_New( S, Chr ) ) + #13#10 ); - end; -end; -{$ENDIF} - -{$IFDEF _D3orHigher} -function WIndexOfChar( const S : KOLWideString; Chr : WideChar ) : Integer; -var i, l : integer; -begin - Result := -1; - if S = '' then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - l := Length(S); - for I := 1 to l do - begin - if S[I] = Chr then - begin - Result := I; - break; - end; - end; -end; -{$ENDIF} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function IndexOfCharsMin( const S, Chars : KOLString ) : Integer; -var I, J : Integer; -begin - Result := -1; - for I := 1 to Length( Chars ) do - begin - J := IndexOfChar( S, Chars[ I ] ); - if J > 0 then - begin - if (Result <= 0) or (J < Result) then - Result := J; - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF _D3orHigher} -function WIndexOfCharsMin( const S, Chars : KOLWideString ) : Integer; -var I, J : Integer; -begin - Result := -1; - for I := 1 to Length( Chars ) do - begin - J := WIndexOfChar( S, Chars[ I ] ); - if J > 0 then - begin - if (Result <= 0) or (J < Result) then - Result := J; - end; - end; -end; -{$ENDIF} - -{$IFNDEF _FPC} -{$IFNDEF _D2} -function IndexOfWideCharsMin( const S, Chars : KOLWideString ) : Integer; -var I, J : Integer; -begin - Result := -1; - for I := 1 to Length( Chars ) do - begin - J := pos( Chars[ I ], S ); - if J > 0 then - begin - if (Result < 0) or (J < Result) then - Result := J; - end; - end; -end; -{$ENDIF _D2} -{$ENDIF _FPC} - - {$DEFINE ASM_LOCAL} -{$IFDEF PAS_VERSION} {$UNDEF ASM_LOCAL}{$ENDIF} -{$IFDEF UNICODE_CTRLS}{$UNDEF ASM_LOCAL}{$ENDIF} -{$IFDEF _D2} {$UNDEF ASM_LOCAL}{$ENDIF} -{$IFDEF _D3} {$UNDEF ASM_LOCAL}{$ENDIF} - -{$IFDEF ASM_LOCAL} -function IndexOfStr( const S, Sub : KOLString ) : Integer; -asm - PUSH EBX - PUSH ESI - PUSH EDI - - PUSH EAX - MOV EAX, EDX - PUSH EDX - CALL System.@LStrLen - MOV EDI, EAX - POP EAX - CALL EAX2PChar - MOV BL, [EAX] - XCHG EAX, [ESP] - CALL EAX2PChar - - MOV ESI, EAX - - DEC EAX -@@1: INC EAX - MOV DL, BL - MOV ECX, [ESI-4] - SUB ECX, EAX - ADD ECX, ESI - - CMP ECX, EDI - JL @@ret__1 - - CALL StrScanLen - TEST EAX, EAX - JE @@exit__1 - DEC EAX - - POP EDX - PUSH EDX - - MOV ECX, EDI - PUSH EAX - //CALL StrLComp - CALL CompareMem - TEST AL, AL - POP EAX - JZ @@1 - - SUB EAX, ESI - INC EAX - JMP @@exit - -@@ret__1: - XOR EAX, EAX -@@exit__1: - DEC EAX -@@exit: - POP EDX - POP EDI - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function IndexOfStr( const S, Sub : KOLString ) : Integer; -begin - Result := pos( Sub, S ); - if Result = 0 then Result := -1; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function Parse( var S : KOLString; const Separators : KOLString ) : KOLString; -var Pos : Integer; -begin - Pos := IndexOfCharsMin( S, Separators ); - if Pos <= 0 then - Pos := Length( S )+1; - Result := Copy( S, 1, Pos-1 ); - Delete( S, 1, Pos ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF _D3orHigher} -function ParseW( var S : KOLWideString; const Separators : KOLWideString ) : KOLWideString; -var Pos : Integer; -begin - Pos := WIndexOfCharsMin( S, Separators ); - if Pos <= 0 then - Pos := Length( S )+1; - Result := Copy( S, 1, Pos-1 ); - Delete( S, 1, Pos ); -end; -{$ENDIF} - -{$IFNDEF _FPC} -{$IFNDEF _D2} -function WParse( var S : KOLWideString; const Separators : KOLWideString ) : KOLWideString; -var Pos : Integer; -begin - Pos := IndexOfWideCharsMin( S, Separators ); - if Pos <= 0 then - Pos := Length( S ) + 1; - Result := S; - S := Copy( Result, Pos + 1, MaxInt ); - Result := Copy( Result, 1, Pos - 1 ); -end; -{$ENDIF _D2} -{$ENDIF _FPC} - -function ParsePascalString( var S : KOLString; const Separators : KOLString ) : KOLString; -var Pos, Idx : Integer; - Hex, Spc : Boolean; - procedure SkipSpaces; - begin - if not Spc then - while (Length( S ) >= Pos) and (S[ Pos ] = ' ') do - Inc( Pos ); - end; -var Buf : KOLString; - Ou, Val : Integer; -begin - Pos := 1; - Spc := IndexOfChar( Separators, ' ' ) >= 0; - SkipSpaces; - if Length( S ) < Pos then - begin - Result := S; - S := ''; - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Buf := PKOLChar( S ); - Ou := 1; - if (S[ Pos ] = '''') or (S[ Pos ] = '#') then - begin - // skip here string constant expression - while Pos <= Length( S ) do - begin - if S[ Pos ] = '''' then - begin - Inc( Pos ); - while Pos <= Length( S ) do - begin - if S[ Pos ] = '''' then - if (Pos = Length( S )) or (S[ Pos+1 ] <> '''') then - begin - Inc( Pos ); - break; - end else Inc( Pos ); - Buf[ Ou ] := S[ Pos ]; - Inc( Ou ); - Inc( Pos ); - end; - end else - if S[ Pos ] = '#' then - begin - Inc( Pos ); Hex := False; Val := 0; - if (Pos < Length( S )) and (S[ Pos ] = '$') then - begin - Inc( Pos ); Hex := True; - end; - Dec( Pos ); - while Pos < Length( S ) do - begin - Inc( Pos ); - if (S[ Pos ] >= '0') and (S[ Pos ] <= '9') or - Hex and ( (S[ Pos ] >= 'a') and (S[ Pos ] <= 'f') or - (S[ Pos ] >= 'A') and (S[ Pos ] <= 'F') ) then - begin - if Hex then - Val := Val * 16 - else Val := Val * 10; - if S[ Pos ] <= '9' then - Val := Val + Integer( S[ Pos ] ) - Integer( '0' ) - else if S[ Pos ] <= 'F' then - Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'A' ) - else Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'a' ); - continue; - end; - Inc( Pos ); break; - end; - Buf[ Ou ] := KOLChar( Val ); - Inc( Ou ); - end else break; - SkipSpaces; - if S[ Pos ] <> '+' then break; - SkipSpaces; - end; - end; - Idx := IndexOfCharsMin( CopyEnd( S, Pos ), Separators ); - if Idx <= 0 then - begin - Result := Copy( Buf, 1, Ou - 1 ) + CopyEnd( S, Pos ); - S := ''; - end else - begin - Result := Copy( Buf, 1, Ou - 1 ) + Copy( S, Pos, Idx - 1 ); - S := CopyEnd( S, Pos + Idx ); - end; -end; - -function String2PascalStrExpr( const S : KOLString ) : KOLString; -var I, Strt : Integer; - function String2DoubleQuotas( const S : KOLString ) : KOLString; - var I, J : Integer; - begin - if IndexOfChar( S, '''' ) <= 0 then - Result := S - else - begin - J := 0; - for I := 1 to Length( S ) do - if S[ I ] = '''' then Inc( J ); - SetLength( Result, Length( S ) + J ); - J := 1; - for I := 1 to Length( S ) do - begin - Result[ J ] := S[ I ]; - Inc( J ); - if S[ I ] = '''' then - begin - Result[ J ] := ''''; - Inc( J ); - end; - end; - end; - end; -begin - Result := ''; - if S = '' then - begin - Result := ''''''; - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Strt := 1; - for I := 1 to Length( S ) + 1 do - begin - if (I > Length( S )) or (S[ I ] < ' ') or (S[ I ] >= #$7F) then - begin - if (I > Strt) and (I > 1) then - begin - if Result <> '' then - Result := Result + '+'; - Result := Result + '''' + String2DoubleQuotas( Copy( S, Strt, I - Strt ) ) + ''''; - end; - if I > Length( S ) then break; - if Result <> '' then - Result := Result + '+' - else Result := Result + '''''+'; - Result := Result + '#' + Int2Str( Integer( S[ I ] ) ); - Strt := I + 1; - end; - end; -end; - -{$IFDEF PAS_ONLY} -function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; -var PP1, PP2: PByte; -begin - Result := FALSE; - PP1 := P1; - PP2 := P2; - while (Length > 0) do - begin - if (PP1^ <> PP2^) then - Exit; //>>>>>>>>>>>>>>>>>>>>>>>> - inc(PP1); - inc(PP2); - dec(Length); - end; - Result := TRUE; -end; -{$ELSE} -function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler; -asm - {$IFDEF F_P} - MOV EAX, [P1] - MOV EDX, [P2] - MOV ECX, [Length] - {$ENDIF} - PUSH ESI - PUSH EDI - MOV ESI,P1 - MOV EDI,P2 - MOV EDX,ECX - XOR EAX,EAX - AND EDX,3 - SHR ECX,1 - SHR ECX,1 - REPE CMPSD - JNE @@2 - MOV ECX,EDX - REPE CMPSB - JNE @@2 -@@1: INC EAX -@@2: POP EDI - POP ESI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function AllocMem( Size : Integer ) : Pointer; -begin - Result := nil; - if Size > 0 then - begin - GetMem( Result, Size ); - //FillChar( Result^, Size, 0 ); - ZeroMemory( Result, Size ); - end; -end; -{$ENDIF PAS_VERSION} - -procedure DisposeMem( var Addr : Pointer ); -begin - if Addr <> nil then - FreeMem( Addr ); - Addr := nil; -end; - -{$IFDEF WIN} -function AnsiUpperCase(const S: AnsiString): AnsiString; -var Len: Integer; -begin - Len := Length(S); - SetString(Result, PAnsiChar(S), Len); - if Len > 0 then CharUpperBuffA(Pointer(Result), Len); -end; - -function AnsiLowerCase(const S: Ansistring): Ansistring; -var - Len: Integer; -begin - Len := Length(S); - SetString(Result, PAnsiChar(S), Len); - if Len > 0 then CharLowerBuffA(Pointer(Result), Len); -end; - -function KOLUpperCase(const S: KOLString): KOLString; -var Len: Integer; -begin - Len := Length(S); - SetString(Result, PKOLChar( S ), Len); - if Len > 0 then CharUpperBuff(PKOLChar(Result), Len); -end; - -function KOLLowerCase(const S: KOLString): KOLString; -var - Len: Integer; -begin - Len := Length(S); - SetString(Result, PKOLChar(S), Len); - if Len > 0 then CharLowerBuff(PKOLChar(Result), Len); -end; - -{$IFDEF _D3orHigher} -function WUpperCase(const S: KOLWideString): KOLWideString; -var Len: Integer; -begin - Len := Length(S); - SetString(Result, PWideChar( S ), Len); - if Len > 0 then CharUpperBuffW(PWideChar(Result), Len); -end; - -function WLowerCase(const S: KOLWideString): KOLWideString; -var - Len: Integer; -begin - Len := Length(S); - SetString(Result, PWideChar(S), Len); - if Len > 0 then CharLowerBuffW(PWideChar(Result), Len); -end; -{$ENDIF} -{$ENDIF WIN} - -{$IFNDEF _D2} -{$IFNDEF _FPC} - -{$IFDEF WIN} -function WAnsiUpperCase(const S: KOLWideString): KOLWideString; -var Len: Integer; -begin - Result := S; - Len := Length(S); - if Len > 0 then CharUpperBuffW(Pointer(Result), Len); -end; -{$ENDIF WIN} - -{$IFDEF WIN} -function WAnsiLowerCase(const S: KOLWideString): KOLWideString; -var Len: Integer; -begin - Result := S; - Len := Length(S); - if Len > 0 then CharLowerBuffW(Pointer(Result), Len); -end; -{$ENDIF WIN} - -{$IFDEF WIN} -function WStrComp(const S1, S2: KOLWideString): Integer; -var i: Integer; -begin - for i := 1 to min( Length( S1 ), Length( S2 ) ) do - begin - Result := Ord( S1[ i ] ) - Ord( S2[ i ] ); - if Result <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := Length( S1 ) - Length( S2 ); -end; - -{$IFDEF ASM_VERSION}{$ELSE} -function _WStrComp(S1, S2: PWideChar): Integer; -var - L, R : PWideChar; -begin - L := S1; - R := S2; - Result := 0; - repeat - if L^ = R^ then - begin - if L^ = #0 then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Inc(L); - Inc(R); - end else - begin - Result := (Word(L^) - Word(R^)); - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - until (False); -end; -{$ENDIF} - -{$IFDEF PAS_ONLY} -function _WStrLComp(S1, S2: PWideChar; Len: Integer): Integer; -begin - while (Len > 0) and (S1^ <> #0) and (S2^ <> #0) do - begin - Result := Ord(S1^) - Ord(S2^); - if Result <> 0 then Exit; // >>>>>>>>>>>>>>>>>>>> - dec(Len); - end; - Result := 0; -end; -{$ELSE} -function _WStrLComp(S1, S2: PWideChar; Len: Integer): Integer; -asm - {$IFDEF F_P} - MOV EAX, [S1] - MOV EDX, [S2] - MOV ECX, [Len] - {$ENDIF F_P} - PUSH EDI - PUSH ESI - MOV EDI,EDX - XCHG ESI,EAX - CMP EAX, EAX - REPE CMPSW - MOVZX EAX, word ptr [ESI-2] - MOVZX EDX, word ptr [EDI-2] - SUB EAX,EDX - POP ESI - POP EDI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF} - -function WStrScan(Str: PWideChar; Chr: WideChar): PWideChar; -begin - while (Str^ <> Chr) and (Str^ <> #0) do inc( Str ); - Result := Str; -end; - -function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; -begin - Result := Str; - while Result^ <> #0 do inc( Result ); - while (DWORD( Result ) >= DWORD( Str )) and - (Result^ <> Chr) do dec( Result ); - if (DWORD( Result ) < DWORD( Str )) then - Result := nil; -end; -{$ENDIF WIN} -{$ENDIF _FPC} -{$ENDIF _D2} - -{$IFDEF WIN} -function AnsiCompareStr(const S1, S2: KOLString): Integer; -begin - Result := CompareString(LOCALE_USER_DEFAULT, 0, PKOLChar(S1), -1, PKOLChar(S2), -1 ) - 2; -end; -{$ENDIF WIN} - -{$IFDEF WIN} -function AnsiCompareStrA(const S1, S2: AnsiString): Integer; -begin - Result := CompareStringA(LOCALE_USER_DEFAULT, 0, PAnsiChar(S1), -1, PAnsiChar(S2), -1 ) - 2; -end; -{$ENDIF WIN} - -{$IFDEF WIN} -function _AnsiCompareStr(S1, S2: PKOLChar): Integer; -begin - Result := CompareString( LOCALE_USER_DEFAULT, 0, S1, -1, - S2, -1) - 2; -end; -{$ENDIF WIN} - -type - TSortAnsiRec = record - A: array[ AnsiChar ] of PAnsiChar; - end; - PSortAnsiRec = ^TSortAnsiRec; -var SortAnsiOrderNoCase: array[ AnsiChar ] of SmallInt; - SortAnsiOrder: array[ AnsiChar ] of SmallInt; - -{$IFDEF WIN} -function _AnsiCompareStrA_Slow(S1, S2: PAnsiChar): Integer; -begin - Result := CompareStringA( LOCALE_USER_DEFAULT, 0, S1, -1, - S2, -1) - 2; -end; -{$ENDIF WIN} - -function CompareAnsiRec( R: PSortAnsiRec; const e1, e2: Integer ): Integer; -begin - Result := _AnsiCompareStrA_Slow( - R.A[AnsiChar(e1)], - R.A[AnsiChar(e2)] - ); -end; - -procedure SwapAnsiRec( R: PSortAnsiRec; const e1, e2: Integer ); -{$IFDEF PAS_ONLY} -var a: PAnsiChar; -{$ENDIF} -begin - {$IFDEF PAS_ONLY} - a := R.A[AnsiChar(e1)]; - R.A[AnsiChar(e1)] := R.A[AnsiChar(e2)]; - R.A[AnsiChar(e2)] := a; - {$ELSE} - Swap( Integer( R.A[AnsiChar(e1)] ), - Integer( R.A[AnsiChar(e2)] ) ); - {$ENDIF} -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function _AnsiCompareStrA_Fast2(S1, S2: PAnsiChar): Integer; -begin - if S1 = nil then - S1 := ''; - if S2 = nil then - S2 := ''; - Result := 0; - while TRUE do - begin - Result := SortAnsiOrder[ S1^ ] - SortAnsiOrder[ S2^ ]; - if Result <> 0 then break; - if (S1^ = #0) or (S2^ = #0) then break; - inc( S1 ); - inc( S2 ); - end; -end; -{$ENDIF PAS_VERSION} - -function _AnsiCompareStrA_Fast(S1, S2: PAnsiChar): Integer; -var c: AnsiChar; - R: TSortAnsiRec; - Buf: array[ 0..511 ] of AnsiChar; - P: PAnsiChar; -begin - P := @Buf[0]; - for c := Low(c) to High(c) do - begin - P^ := c; - R.A[c] := P; - inc( P ); - P^ := #0; - inc( P ); - end; - SortData( @R, 256, @CompareAnsiRec, @SwapAnsiRec ); - for c := Low(c) to High(c) do - SortAnsiOrder[AnsiChar(R.A[c][0])] := Ord(c); - _AnsiCompareStrA := _AnsiCompareStrA_Fast2; - Result := _AnsiCompareStrA_Fast2( S1, S2 ); -end; - -{$IFDEF WIN} -function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer; -begin - Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PKOLChar(S1), -1, - PKOLChar(S2), -1 ) - 2; -end; -{$ENDIF WIN} - -{$IFDEF WIN} -function AnsiCompareStrNoCaseA(const S1, S2: AnsiString): Integer; -begin - Result := CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PAnsiChar(S1), -1, - PAnsiChar(S2), -1 ) - 2; -end; -{$ENDIF WIN} - -{$IFDEF WIN} -function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer; -begin - Result := CompareString( LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1, - S2, -1) - 2; -end; -{$ENDIF WIN} - -{$IFDEF WIN} -function _AnsiCompareStrNoCaseA_Slow(S1, S2: PAnsiChar): Integer; -begin - Result := CompareStringA( LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1, - S2, -1) - 2; -end; -{$ENDIF WIN} - -function CompareAnsiRecNoCase( R: PSortAnsiRec; const e1, e2: Integer ): Integer; -begin - Result := _AnsiCompareStrNoCaseA_Slow( - R.A[AnsiChar(e1)] + 1, - R.A[AnsiChar(e2)] + 1 - ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -//{$DEFINE DEBUG_SORTFAST} -{$IFDEF DEBUG_SORTFAST} -var DBSF: Integer; -{$ENDIF} -function _AnsiCompareStrNoCaseA_Fast2(S1, S2: PAnsiChar): Integer; -{$IFDEF DEBUG_SORTFAST} -var S01, S02: PChar; -{$ENDIF} -begin - if S1 = nil then - S1 := ''; - if S2 = nil then - S2 := ''; - {$IFDEF DEBUG_SORTFAST} - S01 := S1; - S02 := S2; - {$ENDIF} - Result := 0; - while TRUE do - begin - Result := SortAnsiOrderNoCase[ S1^ ] - SortAnsiOrderNoCase[ S2^ ]; - if Result <> 0 then break; - if (S1^ = #0) or (S2^ = #0) then break; - inc( S1 ); - inc( S2 ); - end; - {$IFDEF DEBUG_SORTFAST} - inc( DBSF ); - if Result < 0 then - LogFileOutput( GetStartDir + 'LT.txt', Int2Str( DBSF ) + ': ' + - '"' + S01 + '" < "' + S02 + '"' ) - else if Result > 0 then - LogFileOutput( GetStartDir + 'GT.txt', Int2Str( DBSF ) + ': ' + - '"' + S01 + '" > "' + S02 + '"' ) - else LogFileOutput( GetStartDir + 'EQ.txt', Int2Str( DBSF ) + ': ' + - '"' + S01 + '" = "' + S02 + '"' ) - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -function _AnsiCompareStrNoCaseA_Fast(S1, S2: PAnsiChar): Integer; -var c: AnsiChar; - R: TSortAnsiRec; - Buf: array[ 0..767 ] of AnsiChar; - P: PAnsiChar; - {$IFDEF PAS_ONLY} - a: PAnsiChar; - {$ENDIF} -begin - P := @Buf[0]; - for c := Low(c) to High(c) do - begin - R.A[c] := P; - P^ := c; - inc( P ); - P^ := AnsiLowerCase( c )[1]; - inc( P ); - P^ := #0; - inc( P ); - //R.X[c] := Ord(c); - end; - SortData( @R, 256, @CompareAnsiRecNoCase, @SwapAnsiRec ); - for c := Succ(Low(c)) to High(c) do - begin - //R.X[c] := Byte(c); - if _AnsiCompareStrNoCaseA_Slow( R.A[Pred(c)] + 1, R.A[c] + 1 ) = 0 then - begin - if _AnsiCompareStrA( R.A[Pred(c)], R.A[c] ) < 0 then - begin - {$IFDEF PAS_ONLY} - a := R.A[Pred(c)]; - R.A[Pred(c)] := R.A[c]; - R.A[c] := a; - {$ELSE} - Swap( Integer( R.A[Pred(c)] ), Integer( R.A[c] ) ); - {$ENDIF} - end; - end; - // R.X[c] := R.X[Pred(c)]; - end; - for c := Low(c) to High(c) do - SortAnsiOrderNoCase[AnsiChar(R.A[c][0])] := Ord( R.A[c][1] ); // Ord(c); // R.X[c]; - _AnsiCompareStrNoCaseA := _AnsiCompareStrNoCaseA_Fast2; - Result := _AnsiCompareStrNoCaseA_Fast2( S1, S2 ); -end; - -function AnsiCompareText( const S1, S2: KOLString ): Integer; -begin - Result := AnsiCompareStrNoCase( S1, S2 ); -end; - -function AnsiCompareTextA( const S1, S2: AnsiString ): Integer; -begin - Result := AnsiCompareStrNoCaseA( S1, S2 ); -end; - -{$IFDEF PAS_ONLY} -function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; -var Src: PAnsiChar; -begin - Src := Source; - while MaxLen > 0 do - begin - Dest^ := Src^; - if Src^ = #0 then break; - inc(Dest); - inc(Src); - dec(MaxLen); - end; - Result := Dest; -end; -{$ELSE} -function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; assembler; -asm - {$IFDEF F_P} - MOV EAX, [Dest] - MOV EDX, [Source] - MOV ECX, [MaxLen] - {$ENDIF F_P} - PUSH EDI - PUSH ESI - PUSH EBX - MOV ESI,EAX - MOV EDI,EDX - MOV EBX,ECX - XOR AL,AL - TEST ECX,ECX - JZ @@1 - REPNE SCASB - JNE @@1 - INC ECX -@@1: SUB EBX,ECX - MOV EDI,ESI - MOV ESI,EDX - MOV EDX,EDI - MOV ECX,EBX - SHR ECX,2 - REP MOVSD - MOV ECX,EBX - AND ECX,3 - REP MOVSB - STOSB - MOV EAX,EDX - POP EBX - POP ESI - POP EDI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function StrPCopy(Dest: PAnsiChar; const Source: Ansistring): PAnsiChar; -begin - Result := StrLCopy(Dest, PAnsiChar(Source), Length(Source)); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function StrEq( const S1, S2 : AnsiString ) : Boolean; -begin - Result := (Length( S1 ) = Length( S2 )) and - (LowerCase( S1 ) = LowerCase( S2 )); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function AnsiEq( const S1, S2 : KOLString ) : Boolean; -begin - Result := AnsiCompareStrNoCase( S1, S2 ) = 0; -end; -{$ENDIF PAS_VERSION} - -{$IFNDEF _D2} -{$IFNDEF _FPC} -function WAnsiEq( const S1, S2 : KOLWideString ) : Boolean; -begin - Result := WAnsiLowerCase( S1 )=WAnsiLowerCase( S2 ); -end; -{$ENDIF _FPC} -{$ENDIF _D2} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function StrIn(const S: AnsiString; const A: array of AnsiString): Boolean; -var I : Integer; -begin - for I := Low( A ) to High( A ) do - if StrEq( S, A[ I ] ) then - begin - Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := False; -end; -{$ENDIF PAS_VERSION} - -{$IFNDEF _D2} -{$IFNDEF _FPC} -function WStrIn( const S : KOLWideString; const A : array of KOLWideString ) : Boolean; -var I : Integer; -begin - for I := Low( A ) to High( A ) do - if WAnsiEq( S, A[ I ] ) then - begin - Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := False; -end; -{$ENDIF _FPC} -{$ENDIF _D2} - -function CharIn( C: KOLChar; const A: TSetofChar ): Boolean; -begin - Result := (DWord( C ) <= 255) and (AnsiChar( C ) in A); -end; - -function StrIs( const S : AnsiString; const A : Array of AnsiString; var Idx: Integer ) : Boolean; -var I : Integer; -begin - Idx := -1; - for I := Low( A ) to High( A ) do - if StrEq( S, A[ I ] ) then - begin - Idx := I; - Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := False; -end; - -function IntIn( Value: Integer; const List: array of Integer ): Boolean; -var I: Integer; -begin - Result := FALSE; - for I := 0 to High( List ) do - begin - if Value = List[ I ] then - begin - Result := TRUE; - break; - end; - end; -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function _StrSatisfy( S, Mask : PKOLChar ) : Boolean; -label next_char; -begin -next_char: - Result := True; - if (S^ = #0) and (Mask^ = #0) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (Mask^ = '*') and (Mask[1] = #0) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if S^ = #0 then - begin - while Mask^ = '*' do - Inc( Mask ); - Result := Mask^ = #0; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := False; - if Mask^ = #0 then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Mask^ = '?' then - begin - Inc( S ); Inc( Mask ); goto next_char; - end; - if Mask^ = '*' then - begin - Inc( Mask ); - while S^ <> #0 do - begin - Result := _StrSatisfy( S, Mask ); - if Result then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Inc( S ); - end; - exit; // (Result = False) {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := S^ = Mask^; - Inc( S ); Inc( Mask ); - if Result then goto next_char; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function StrSatisfy( const S, Mask: KOLString ): Boolean; -begin - Result := FALSE; - if (S = '') or (Mask = '') then Exit; - Result := _StrSatisfy( PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase - {$ELSE} AnsiLowerCase {$ENDIF} ( S ) ), - PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase - {$ELSE} AnsiLowerCase {$ENDIF} ( Mask ) ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} // Pascal -function _2StrSatisfy( S, Mask: PKOLChar ): Boolean; -begin - Result := StrSatisfy( S, Mask ); -end; -{$ENDIF PAS_VERSION} - -function StrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean; -var I: Integer; -begin - I := pos( From, S ); - if I > 0 then - begin - S := Copy( S, 1, I - 1 ) + ReplTo + CopyEnd( S, I + Length( From ) ); - Result := TRUE; - end else Result := FALSE; -end; - -function KOLStrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean; -var I: Integer; -begin - I := pos( From, S ); - if I > 0 then - begin - S := Copy( S, 1, I - 1 ) + ReplTo + CopyEnd( S, I + Length( From ) ); - Result := TRUE; - end else Result := FALSE; -end; - -{$IFDEF _FPC} -procedure SetLengthW( var W: KOLWideString; NewLength: Integer ); -begin - while Length( W ) < NewLength do - W := W + ' ' + W; - if Length( W ) > NewLength then - Delete( W, NewLength + 1, Length( W ) - NewLength ); -end; - -function CopyW( const W: KOLWideString; From, Count: Integer ): KOLWideString; -begin - Result := ''; - if Count <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SetLengthW( Result, Count ); - Move( W[ From ], Result[ 1 ], Count * Sizeof( WideChar ) ); -end; - -function posW( const S1, S2: AnsiString ): Integer; // not used. When use, change AnsiString to WideString ? -var I, L1: Integer; -begin - L1 := Length( S1 ); - for I := 1 to Length( S2 )-L1+1 do - begin - if Copy( S2, I, L1 ) = S1 then - begin - Result := I; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := 0; -end; -{$ENDIF _FPC} - -{$IFDEF ASM_VERSION} - procedure DoMove(const from; var to_; count: Integer); - asm - PUSH ESI - PUSH EDI - XCHG ESI, EAX - MOV EDI, EDX - REP MOVSB - POP EDI - POP ESI - end; -{$ENDIF} - -{$IFNDEF _FPC} -{$IFNDEF _D2} -function WStrReplace( var S: KOLWideString; const From, ReplTo: KOLWideString ): Boolean; -var I: Integer; -begin - I := pos( From, S ); - if I > 0 then - begin - S := Copy( S, 1, I - 1 ) + ReplTo + Copy( S, I + Length( From ), MaxInt ); - Result := TRUE; - end else Result := FALSE; -end; - -function WStrRepeat( const S: KOLWideString; Count: Integer ): KOLWideString; -var {$IFDEF ASM_VERSION} {$ELSE} I, {$ENDIF} L: Integer; -begin - L := Length( S ); - SetLength( Result, L * Count ); - if L = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF ASM_VERSION} - Move( S[1], Result[1], L * Sizeof(WideChar) ); - if Count > 1 then - DoMove( Result[1], Result[1+L], (Count-1)*L*Sizeof(WideChar) ); - {$ELSE} - for I := 0 to Count-1 do - Move( S[ 1 ], Result[ 1 + I * L ], L * Sizeof( WideChar ) ); - {$ENDIF PAS_VERSION} -end; -{$ENDIF _D2} -{$ENDIF _FPC} - -{$IFDEF ASM_VERSION} - {$IFDEF UNICODE_CTRLS} - function StrRepeat( const S: KOLString; Count: Integer ): KOLString; - var L: Integer; - begin - Result := ''; - L := Length(S); - if L = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SetLength( Result, Count * Length( S ) ); - Move( S[1], Result[1], Length(S)*Sizeof(KOLChar) ); - if Count > 1 then - DoMove( Result[1], Result[1+Length(S)], - (Length(Result)-Length(S))*Sizeof(KOLChar) ); - end; - {$ELSE notUNICODE} -function StrRepeat( const S: KOLString; Count: Integer ): KOLString; -asm - PUSH EBX - PUSH ESI - PUSH EDI - MOV EBX, ECX - MOV EDI, EDX - XCHG ESI, EAX - - MOV EAX, ECX - CALL System.@LStrClr - TEST ESI, ESI - JZ @@exit - MOV EDX, [ESI-4] - imul edx, EDI - PUSH EDX - MOV EAX, EBX - CALL System.@LStrSetLength - PUSH ESI - PUSH EDI - MOV ECX, [ESI-4] - MOV EDI, [EBX] - REP MOVSB - POP EAX - POP ESI - DEC EAX - POP ECX - JLE @@exit - SUB ECX, [ESI-4] - MOV ESI, [EBX] - REP MOVSB -@@exit: - POP EDI - POP ESI - XCHG EAX, EBX - POP EBX -end; -{$ENDIF notUNICODE_CTRLS} -{$ELSE ASM_VERSION} -function StrRepeat( const S: KOLString; Count: Integer ): KOLString; -var I, L: Integer; -begin - L := Length( S ); - SetLength( Result, L * Count ); - for I := 0 to Count-1 do - Move( S[ 1 ], Result[ 1 + I * L * Sizeof(KOLChar) ], L ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_noVERSION} -{$ELSE PAS_VERSION} //Pascal -procedure NormalizeUnixText( var S: AnsiString ); -var I, J, N: Integer; -begin - if S <> '' then - begin - N := 0; - if S[ 1 ] = #10 then - begin - S[ 1 ] := #0; - inc( N ); - end; - for I := Length(S) downto 2 do - begin - if (S[I]=#10) and (S[I-1]<>#13) then - S[I] := #0; - if S[I] = #0 then inc( N ); - end; - if N > 0 then - begin - SetLength( S, N+Length(S) ); - J := Length(S); - for I := Length(S)-N downto 1 do - begin - if S[I] = #0 then - begin - S[J] := #10; - S[J-1] := #13; - dec( J ); - end else S[J] := S[I]; - dec(J); - end; - end; - end; -end; -{$ENDIF PAS_VERSION} - -var Koi8_to_Ansi: array[ Char ] of AnsiChar; -procedure Koi8ToAnsi( s: PAnsiChar ); -var c: AnsiChar; -begin - if Koi8_to_Ansi[ #1 ] = #0 then - begin - for c := #1 to #255 do - begin - Koi8_to_Ansi[ c ] := c; - if (c >= #$C0) and (c <= #$FF) then - Koi8_to_Ansi[ c ] := KOI8_Rus[ c ]; - end; - end; - while s^ <> #0 do - begin - s^ := Koi8_to_Ansi[ s^ ]; - inc( s ); - end; -end; - -{$IFDEF PAS_ONLY} -function StrComp(const Str1, Str2: PAnsiChar): Integer; -var S1, S2: PAnsiChar; -begin - S1 := Str1; - S2 := Str2; - while (S1^ <> #0) and (S2^ <> #0) do - begin - Result := Integer(Ord(S1^)) - Integer(Ord(S2^)); - if Result <> 0 then Exit; - inc(S1); - inc(S2); - end; - Result := 0; -end; -{$ELSE} -function StrComp(const Str1, Str2: PAnsiChar): Integer; assembler; -asm - {$IFDEF F_P} - MOV EAX, [Str1] - MOV EDX, [Str2] - {$ENDIF F_P} - PUSH EDI - PUSH ESI - MOV EDI,EDX - XCHG ESI,EAX - OR ECX, -1 - XOR EAX,EAX - REPNE SCASB - NOT ECX - MOV EDI,EDX - XOR EDX,EDX - REPE CMPSB - MOV AL,[ESI-1] - MOV DL,[EDI-1] - SUB EAX,EDX - POP ESI - POP EDI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF PAS_ONLY} - -var Upper: array[ AnsiChar ] of AnsiChar; - Upper_initialized: Boolean; - -procedure Init_Upper; -var c: AnsiChar; - s: AnsiString; -begin - if not Upper_initialized then - begin - for c := Low(c) to High(c) do - begin - s := c + AnsiChar( ' ' ); - Upper[c] := AnsiUpperCase( s )[1]; - end; - Upper_initialized := TRUE; - end; -end; - -{$IFDEF PAS_ONLY} -function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -var S1, S2: PAnsiChar; - c1, c2: AnsiChar; -begin - S1 := Str1; - S2 := Str2; - while (S1^ <> #0) and (S2^ <> #0) and (MaxLen > 0) do - begin - c1 := S1^; - c2 := S2^; - Result := Integer(c1) - Integer(c2); - if Result <> 0 then Exit; - inc(S1); - inc(S2); - dec(MaxLen); - end; - Result := 0; -end; - -function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -var S1, S2: PAnsiChar; - c1, c2: AnsiChar; -begin - S1 := Str1; - S2 := Str2; - while (S1^ <> #0) and (S2^ <> #0) and (MaxLen > 0) do - begin - c1 := S1^; - if (c1 >= 'a') and (c1 <= 'z') then - c1 := AnsiChar(Ord(c1)-32); - c2 := S2^; - if (c2 >= 'a') and (c2 <= 'z') then - c2 := AnsiChar(Ord(c2)-32); - Result := Integer(c1) - Integer(c2); - if Result <> 0 then Exit; - inc(S1); - inc(S2); - dec(MaxLen); - end; - Result := 0; -end; - -function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; -var S1, S2: PAnsiChar; - c1, c2: AnsiChar; -begin - S1 := Str1; - S2 := Str2; - while (S1^ <> #0) and (S2^ <> #0) do - begin - c1 := S1^; - if (c1 >= 'a') and (c1 <= 'z') then - c1 := AnsiChar(Ord(c1)-32); - c2 := S2^; - if (c2 >= 'a') and (c2 <= 'z') then - c2 := AnsiChar(Ord(c2)-32); - Result := Integer(c1) - Integer(c2); - if Result <> 0 then Exit; - inc(S1); - inc(S2); - end; - Result := 0; -end; -{$ELSE} - -{$IFDEF SMALLER_CODE} -function StrComp_NoCase(const Str1, Str2: PAnsiChar): Integer; -asm - {$IFDEF F_P} - MOV EAX, [Str1] - MOV EDX, [Str2] - {$ENDIF F_P} - PUSH EDI - PUSH ESI - MOV EDI,EDX - XCHG ESI,EAX - OR ECX, -1 - XOR EAX,EAX - REPNE SCASB - - NOT ECX - MOV EDI,EDX - @@0: - XOR EDX,EDX - REPE CMPSB - MOV AL,[ESI-1] - MOV AH, AL - SUB AH, 'a' - CMP AH, 25 - JA @@1 - SUB AL, $20 - @@1: - MOV DL,[EDI-1] - MOV AH, DL - SUB AH, 'a' - CMP AH, 25 - JA @@2 - SUB DL, $20 - @@2: - MOV AH, 0 - SUB EAX,EDX - JNZ @@exit - CMP DL, 0 - JNZ @@0 - - @@exit: - POP ESI - POP EDI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; - -function StrLComp_NoCase(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -asm - {$IFDEF F_P} - MOV EAX, [Str1] - MOV EDX, [Str2] - MOV ECX, [MaxLen] - {$ENDIF F_P} - PUSH EDI - PUSH ESI - PUSH EBX - MOV EDI,EDX - MOV ESI,EAX - MOV EBX,ECX - XOR EAX,EAX - OR ECX,ECX - JE @@exit - REPNE SCASB - SUB EBX,ECX - MOV ECX,EBX - MOV EDI,EDX - @@0: - XOR EDX,EDX - REPE CMPSB - MOV AL,[ESI-1] - MOV AH, AL - SUB AH, 'a' - CMP AH, 25 - JA @@1 - SUB AL, $20 - @@1: - MOV DL,[EDI-1] - MOV AH, DL - SUB AH, 'a' - CMP AH, 25 - JA @@2 - SUB DL, $20 - @@2: - MOV AH, 0 - SUB EAX,EDX - JECXZ @@exit - JZ @@0 - - @@exit: - POP EBX - POP ESI - POP EDI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ELSE not SMALLER_CODE} -function StrComp_NoCase2(const Str1, Str2: PAnsiChar): Integer; -asm - {$IFDEF F_P} - MOV EAX, [Str1] - MOV EDX, [Str2] - {$ENDIF F_P} - PUSH ESI - XCHG ESI, EAX - @@1: - MOVZX EAX, BYTE PTR [EDX] - INC EDX - MOV CL, BYTE PTR [EAX+Upper] - LODSB - SUB CL, BYTE PTR [EAX+Upper] - JNZ @@fin - CMP AL, CL - JNZ @@1 - @@fin:MOVSX EAX, CL - NEG EAX - POP ESI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; - -function StrComp_NoCase1(const Str1, Str2: PAnsiChar): Integer; -begin - Init_Upper; - StrComp_NoCase := @StrComp_NoCase2; - Result := StrComp_NoCase2( Str1, Str2 ); -end; - -function StrLComp_NoCase2(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -asm - {$IFDEF F_P} - MOV EAX, [Str1] - MOV EDX, [Str2] - MOV ECX, [MaxLen] - {$ENDIF F_P} - PUSH EDI - PUSH ESI - PUSH EBX - MOV EDI,EDX - XCHG ESI,EAX - XOR EBX, EBX - JECXZ @@fin - @@1: MOVZX EAX, BYTE PTR [EDI] - INC EDI - MOV BL, BYTE PTR [EAX+Upper] - LODSB - SUB BL, BYTE PTR [EAX+Upper] - JNZ @@fin - TEST EAX, EAX - JZ @@fin - LOOP @@1 - @@fin:MOVSX EAX, BL - POP EBX - POP ESI - POP EDI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; - -function StrLComp_NoCase1(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; -begin - Init_Upper; - StrComp_NoCase := @StrComp_NoCase2; - Result := StrLComp_NoCase2( Str1, Str2, MaxLen ); -end; -{$ENDIF} - -function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; assembler; -asm - {$IFDEF F_P} - MOV EAX, [Str1] - MOV EDX, [Str2] - MOV ECX, [MaxLen] - {$ENDIF F_P} - PUSH EDI - PUSH ESI - PUSH EBX - MOV EDI,EDX - MOV ESI,EAX - MOV EBX,ECX - XOR EAX,EAX - OR ECX,ECX - JE @@1 - REPNE SCASB - SUB EBX,ECX - MOV ECX,EBX - MOV EDI,EDX - XOR EDX,EDX - REPE CMPSB - MOV AL,[ESI-1] - MOV DL,[EDI-1] - SUB EAX,EDX -@@1: POP EBX - POP ESI - POP EDI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF PAS_ONLY} - -function StrLen(const Str: PAnsiChar): Cardinal; assembler; -asm - {$IFDEF F_P} - MOV EAX, [Str] - {$ENDIF F_P} - XCHG EAX, EDI - XCHG EDX, EAX - OR ECX, -1 - XOR EAX, EAX - CMP EAX, EDI - JE @@exit0 - REPNE SCASB - DEC EAX - DEC EAX - SUB EAX,ECX -@@exit0: - MOV EDI,EDX -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; - -{$IFDEF ASM_UNICODE} -{$ELSE PAS_VERSION} //Pascal -function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar; -var - P, F : PKOLChar; -begin - P := Str; - Result := P + {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( Str ); - while Delimiters^ <> #0 do - begin - F := {$IFDEF UNICODE_CTRLS} WStrRScan {$ELSE} StrRScan {$ENDIF} - ( P, Delimiters^ ); - if F <> nil then - if (Result^ = #0) or (Integer(F) > Integer(Result)) then - Result := F; - Inc( Delimiters ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF _D3orHigher} -function W__DelimiterLast( Str, Delimiters: PWideChar ): PWideChar; -var - P, F : PWideChar; -begin - P := Str; - Result := P + WStrLen( Str ); - while Delimiters^ <> #0 do - begin - F := WStrRScan( P, Delimiters^ ); - if F <> nil then - if (Result^ = #0) or (Integer(F) > Integer(Result)) then - Result := F; - Inc( Delimiters ); - end; -end; -{$ENDIF _D3orHigher} - -{$IFDEF WIN} -{$IFNDEF PARAMS_DEFAULT} -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -function SkipSpaces( P: PKOLChar ): PKOLChar; -begin - while (P[0] <> #0) and (P[0] <= ' ') do Inc(P); - Result := P; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE} -function SkipParam(P: PKOLChar): PKOLChar; -begin - P := SkipSpaces( P ); - while P[0] > ' ' do - if P[0] = '"' then - begin - Inc(P); - while (P[0] <> #0) and (P[0] <> '"') do - Inc(P); - if P[0] <> #0 then Inc(P); - end else Inc(P); - Result := P; -end; -{$ENDIF} - -{$UNDEF ASM_LOCAL} -{$IFDEF _D3orHigher} -{$IFDEF ASM_UNICODE} - {$DEFINE ASM_LOCAL} -{$ENDIF ASM_UNICODE} -{$ENDIF _D3orHigher} - -{$IFDEF ASM_LOCAL} -function ParamStr( Idx: Integer ): KOLString; -asm - PUSH EDI - MOV EDI, EDX - TEST EAX, EAX - JNE @@1 - SUB ESP, 260 - MOV ECX, ESP - PUSH 260 - PUSH ECX - PUSH 0 - CALL GetModuleFileName - XCHG ECX, EAX - MOV EDX, ESP - MOV EAX, EDI - CALL System.@LStrFromPCharLen - ADD ESP, 260 - JMP @@exit -@@1: - PUSH EAX - CALL GetCommandLine - POP ECX - INC ECX -@@loop: CALL SkipSpaces - MOV EDX, EAX - CALL SkipParam - LOOP @@loop - MOV ECX, EAX - SUB ECX, EDX - CMP ECX, 2 - JL @@ready - CMP byte ptr [EDX], '"' - JNE @@ready - CMP byte ptr [EAX-1], '"' - JNE @@ready - INC EDX - DEC EAX -@@ready: SUB EAX, EDX - XCHG ECX, EAX - XCHG EAX, EDI - CALL System.@LStrFromPCharLen -@@exit: POP EDI -end; -{$ELSE PAS_VERSION} -function ParamStr( Idx: Integer ): KOLString; -var P, P1: PKOLChar; - Buffer: array[ 0..260 ] of KOLChar; -begin - if Idx = 0 then - SetString( Result, Buffer, GetModuleFileName( 0, Buffer, Sizeof( Buffer ) ) ) - else - begin - P := GetCommandLine; - repeat - P1 := SkipSpaces( P ); - P := SkipParam(P1); - Dec(Idx); - until (Idx < 0); // or (P = P1); - if Integer(P-P1) >= 2 then - if (P1^ = '"') and ( (P-1)^ = '"') then - begin - inc( P1 ); - dec( P ); - end; - SetString( Result, P1, P-P1 ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -function ParamCount: Integer; -var p: PKOLChar; -begin - p := GetCommandLine; - Result := -1; - while p^ <> #0 do - begin - inc( Result ); - p := SkipParam( p ); - p := SkipSpaces( p ); - end; -end; -{$ENDIF PAS_VERSION} -{$ENDIF PARAMS_DEFAULT} -{$ENDIF WIN} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function DelimiterLast( const Str, Delimiters: KOLString ): Integer; -var PStr: PKOLChar; -begin - PStr := PKOLChar( Str ); - Result := Integer( __DelimiterLast( PStr, PKOLChar( Delimiters ) ) ) - - Integer( PStr ) - + {$IFDEF UNICODE_CTRLS} 2 {$ELSE} 1 {$ENDIF}; // {Viman} - {$IFDEF UNICODE_CTRLS} Result := Result div SizeOf( WideChar ) {$ENDIF}; -end; -{$ENDIF PAS_VERSION} - -// Thanks to Marco Bobba - Marisa Bo for this code -{$IFDEF ASM_UNICODE}{$ELSE} -function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean; -begin - Result := FALSE; - if (Str = nil) or (Pattern = nil) then - begin - Result := (Integer(Str) = Integer(Pattern)); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - - while Pattern^ <> #0 do - begin - if Str^ <> Pattern^ then Exit; - inc( Str ); - inc( Pattern ); - end; - Result := TRUE; -end; -{$ENDIF ASM_UNICODE} - -{$IFDEF PAS_ONLY} -function StrIsStartingFromNoCase( Str, Pattern: PAnsiChar ): Boolean; -begin - Result := FALSE; - while (Str^ <> #0) and (Pattern^ <> #0) do - begin - if Str^ <> Pattern^ then Exit; - inc(Str^); - inc(Pattern^); - end; - Result := Pattern^ = #0; -end; -{$ELSE} -function StrIsStartingFromNoCase( Str, Pattern: PAnsiChar ): Boolean; -asm - {$IFDEF F_P} - MOV EAX, [Str] - MOV EDX, [Pattern] - {$ENDIF F_P} - XOR ECX, ECX - @@1: - MOV CL, [EDX] // pattern[ i ] - INC EDX - MOV CH, [EAX] // str[ i ] - INC EAX - JECXZ @@2 // str = pattern; CL = #0, CH = #0 - CMP CL, 'a' - JB @@cl_ok - CMP CL, 'z' - JA @@cl_ok - SUB CL, 32 - @@cl_ok: - CMP CH, 'a' - JB @@ch_ok - CMP CH, 'z' - JA @@ch_ok - SUB CH, 32 - @@ch_ok: - CMP CL, CH - JE @@1 - @@2: - TEST CL, CL - SETZ AL -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF PAS_ONLY} - - -{$IFNDEF _FPC} - -{$IFDEF WIN} -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function Format( const fmt: KOLString; params: Array of const ): KOLString; -var Buffer: array[ 0..1023 ] of KOLChar; - ElsArray, El: PDWORD; - I : Integer; - P : PDWORD; -begin - ElsArray := nil; - if High( params ) >= 0 then - GetMem( ElsArray, (High( params ) + 1) * sizeof( Pointer ) ); - El := ElsArray; - for I := 0 to High( params ) do - begin - P := @params[ I ]; - P := Pointer( P^ ); - El^ := DWORD( P ); - Inc( El ); - end; - wvsprintf( PKOLChar(@Buffer[0]), PKOLChar( fmt ), Pointer( ElsArray ) ); - Result := Buffer; - if ElsArray <> nil then - FreeMem( ElsArray ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -function LStrFromPWCharLen(Source: PWideChar; Length: Integer): AnsiString; -var - DestLen: Integer; - Buffer: array[0..2047] of AnsiChar; -begin - if Length <= 0 then - begin - Result := ''; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if Length < SizeOf(Buffer) div 2 then - begin - DestLen := WideCharToMultiByte(0, 0, Source, Length, - Buffer, SizeOf(Buffer), nil, nil); - if DestLen > 0 then - begin - Result := Buffer; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil); - SetLength( Result, DestLen ); - WideCharToMultiByte(0, 0, Source, Length, Pointer(Result), DestLen, nil, nil); -end; - -{$IFDEF PAS_ONLY} -function LStrFromPWChar(Source: PWideChar): AnsiString; -begin - Result := AnsiString(WideString(Source)); -end; -{$ELSE} -function LStrFromPWChar(Source: PWideChar): AnsiString; -{* from Delphi5 - because D2 does not contain it. } -asm - PUSH EDX - XOR EDX,EDX - TEST EAX,EAX - JE @@5 - PUSH EAX -@@0: CMP DX,[EAX+0] - JE @@4 - CMP DX,[EAX+2] - JE @@3 - CMP DX,[EAX+4] - JE @@2 - CMP DX,[EAX+6] - JE @@1 - ADD EAX,8 - JMP @@0 -@@1: ADD EAX,2 -@@2: ADD EAX,2 -@@3: ADD EAX,2 -@@4: XCHG EDX,EAX - POP EAX - SUB EDX,EAX - SHR EDX,1 -@@5: POP ECX - JMP LStrFromPWCharLen -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF PAS_ONLY} - -{$ENDIF not_FPC} - -function WCharIn( C: KOLChar; const Chars: array of KOLChar ): Boolean; -var i: Integer; -begin - Result := TRUE; - for i := 0 to High( Chars ) do - if Chars[i] = C then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := FALSE; -end; - -///////////////////////////////////////////////////////////////////////// -// -// -// F I L E S -// -// -///////////////////////////////////////////////////////////////////////// -{ - This part of the unit modified by Tim Slusher and Vladimir Kladov. -} -{* Set of utility methods to work with files - and reqistry. - When programming KOL, which is Windows API-oriented, You should - avoid alien (for Windows) embedded Pascal files handling, and - use API-calls which implemented very well. This set of functions - is intended to make this easier. - Also TDirList object implementation present here and some registry - access functions, which allow to make code more elegant. -} - -{$UNDEF ASM_LOCAL} -{$IFDEF ASM_VERSION} - {$DEFINE ASM_LOCAL} -{$ENDIF PAS_VERSION} - -{$IFDEF WIN} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle; -var Attr: DWORD; -begin - Attr := (OpenFlags shr 16) and $1FFF; - if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL; - Result := CreateFile( PKOLChar(FileName), OpenFlags and $F0000000, - OpenFlags and $F, nil, (OpenFlags shr 8) and $F, - Attr, 0 ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -{$IFDEF _D3orHigher} -function WFileCreate(const FileName: KOLWideString; OpenFlags: DWord): THandle; -var Attr: DWORD; -begin - Attr := (OpenFlags shr 16) and $1FFF; - if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL; - Result := CreateFileW( PWideChar(FileName), OpenFlags and $F0000000, - OpenFlags and $F, nil, (OpenFlags shr 8) and $F, - Attr, 0 ); -end; -{$ENDIF _D3orHigher} - -{$IFDEF WIN} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function FileClose(Handle: THandle): Boolean; -begin - Result := CloseHandle(Handle); -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -{$IFDEF WIN} -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function FileExists( const FileName : KOLString ) : Boolean; -{$IFDEF FILE_EXISTS_EX} -var FD: TFindFileData; - LFT: TFileTime; - Hi, Lo: Word; - e: DWORD; -{$ELSE} -var Code: Integer; -{$ENDIF} -begin - {$IFDEF FILE_EXISTS_EX} - Result := FALSE; - e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS ); - if Find_First( Filename, FD ) then - begin - if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then - begin - FileTimeToLocalFileTime( FD.ftLastWriteTime, LFT ); - if FileTimeToDosDateTime( LFT, Hi, Lo ) then - Result := TRUE; - end; - Find_Close( FD ); - end; - SetErrorMode( e ); - {$ELSE} - Code := GetFileAttributes(PKOLChar(FileName)); - Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -{$IFDEF _D3orHigher} -function WFileExists( const FileName: KOLWideString ) : Boolean; -{$IFDEF notimplemented_FILE_EXISTS_EX} -var FD: TFindFileData; - //F: DWORD; - LFT: TFileTime; - Hi, Lo: Word; -{$ELSE} -var Code: Integer; -{$ENDIF} -begin - {$IFDEF notimplemented_FILE_EXISTS_EX} - Result := FALSE; - if not WFind_First( Filename, FD ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then Exit; {>>>>>>>>} - FileTimeToLocalFileTime( FD.ftLastWriteTime, LFT ); - if FileTimeToDosDateTime( LFT, Hi, Lo ) then Result := TRUE; - WFind_Close( FD ); - {$ELSE} - Code := GetFileAttributesW(PWideChar(FileName)); - Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0); - {$ENDIF} -end; -{$ENDIF _D3orHigher} - -{$IFDEF WIN} -{$IFDEF ASM_STREAM} -function FileSeek(Handle: THandle; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize; -asm - MOVZX ECX, CL - PUSH ECX - PUSH 0 - PUSH EDX - PUSH EAX - CALL SetFilePointer -end; -{$ELSE PAS_VERSION} //Pascal -function FileSeek(Handle: THandle; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize; -{$IFDEF STREAM_LARGE64} -var HiPtr: DWORD; -{$ENDIF} -begin - {$IFDEF STREAM_LARGE64} - HiPtr := MoveTo shr 32; - Result := SetFilePointer(Handle, DWORD( MoveTo ), @ HiPtr, Ord( MoveMethod ) ); - if (DWORD( Result ) = $FFFFFFFF {INVALID_SET_FILE_POINTER}) and - (GetLastError <> NO_ERROR) then - Result := -1; // Int64(-1) - if Result >= 0 then - Result := Result or (HiPtr shl 32); - {$ELSE} - Result := SetFilePointer(Handle, MoveTo, nil, Ord( MoveMethod ) ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -{$IFDEF WIN} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord; -begin - if not ReadFile(Handle, Buffer, Count, Result, nil) then - Result := 0; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function File2Str(Handle: THandle): AnsiString; -var Pos, Size: DWORD; -begin - Result := ''; - if Handle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Pos := FileSeek( Handle, 0, spCurrent ); - Size := GetFileSize( Handle, nil ); - SetString( Result, nil, Size - Pos + 1 ); - FileRead( Handle, Result[ 1 ], Size - Pos ); - Result[ Size - Pos + 1 ] := #0; -end; -{$ENDIF PAS_VERSION} - -{$IFNDEF _D2} -function File2WStr(Handle: THandle): KOLWideString; -var Pos, Size: DWORD; -begin - Result := ''; - if Handle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Pos := FileSeek( Handle, 0, spCurrent ); - Size := GetFileSize( Handle, nil ); - SetString( Result, nil, (Size - Pos + 1) div Sizeof( WideChar ) + 1 ); // fixed by zhoudi - FileRead( Handle, Result[ 1 ], Size - Pos ); - Result[ Length(Result) ] := #0; // fixed by zhoudi -end; -{$ENDIF _D2} - -{$IFDEF WIN} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord; -begin - if not WriteFile(Handle, Buffer, Count, Result, nil) then - Result := 0; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function FileEOF( Handle: THandle ) : Boolean; -var Siz, Pos : DWord; -begin - Siz := GetFileSize( Handle, nil ); - Pos := FileSeek( Handle, 0, spCurrent ); - Result := Pos >= Siz; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN} -{$IFDEF ASM_noVERSION_UNICODE} -function FileFullPath( const FileName: AnsiString ) : AnsiString; -const - BkSlash: AnsiString = '\'; - szTShFileInfo = sizeof( TShFileInfo ); -asm - PUSH EBX - PUSH ESI - MOV EBX, EDX - PUSH EAX - - XCHG EAX, EDX - CALL System.@LStrClr - - POP EDX - PUSH 0 - MOV EAX, ESP - CALL System.@LStrAsg - MOV ESI, ESP - -@@loo: CMP dword ptr [ESI], 0 - JZ @@fin - - MOV EAX, ESI - MOV EDX, [BkSlash] - PUSH 0 - MOV ECX, ESP - CALL Parse - - CMP dword ptr [EBX], 0 - JE @@1 - MOV EAX, EBX - MOV EDX, [BkSlash] - CALL System.@LStrCat - JMP @@2 -@@1: - POP EAX - PUSH EAX - CALL System.@LStrLen - CMP EAX, 2 - JNE @@2 - POP EAX - PUSH EAX - CMP byte ptr [EAX+1], ':' - JNE @@2 - - MOV EAX, EBX - POP EDX - PUSH EDX - CALL System.@LStrAsg - JMP @@3 -@@2: - PUSH 0 - MOV EAX, ESP - MOV EDX, [EBX] - CALL System.@LStrAsg - MOV EAX, ESP - MOV EDX, [ESP+4] - CALL System.@LStrCat - POP EAX - PUSH EAX - SUB ESP, szTShFileInfo - MOV EDX, ESP - PUSH SHGFI_DISPLAYNAME - PUSH szTShFileInfo - PUSH EDX - PUSH 0 - PUSH EAX - CALL ShGetFileInfo - LEA EDX, [ESP].TShFileInfo.szDisplayName - CMP byte ptr [EDX], 0 - JE @@clr_stk - LEA EAX, [ESP+szTShFileInfo+4] - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPChar -@@clr_stk: - ADD ESP, szTShFileInfo - CALL RemoveStr - POP EDX - PUSH EDX - MOV EAX, EBX - CALL System.@LStrCat - -@@3: CALL RemoveStr - JMP @@loo - -@@fin: CALL RemoveStr - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function FileFullPath( const FileName: KOLString ) : KOLString; -var SFI: TShFileInfo; - Src, S: KOLString; -begin - Result := ''; - Src := FileName; - while Src <> '' do - begin - S := Parse( Src, '\' ); - if Result <> '' then - Result := Result + '\'; - if (Result = '') and (Length( S ) = 2) and (S[ 2 ] = ':') then - Result := S - else - begin - {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF} - ( PKOLChar( Result + S ), 0, SFI, Sizeof( SFI ), SHGFI_DISPLAYNAME ); - if SFI.szDisplayName[ 0 ] <> #0 then - S := SFI.szDisplayName; - Result := Result + S; - end; - end; - if ExtractFileExt( Result ) = '' then - // case when flag 'Hide extensions for registered file types' is set on - // in the Explorer: - Result := Result + ExtractFileExt( FileName ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -{$IFDEF WIN} -function FileShortPath( const FileName: KOLString ): KOLString; -var Buf: array[ 0..MAX_PATH ] of KOLChar; -begin - GetShortPathName( PKOLChar( FileName ), Buf, Sizeof( Buf ) ); - Result := Buf; -end; - -function FileIconSystemIdx( const Path: KOLString ): Integer; -var SFI: TShFileInfo; -begin - SFI.iIcon := 0; // Bartov - {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF} - ( PKOLChar( Path ), 0, SFI, sizeof( SFI ), SHGFI_SMALLICON or SHGFI_SYSICONINDEX ); - Result := SFI.iIcon; -end; - -function FileIconSysIdxOffline( const Path: KOLString ): Integer; -var SFI: TShFileInfo; -begin - SFI.iIcon := 0; // Bartov - {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF} - ( PKOLChar( Path ), FILE_ATTRIBUTE_NORMAL, SFI, sizeof( SFI ), - SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES ); - Result := SFI.iIcon; -end; -{$ENDIF WIN} - -procedure LogFileOutput( const filepath, str: KOLString ); -var F: THandle; - Tmp: KOLString; -begin - F := FileCreate( filepath, ofOpenWrite or ofOpenAlways or ofShareDenyWrite ); - if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FileSeek( F, 0, spEnd ); - Tmp := str + {$IFDEF LIN} #10 {$ELSE} #13#10 {$ENDIF}; - FileWrite( F, PKOLChar( Tmp )^, Length( Tmp ) * Sizeof(KOLChar) ); - FileClose( F ); -end; - -function StrLoadFromFile( const Filename: KOLString ): AnsiString; -var F: THandle; -begin - {$IFDEF WIN} - if KOLLowerCase(Filename) = 'con' then - Result := File2Str(GetStdHandle(STD_INPUT_HANDLE)) - else - {$ENDIF WIN} - begin - Result := ''; - F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite ); - if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := File2Str( F ); - FileClose( F ); {Dark Knight} - end; -end; - -function Str2File( Filename: PKOLChar; Str: PAnsiChar ): Boolean; -var L: Integer; -begin - L := StrLen( Str ); - Result := Mem2File( Filename, Str, L ) = L; -end; - -function WStr2File( Filename: PKOLChar; Str: PWideChar ): Boolean; -var L: Integer; -begin - L := WStrLen( Str ); - Result := Mem2File( Filename, Str, L * Sizeof(WideChar) ) = L; -end; - -function StrSaveToFile( const Filename: KOLString; const Str: AnsiString ): Boolean; -begin - Result := Mem2File( PKOLChar( Filename ), PAnsiChar( Str ), Length( Str ) ) - = Length( Str ); -end; - -{$IFNDEF _D2} -function WStrLoadFromFile( const Filename: KOLString ): KOLWideString; -var F: THandle; -begin - {$IFDEF WIN} - //if StrEq( Filename, 'CON' ) then - if KOLLowerCase(Filename) = 'con' then - Result := File2WStr(GetStdHandle(STD_INPUT_HANDLE)) - else - {$ENDIF WIN} - begin - Result := ''; - F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite ); - if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := File2WStr( F ); - FileClose( F ); {Dark Knight} - end; -end; - -function WStrSaveToFile( const Filename: KOLString; const Str: KOLWideString ): Boolean; -var BytesToSave: Integer; -begin - BytesToSave := Length( Str ) * Sizeof(WideChar); - Result := Mem2File( PKOLChar( Filename ), PWideChar( Str ), BytesToSave ) - = BytesToSave; // fixed by zhoudi -end; -{$ENDIF _D2} - -function Mem2File( Filename: PKOLChar; Mem: Pointer; Len: Integer ): Integer; -var F: THandle; -begin - Result := 0; - F := //FileCreate( Filename, ofOpenWrite or ofCreateAlways ); - CreateFile( Filename, GENERIC_WRITE, 0, nil, CREATE_ALWAYS, 0, 0 ); - if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := FileWrite( F, Mem^, Len ); - CloseHandle( F ); -end; - -function File2Mem( Filename: PKOLChar; Mem: Pointer; MaxLen: Integer ): Integer; -var F: THandle; -begin - Result := 0; - F := //FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite ); - CreateFile( Filename, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0 ); - if F = INVALID_HANDLE_VALUE then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := FileRead( F, Mem^, MaxLen ); - CloseHandle( F ); -end; - -{$IFDEF WIN} -function Find_First( const FilePathName: KOLString; var F: TFindFileData ): Boolean; -begin - {$IFDEF UNICODE_CTRLS} - F.FindHandle := THandle( FindFirstFileExW( PKOLChar( FilePathName ), - FindExInfoStandard, PWin32FindDataW( @ F ), - FindExSearchNameMatch, nil, 0 ) ); - {$ELSE} - F.FindHandle := FindFirstFile( PKOLChar( FilePathName ), - PWin32FindData( @ F )^ ); - {$ENDIF} - Result := F.FindHandle <> INVALID_HANDLE_VALUE; -end; -function Find_Next( var F: TFindFileData ): Boolean; -begin - Result := FindNextFile( F.FindHandle, - {$IFDEF UNICODE_CTRLS} PWin32FindDataW {$ELSE} PWin32FindData {$ENDIF} - ( @ F )^ ); -end; -procedure Find_Close( var F: TFindFileData ); -begin - Windows.FindClose( F.FindHandle ); -end; -{$ENDIF WIN} - -{$IFDEF WIN} -function FileSize( const Path: KOLString ) : {$IFDEF _D2orD3} Integer {$ELSE} Int64 {$ENDIF}; -var FD : TFindFileData; -begin - Result := 0; - if not Find_First( Path, FD ) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF _D2orD3} - Result := FD.nFileSizeLow; - {$ELSE} - I64( Result ).Lo := FD.nFileSizeLow; - I64( Result ).Hi := FD.nFileSizeHigh; - {$ENDIF} - Find_Close( FD ); -end; -{$ENDIF WIN} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure FileTime( const Path: KOLString; - CreateTime, LastAccessTime, LastModifyTime: PFileTime ); stdcall; -var FD : TFindFileData; - procedure CopyTime( Dest, Src: PFileTime ); - begin - if Dest <> nil then - Dest^ := Src^; - end; -begin - if not Find_First( Path, FD ) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Find_Close( FD ); - CopyTime( CreateTime, @ FD.ftCreationTime ); - CopyTime( LastModifyTime, @ FD.ftLastWriteTime ); - CopyTime( LastAccessTime, @ FD.ftLastAccessTime ); -end; -{$ENDIF PAS_VERSION} - -function GetUniqueFilename( PathName: KOLString ) : KOLString; -var Path, Nam, Ext : KOLString; - I, J, K : Integer; -begin - Result := PathName; - Path := ExtractFilePath( PathName ); - if not DirectoryExists( Path ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Nam := ExtractFileNameWOext( PathName ); - if Nam = '' then - begin - Path := ExcludeTrailingPathDelimiter( Path ); - PathName := Path; - Result := Path; - end; - Nam := ExtractFileNameWOext( PathName ); - Ext := ExtractFileExt( PathName ); - I := Length( Nam ); - for J := I downto 1 do - if not ((Nam[ J ] >= '0') and (Nam[ J ] <= '9')) then - begin - I := J; - break; - end; - K := Str2Int( CopyEnd( Nam, I + 1 ) ); - while FileExists( Result ) do - begin - Inc( K ); - Result := Path + Copy( Nam, 1, I ) + Int2Str( K ) + Ext; - end; -end; - -{$IFDEF WIN} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function CompareSystemTime(const D1, D2 : TSystemTime) : Integer; -{$IFDEF DATE0_1601} -var ft1, ft2: TFileTime; -{$ELSE} -var R: Integer; - procedure CompareFields(const F1, F2 : Integer); - begin - if R <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if F1 = F2 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if F1 < F2 then - R := -1 - else R := 1; - end; -{$ENDIF DATE0_0001} -begin - {$IFDEF DATE0_1601} - SystemTimeToFileTime( D1, ft1 ); - SystemTimeToFileTime( D2, ft2 ); - Result := CompareFileTime( ft1, ft2 ); - {$ELSE} - R := 0; - CompareFields( D1.wYear, D2.wYear ); - CompareFields( D1.wMonth, D2.wMonth ); - CompareFields( D1.wDay, D2.wDay ); - CompareFields( D1.wHour, D2.wHour ); - CompareFields( D1.wMinute, D2.wMinute ); - CompareFields( D1.wSecond, D2.wSecond ); - CompareFields( D1.wMilliseconds, D2.wMilliseconds ); - Result := R; - {$ENDIF DATE0_0001} -end; -{$ENDIF PAS_VERSION} - -function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer; -begin - Result := CompareFileTime( FT1, FT2 ); -end; -{$ENDIF WIN} - -{$IFDEF WIN} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function DirectoryExists(const Name: KOLString): Boolean; -var - Code: Integer; - e: DWORD; -begin - e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS ); - Code := GetFileAttributes(PKOLChar(Name)); - Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); - SetErrorMode( e ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -function DiskPresent( const DrivePath: KOLString ): Boolean; -var e: DWORD; - restore: Boolean; -begin - e := 0; - Restore := FALSE; - //if Copy( DrivePath, 1, 2 ) <> '\\' then - if (DrivePath <> '') and (DrivePath[1] <> '\') then - CASE GetDriveType( PKOLChar( DrivePath ) ) OF - DRIVE_REMOVABLE, DRIVE_CDROM, DRIVE_RAMDISK: - begin - e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS ); - Restore := TRUE; - end; - END; - Result := DirectoryExists( DrivePath ); - if Restore then SetErrorMode( e ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF _D3orHigher} -function WDirectoryExists(const Name: KOLWideString): Boolean; -var - Code: Integer; -begin - Code := GetFileAttributesW(PWideChar(Name)); - Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); -end; -{$ENDIF _D3orHigher} - -{$ENDIF WIN} - -function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean; - const Mask: KOLString ): Boolean; -var FD: TFindFileData; -begin - Result := TRUE; - if DirectoryExists( Name ) then - begin - if Find_First( IncludeTrailingPathDelimiter( Name ) + Mask, FD ) then - begin - repeat - if not {$IFDEF UNICODE_CTRLS}WStrIn{$ELSE}StrIn{$ENDIF}( FD.cFileName, ['.','..'] ) then - begin - if SubDirsOnly and LongBool(FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) - or not SubDirsOnly then - begin - Result := FALSE; - break; - end; - end; - until not Find_Next( FD ); - Find_Close( FD ); - end; - end; -end; - -function DirectoryEmpty(const Name: KOLString): Boolean; -begin - Result := CheckDirectoryContent( Name, FALSE, '*.*' ); -end; - -function DirectoryHasSubdirs( const Path: KOLString ): Boolean; -begin - Result := not CheckDirectoryContent( Path, TRUE, '*.*' ); -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal - {$IFDEF WIN} - {$UNDEF LINUX_USE_HOME_STARTFDIR} - {$ENDIF} -function GetStartDir : KOLString; -{$IFNDEF LINUX_USE_HOME_STARTFDIR} -var Buffer:array[0..MAX_PATH] of KOLChar; - I : Integer; -{$ENDIF} -begin - {$IFDEF LINUX_USE_HOME_STARTFDIR} - Result := getenv( 'HOME' ); - {$ELSE} - I := GetModuleFileName( 0, Buffer, MAX_PATH ); - for I := I downto 0 do - if Buffer[ I ] = {$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF} then - begin - Buffer[ I + 1 ] := #0; - break; - end; - Result := Buffer; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -function ExePath: KOLString; -var Buffer: array[ 0..MAX_PATH+1 ] of KOLChar; -begin - Buffer[ MAX_PATH+1 ] := #0; - GetModuleFileName( 0, Buffer, MAX_PATH+1 ); - Result := Buffer; -end; - -function ModulePath: KOLString; -var Buffer: array[ 0..MAX_PATH+1 ] of KOLChar; -begin - Buffer[ MAX_PATH+1 ] := #0; - GetModuleFileName( hInstance, Buffer, MAX_PATH+1 ); - Result := Buffer; -end; - -{$IFNDEF PAS_ONLY} -function DirectorySize( const Path: KOLString ): I64; -var DirList: PDirList; - I: Integer; -begin - Result := MakeInt64( 0, 0 ); - DirList := NewDirList( Path, {$IFDEF LIN} '*' {$ELSE} '*.*' {$ENDIF}, 0 ); - for I := 0 to DirList.Count-1 do - begin - if LongBool( DirList.Items[ I ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY ) then - Result := Add64( Result, DirectorySize( DirList.Path + DirList.Names[ I ] ) ) - else Result := Add64( Result, MakeInt64( DirList.Items[ I ].nFileSizeLow, - DirList.Items[ I ].nFileSizeHigh ) ); - end; - DirList.Free; -end; -{$ENDIF} - -{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -function GetFileList(const dir: KOLString): PKOLStrList; -var - Srch: TFindFileData; - succ: Boolean; -begin - result := nil; - succ := Find_First(dir, Srch); - while succ do begin - if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin - if Result = nil then begin - Result := NewKOLStrList; - end; - Result.Add(Srch.cFileName); - end; - succ := Find_Next(Srch); - end; - Find_Close(Srch); -end; - -{$ENDIF WIN} -function ExcludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString; -begin - Result := S; - if Result <> '' then - if Result[ Length( Result ) ] = C then - Delete( Result, Length( Result ), 1 ); -end; - -{$IFDEF ASM_UNICODE}{$ELSE PASCAL} -function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString; -begin - Result := S; - if (Result = '') or (Result[ Length( Result ) ] <> C) then - Result := Result + KOLString(C); -end; -{$ENDIF PAS_VERSION} - - -//--------------------------------------------------------- -// Following functions/procedures are created by Edward Aretino: -// IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter, -// ForceDirectories, CreateDir, ChangeFileExt -//--------------------------------------------------------- -function IncludeTrailingPathDelimiter(const S: KOLString): KOLString; -begin - Result := IncludeTrailingChar( S, {$IFDEF UNIX} '/' {$ELSE} '\' {$ENDIF} ); -end; - -function ExcludeTrailingPathDelimiter(const S: KOLString): KOLString; -begin - Result := ExcludeTrailingChar( S, {$IFDEF UNIX} '/' {$ELSE} '\' {$ENDIF} ); -end; - -function ExtractFileDrive( const Path: KOLString ) : KOLString; -var i, j: Integer; -begin - Result := Path; - if Result = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if pos( KOLString(':'), Result ) > 1 then - Result := Parse( Result, ':' ) + ':\' - else if Length( Result ) > 2 then - begin - j := 0; - for i := 3 to Length( Result ) do - if Result[ i ] = '\' then - begin - inc( j ); - if j = 2 then - begin - Result := Copy( Result, 1, i ); - break; - end; - end; - Result := IncludeTrailingPathDelimiter( Result ); - end else if Length( Result ) = 1 then - Result := Result + ':\'; -end; - -{$IFDEF ASM_LStrFromPCharLen} // LStrFromPCharLen - there are no in D2 -function ExtractFilePath( const Path : AnsiString ) : AnsiString; -asm - PUSH EDX - MOV EDX, [DirDelimiters] - CALL EAX2PChar - PUSH EAX - CALL __DelimiterLast - XCHG EDX, EAX - XOR ECX, ECX // ECX = 0 - POP EAX - CMP byte ptr [EDX], CL - JZ @@ret_0 - SUB EDX, EAX - INC EDX - XCHG EDX, EAX - XCHG ECX, EAX // EAX = 0 -@@ret_0: - POP EAX - {$IFDEF _D2009orHigher} - PUSH 0 - {$ENDIF} - CALL System.@LStrFromPCharLen -end; -{$ELSE} //Pascal -function ExtractFilePath( const Path : KOLString ) : KOLString; -//var I : Integer; -var P, P0: PKOLChar; -begin - P0 := PKOLChar( Path ); - P := __DelimiterLast( P0, ':\/' ); - if P^ = #0 then - Result := '' - else Result := Copy( Path, 1, P - P0 + 1 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF _D3orHigher} -function WExtractFilePath( const Path: KOLWideString ) : KOLWideString; -var P, P0: PWideChar; -begin - P0 := PWideChar( Path ); - P := W__DelimiterLast( P0, ':\/' ); - if P^ = #0 then - Result := '' - else Result := Copy( Path, 1, P - P0 + 1 ); -end; -{$ENDIF} - -{$IFDEF ASM_VERSION}{$IFNDEF _D2} -{$DEFINE ASM_LStrFromPCharLen} -{$ENDIF} -{$ENDIF PAS_VERSION} - -function IsNetworkPath( const Path: KOLString ): Boolean; -begin - Result := (Length( Path ) >= 2) and (Path[1] = '\') and (Path[2] = '\'); -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function ExtractFileName( const Path : KOLString ) : KOLString; -var P: PKOLChar; -begin - P := __DelimiterLast( PKOLChar( Path ), ':\/' ); - if P^ = #0 then - Result := Path - else Result := P + 1; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PASCAL} -function ExtractFileNameWOext( const Path : KOLString ) : KOLString; -begin - Result := ExtractFileName( Path ); - Result := Copy( Result, 1, Length( Result ) - Length( ExtractFileExt( Result ) ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function ExtractFileExt( const Path : KOLString ) : KOLString; -var P: PKOLChar; -begin - P := __DelimiterLast( PKOLChar( Path ), '.' ); - Result := P; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PASCAL} -function ReplaceExt( const Path, NewExt: KOLString ): KOLString; -begin - Result := ExtractFilePath( Path ) + ExtractFileNameWOext( Path ) + - NewExt; -end; -{$ENDIF} - -function ForceDirectories(Dir: KOLString): Boolean; -begin - Result := Length(Dir) > 0; {Centronix} - If not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Dir := ExcludeTrailingPathDelimiter(Dir); - If (Length(Dir) < 3) or DirectoryExists(Dir) or - (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. {>>>>>>>>>} - Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir); -end; - -function CreateDir(const Dir: KOLString): Boolean; -begin - Result := {$IFDEF WIN} {Windows.}CreateDirectory(PKOLChar(Dir), nil) - {$ELSE LIN} Libc.__mkdir(PAnsiChar(Dir), S_IRWXU or S_IRWXG or S_IRWXO) = 0 - {$ENDIF}; -end; - -function ChangeFileExt(FileName: KOLString; const Extension: KOLString): KOLString; -var - FileExt: KOLString; -begin - FileExt := ExtractFileExt(FileName); - DeleteTail(FileName, Length(FileExt)); - Result := FileName+ Extension; -end; - -function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString; -begin - Result := ExtractFilePath( Path ) + - ExtractFileNameWOext( ExtractFileName( Path ) ) + - NewExt; -end; - -{$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -function ExtractShortPathName( const Path: KOLString ): KOLString; -var - Buffer: array[0..MAX_PATH - 1] of KOLChar; -begin - SetString(Result, Buffer, - GetShortPathName(PKOLChar(Path), Buffer, SizeOf(Buffer) div Sizeof(KOLChar))); -end; - -{$IFDEF GDI} -function FilePathShortened( const Path: KOLString; MaxLen: Integer ): KOLString; -begin - Result := FilePathShortenPixels( Path, 0, MaxLen ); -end; - -function PixelsLength( DC: HDC; const Text: KOLString ): Integer; -var Sz: TSize; -begin - if DC = 0 then - Result := Length( Text ) - else - begin - {$IFDEF UNICODE_CTRLS}Windows.GetTextExtentPoint32W - {$ELSE} Windows.GetTextExtentPoint32A - {$ENDIF}( DC, PKOLChar( Text ), Length( Text ), Sz ); - Result := Sz.cx; - end; -end; - -function FilePathShortenPixels( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString; -var L0, L1: Integer; - Prev: KOLString; -begin - Result := Path; - L0 := PixelsLength( DC, Result ); - while L0 > MaxPixels do - begin - Prev := Result; - L1 := pos( KOLString('\...\'), Result ); // ambiguous - if L1 <= 0 then - Result := ExcludeTrailingPathDelimiter( ExtractFilePath( Result ) ) - else Result := Copy( Result, 1, L1 - 1 ); - if Result <> '' then - Result := IncludeTrailingPathDelimiter( ExtractFilePath( Result ) ) + - '...\' + ExtractFileName( Path ); - if (Result = '') or (Result = Prev) then - begin - L1 := Length( ExtractFilePath( Result ) ); - while (PixelsLength( DC, Result ) > MaxPixels) and (L1 > 1) do - begin - Dec( L1 ); - Result := Copy( Result, 1, L1 ) + '...\' + ExtractFileName( Result ); - end; - if PixelsLength( DC, Result ) > MaxPixels then - begin - L1 := MaxPixels + 1; - while ((MaxPixels > 0) and (L1 > 1) or (MaxPixels = 0) and (L1 > 0)) and - (PixelsLength( DC, Result ) > MaxPixels) do - begin - Dec( L1 ); - Result := Copy( ExtractFileName( Path ), 1, L1 ) + '...'; - end; - end; - break; - end; - L0 := PixelsLength( DC, Result ); - end; -end; -{$ENDIF GDI} - -procedure CutFirstDirectory(var S: KOLString); -var - Root: Boolean; - P: Integer; -begin - if S = '\' then - S := '' - else - begin - if S[1] = '\' then - begin - Root := True; - Delete(S, 1, 1); - end else - Root := False; - if S[1] = '.' then - Delete(S, 1, 4); - P := Pos( KOLString('\'), S ); - if P <> 0 then - begin - Delete(S, 1, P); - S := '...\' + S; - end else - S := ''; - if Root then - S := '\' + S; - end; -end; - -{$IFDEF GDI} -function MinimizeName( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString; -var - Drive, Dir, Name: KOLString; -begin - Result := Path; - Dir := ExtractFilePath(Result); - Name := ExtractFileName(Result); - - if (Length(Dir) >= 2) and (Dir[2] = ':') then - begin - Drive := Copy(Dir, 1, 2); - Delete(Dir, 1, 2); - end else Drive := ''; - while ((Dir <> '') or (Drive <> '')) and (PixelsLength(DC, Result) > MaxPixels) do - begin - if Dir = '\...\' then - begin - Drive := ''; - Dir := '...\'; - end else if Dir = '' then - Drive := '' - else CutFirstDirectory(Dir); - Result := Drive + Dir + Name; - end; -end; -{$ENDIF GDI} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -function GetSystemDir: KOLString; -var Buf: array[ 0..MAX_PATH-1 ] of KOLChar; -begin - GetSystemDirectory( @ Buf[ 0 ], MAX_PATH ); - Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -function GetWindowsDir : KOLString; -var Buf : array[ 0..MAX_PATH-1 ] of KOLChar; -begin - GetWindowsDirectory( @Buf[ 0 ], MAX_PATH ); - Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -function GetWorkDir : KOLString; -var Buf: array[ 0..MAX_PATH ] of KOLChar; -begin - GetCurrentDirectory( MAX_PATH, @ Buf[ 0 ] ); - Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -{$IFDEF ASM_UNICODE}{$ELSE PASCAL} -function GetTempDir : KOLString; -{$IFDEF WIN} var Buf : Array[ 0..MAX_PATH ] of KOLChar; {$ENDIF WIN} -begin - {$IFDEF LIN} Result := '/tmp/'; {$ELSE WIN} - GetTempPath( MAX_PATH + 1, @Buf[ 0 ] ); - Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) ); - {$ENDIF WIN} -end; -{$ENDIF} - -{$IFDEF WIN} -{$IFDEF ASM_UNICODE}{$ELSE PASCAL} -function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString; -var Buf: array[ 0..MAX_PATH ] of KOLChar; -begin - GetTempFileName( PKOLChar( DirPath ), PKOLChar( Prefix ), 0, Buf ); - Result := Buf; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLString): KOLString; -{* List of files in string, separating each path from others with FileOpSeparator. - E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())} -var - Srch: TFindFileData; - succ: Boolean; - dir:KOLString; -begin - result := ''; - if (FPath<>'') then FPath := IncludeTrailingPathDelimiter( FPath ); - if (FMask<>'') and (FMask[1]={$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF}) then - FMask := CopyEnd(FMask,2); - dir:=FPath+FMask; - succ := Find_First(dir, Srch); - while succ do begin - if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin - if Result<>'' then Result := Result + KOLString(FileOpSeparator); - Result := Result + FPath + KOLString(Srch.cFileName); - end; - succ := Find_Next(Srch); - end; - Find_Close(Srch); -end; - -function DeleteFiles( const DirPath: KOLString ): Boolean; -var Files, Name: KOLString; -begin - Files := GetFileListStr( ExtractFilePath( DirPath ), ExtractFileName( DirPath ) ); - Result := TRUE; - while Files <> '' do - begin - Name := Parse( Files, FileOpSeparator ); - Result := Result and DeleteFile( PKOLChar( Name ) ); - end; -end; - -{$IFDEF WIN_GDI} //>>>>>>>>>>>> -function DeleteFile2Recycle( const Filename : KOLString ) : Boolean; -begin - Result := DoFileOp( Filename, '', FO_DELETE, FOF_ALLOWUNDO or - FOF_NOCONFIRMATION or FOF_SIMPLEPROGRESS, 'Deleting...' ); -end; - -function CopyMoveFiles( const FromList, ToList: KOLString; Move: Boolean ): Boolean; -begin - Result := DoFileOp(FromList, ToList, FO_COPY - Integer( Move ), - FOF_ALLOWUNDO, nil); //|\\ FO_COPY = 2, FO_MOVE = 1 - -end; - -{$IFNDEF PAS_ONLY} -function DiskFreeSpace( const Path: KOLString ): I64; -type TGetDFSEx = function( Path: PKOLChar; CallerFreeBytes, TotalBytes, FreeBytes: Pointer ) - : Bool; stdcall; -var GetDFSEx: TGetDFSEx; - Kern32: THandle; - V: TOSVersionInfo; - Ex: Boolean; - SpC, BpS, NFC, TNC: DWORD; - FBA, TNB: I64; -begin - GetDFSEx := nil; - V.dwOSVersionInfoSize := Sizeof( V ); - GetVersionEx( POSVersionInfo( @ V )^ ); // bug in Windows.pas ! - Ex := FALSE; - if V.dwPlatformId = VER_PLATFORM_WIN32_NT then - Ex := V.dwMajorVersion >= 4 - else if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then - begin - Ex := V.dwMajorVersion > 4; - if not Ex then - if V.dwMajorVersion = 4 then - begin - Ex := V.dwMinorVersion > 0; - if not Ex then - Ex := LoWord( V.dwBuildNumber ) >= $1111; - end; - end; - if Ex then - begin - Kern32 := GetModuleHandle( 'kernel32' ); - GetDFSEx := GetProcAddress( Kern32, 'GetDiskFreeSpaceExA' ); - end; - if Assigned( GetDFSEx ) then - GetDFSEx( PKOLChar( Path ), @ FBA, @ TNB, @Result ) - else - begin - GetDiskFreeSpace( PKOLChar( Path ), SpC, BpS, NFC, TNC ); - Result := Mul64i( MakeInt64( SpC * BpS, 0 ), NFC ); - end; -end; -{$ENDIF} - -function DoFileOp( const FromList, ToList: KOLString; FileOp: UINT; Flags: Word; - Title: PKOLChar): Boolean; -var FOS : {$IFDEF UNICODE_CTRLS}TSHFileOpStructW{$ELSE}TSHFileOpStruct{$ENDIF}; - Buf : PKOLChar; - L : Integer; - ToList0: KOLString; -begin - L := Length( FromList ); - Buf := AllocMem( (L+2) * Sizeof( KOLChar ) ); - Move( FromList[ 1 ], Buf^, L * Sizeof( KOLChar ) ); - for L := L downto 0 do - if Buf[ L ] = FileOpSeparator then Buf[ L ] := #0; - //FillChar( FOS, Sizeof( FOS ), #0 ); - ZeroMemory( @FOS, Sizeof( FOS ) ); - if Applet <> nil then - FOS.Wnd := Applet.Handle; - FOS.wFunc := FileOp; - FOS.lpszProgressTitle := Title; - FOS.pFrom := Buf; - ToList0 := ToList + #0; - FOS.pTo := PKOLChar( ToList0 ); - FOS.fFlags := Flags; - FOS.fAnyOperationsAborted := True; - Result := {$IFDEF UNICODE_CTRLS}SHFileOperationW{$ELSE}SHFileOperationA{$ENDIF}( FOS ) = 0; - if Result then - Result := not FOS.fAnyOperationsAborted; - FreeMem( Buf ); -end; -{$ENDIF WIN_GDI} - -{$IFDEF WIN} -function DirIconSysIdxOffline( const Path: KOLString ): Integer; -var SFI: TShFileInfo; -begin - SFI.iIcon := 0; // Bartov - {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF} - ( PKOLChar( Path ), FILE_ATTRIBUTE_DIRECTORY, SFI, sizeof( SFI ), - SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES ); - Result := SFI.iIcon; -end; -{$ENDIF WIN} - -{ TDirList } - -{$IFDEF SPEED_FASTER} - {$DEFINE DIRLIST_FASTER} -{$ENDIF} - -function NewDirList( const DirPath, Filter: KOLString; Attr: DWORD ): PDirList; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TDirList'; - {$ENDIF} - Result.ScanDirectory( DirPath, Filter, Attr ); -end; - -function NewDirListEx( const DirPath, Filters: KOLString; Attr: DWORD ): PDirList; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TDirListEx'; - {$ENDIF} - Result.ScanDirectoryEx( DirPath, Filters, Attr ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TDirList.Clear; -begin - Free_And_Nil( FListPositions ); - Free_And_Nil( fStoreFiles ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TDirList.Destroy; -begin - Clear; - FPath := ''; - inherited; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function FindFilter(const Filter: KOLString): KOLString; -begin - Result := Filter; - if Result = '' then Result := '*.*'; -end; -{$ENDIF PAS_VERSION} - -function TDirList.Get(Idx: Integer): PFindFileData; -begin - {$IFDEF DIRLIST_FASTER} - Result := FListPositions.Items[ Idx ]; - {$ELSE} - Result := Pointer( Integer( fStoreFiles.fMemory ) - + Integer( FListPositions.Items[ Idx ] ) ); - {$ENDIF} -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TDirList.GetCount: Integer; -begin - Result := 0; - if FListPositions = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := FListPositions.Count; -end; -{$ENDIF PAS_VERSION} - -function TDirList.GetNames(Idx: Integer): KOLString; -var FData: PFindFileData; -begin - FData := Get( Idx ); - Result := FData.cFileName; -end; - -function TDirList.GetIsDirectory(Idx: Integer): Boolean; -begin - Result := LongBool( Items[ Idx ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY ); -end; - -{$IFDEF ASM_noVERSION} -function TDirList.SatisfyFilter(FileName: PAnsiChar; FileAttr, - FindAttr: DWord): Boolean; -asm - PUSH EBX - PUSH ESI - PUSH EDI - XCHG EBX, EAX // EBX = @ Self - MOV EAX, [FindAttr] - MOV EDI, EDX // EDI = FileName - MOV EDX, EAX - AND EDX, ECX - CMP EDX, EAX - JE @@1 - - TEST AL, FILE_ATTRIBUTE_NORMAL - JZ @@ret_false -@@1: - CMP word ptr [EDI], '.' - JE @@1_1 - CMP word ptr [EDI], '..' - JNE @@1_1 - CMP byte ptr [EDI+2], 0 - JNE @@1_1 -@@1_0: - MOV ECX, [FindAttr] - TEST CL, FILE_ATTRIBUTE_NORMAL - JZ @@1_1 - CMP ECX, FILE_ATTRIBUTE_NORMAL - JE @@1_1 - TEST AL, FILE_ATTRIBUTE_DIRECTORY - JZ @@1_1 - TEST CL, FILE_ATTRIBUTE_DIRECTORY - JNZ @@ret_true - -@@1_1: - MOV ECX, [EBX].fFilters - JECXZ @@ret_false //? - - MOV ESI, [ECX].TStrList.fList - MOV ESI, [ESI].TList.fItems - MOV ECX, [ECX].TStrList.fCount - JECXZ @@ret_false - -@@2: - LODSD - TEST EAX, EAX - JZ @@nx_filter - - PUSHAD - - MOV EDX, [EAX] - CMP DX, $002E - JE @@F_d_dd - AND EDX, $FFFFFF - CMP EDX, $002E2E - JE @@F_d_dd - - MOV EDX, [EDI] - CMP DX, $002E - JE @@4 - AND EDX, $FFFFFF - CMP EDX, $002E2E - JE @@4 - JMP @@chk_anti - -@@F_d_dd: - MOV EDX, EDI - PUSH EAX - CALL StrComp - TEST EAX, EAX - POP EAX - JZ @@popad_ret_true - -@@chk_anti: - XCHG EDX, EAX // EDX = filter[ i ] - MOV EAX, EDI // EAX = FileName - CMP byte ptr [EDX], '^' - JNE @@3 - - INC EDX - CALL _2StrSatisfy - TEST AL, AL - JZ @@4 - POPAD - JMP @@ret_false - -@@3: CALL _2StrSatisfy - TEST AL, AL - JZ @@4 -@@popad_ret_true: - POPAD -@@ret_true: - MOV AL, 1 - JMP @@exit - -@@4: POPAD -@@nx_filter: - LOOP @@2 - -@@ret_false: - XOR EAX, EAX -@@exit: - POP EDI - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function TDirList.SatisfyFilter(FileName: PKOLChar; FileAttr, - FindAttr: DWord): Boolean; -{$IFDEF F_P} -const Dot: AnsiString = '.'; -{$ENDIF F_P} -var I: Integer; - F: PKOLChar; - HasOnlyNegFilters: Boolean; - dots: Boolean; -begin - Result := (((FileAttr and FindAttr) = FindAttr) or - LongBool(FindAttr and FILE_ATTRIBUTE_NORMAL)); - if not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - - dots := (FileName^ = {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}) - and ( (FileName[1] = {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}) - and (FileName[2] = #0) - or (FileName[1] = #0) ); - - if not dots then - if LongBool( FindAttr and FILE_ATTRIBUTE_NORMAL ) and - (FindAttr <> FILE_ATTRIBUTE_NORMAL) then - if LongBool( FindAttr and FILE_ATTRIBUTE_DIRECTORY ) and - LongBool( FileAttr and FILE_ATTRIBUTE_DIRECTORY ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - - HasOnlyNegFilters := TRUE; - for I := 0 to fFilters.Count - 1 do - begin - F := fFilters.ItemPtrs[ I ]; - if F = '' then continue; - if FileName = F then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if dots then - continue; - if F[ 0 ] = '^' then - begin - if StrSatisfy( FileName, PKOLChar(@F[ 1 ]) ) then - begin - Result := False; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end else - begin - HasOnlyNegFilters := FALSE; - if StrSatisfy( FileName, F ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - - Result := HasOnlyNegFilters and not dots; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_nononoVERSION} -procedure TDirList.ScanDirectory(const DirPath, Filter: KOLString; - Attr: DWord); -const sz_win32finddata = sizeof(TWin32FindData); -asm - PUSH EBX - PUSH EDI - MOV EBX, EAX - - PUSHAD - CALL Clear - CALL NewList - MOV [EBX].fList, EAX - POPAD - - PUSHAD - LEA EAX, [EBX].fPath - CALL System.@LStrAsg - POPAD - - MOV EAX, [EBX].fPath - TEST EAX, EAX - JE @@exit - - PUSHAD - LEA EDX, [EBX].fPath - MOV EAX, [EDX] - CALL IncludeTrailingPathDelimiter - - MOV EAX, [EBX].fFilters - TEST EAX, EAX - JNZ @@1 - CALL NewStrList - MOV [EBX].fFilters, EAX - POPAD - - PUSHAD - PUSH ECX - XCHG EAX, ECX - MOV EDX, offset[@@star_d_star] - CALL StrComp - TEST AL, AL - POP EDX - JNZ @@asg_Filter - MOV EDX, offset[@@star] -@@asg_Filter: - MOV EAX, [EBX].fFilters - CALL TStrList.Add - JMP @@1 - -@@star_d_star: - DB '*.*', 0 // PCHAR - - {$IFDEF _D2009orHigher} - DW 0, 1 - {$ENDIF} - DD -1, 1 -@@star: DB '*', 0 - -@@1: - POPAD - - ADD ESP, -sz_win32finddata - XOR EDX, EDX - PUSH EDX - PUSH EDX - XCHG EAX, ECX - MOV EDX, ESP - CALL FindFilter - - LEA EAX, [ESP+4] - MOV EDX, [EBX].fPath - POP ECX - PUSH ECX - CALL System.@LStrCat3 - CALL RemoveStr - - POP EAX - MOV EDX, ESP - PUSH EAX - PUSH EDX - PUSH EAX - CALL FindFirstFile - MOV EDI, EAX - INC EAX - MOV EAX, ESP - - PUSHFD - CALL System.@LStrClr - POPFD - POP ECX - - JZ @@fin - -@@loop: - MOV ECX, [ESP].TWin32FindData.dwFileAttributes - PUSH [Attr] - LEA EDX, [ESP+4].TWin32FindData.cFileName - MOV EAX, EBX - CALL SatisfyFilter - - TEST AL, AL - JZ @@next - - MOV ECX, [EBX].fOnItem.TMethod.Code - JECXZ @@accept - MOV EAX, [EBX].fOnItem.TMethod.Data - MOV ECX, ESP - PUSH 1 - MOV EDX, ESP - PUSH EDX - MOV EDX, EBX - CALL dword ptr [EBX].fOnItem.TMethod.Code - POP ECX - JECXZ @@next - LOOP @@fin - -@@accept: - MOV EAX, sz_win32finddata - PUSH EAX - CALL System.@GetMem - PUSH EAX - XCHG EDX, EAX - MOV EAX, [EBX].fList - CALL TList.Add - POP EDX - POP ECX - MOV EAX, ESP - CALL System.Move - -@@next: - PUSH ESP - PUSH EDI - CALL FindNextFile - TEST EAX, EAX - JNZ @@loop - - PUSH EDI - CALL FindClose - -@@fin: - ADD ESP, sz_win32finddata -@@exit: - XOR EAX, EAX - XCHG EAX, [EBX].fFilters - CALL TObj.Free - POP EDI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -procedure TDirList.ScanDirectory(const DirPath, Filter: KOLString; - Attr: DWord); -var FindData : TFindFileData; - Action: TDirItemAction; - {$IFDEF FORCE_ALTERNATEFILENAME} - IsUnicode: KOLString; - {$ENDIF} - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - {$IFDEF DIRLIST_OPTIMIZE_ASCII} - P: PKOLChar; - {$ENDIF} - {$ENDIF} - {$ENDIF} -begin - Clear; - FPath := DirPath; - if FPath = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FPath := IncludeTrailingPathDelimiter( FPath ); - if (fFilters = nil) then - begin - fFilters := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF}; - if Filter = '*.*' then - fFilters.Add( '*' ) - else fFilters.Add( Filter ); - end; - if Find_First( PKOLChar( FPath + FindFilter( Filter ) ), FindData ) then - begin // D[u]fa. fix mem leaks (FList, fFilters) - FListPositions := NewList; - while True do - begin - {$IFDEF FORCE_ALTERNATEFILENAME} //+MtsVN - IsUnicode := FindData.cFileName; - if (IsUnicode <> '.') and (IsUnicode <> '..') then - begin - if pos('?', IsUnicode) > 0 then - CopyMemory( @FindData.cFileName, @FindData.cAlternateFileName, - SizeOf(FindData.cAlternateFileName)); - end; - {$ENDIF} - if SatisfyFilter( PKOLChar(@FindData.cFileName[0]), - FindData.dwFileAttributes, Attr ) then - begin - Action := diAccept; - if Assigned( OnItem ) then - OnItem( @Self, FindData, Action ); - CASE Action OF - diSkip: ; - diAccept: - begin - if fStoreFiles = nil then - begin - {$IFDEF DIRLIST_FASTER} - fStoreFiles := NewMemBlkStream_WriteOnly( 32 * Sizeof( FindData ) ); - {$ELSE} - fStoreFiles := NewMemoryStream( ); - fStoreFiles.Capacity := 64 * Sizeof( FindData ); - {$ENDIF} - end; - {$IFDEF DIRLIST_FASTER}{$ELSE} - FListPositions.Add( Pointer( fStoreFiles.Position ) ); - {$ENDIF} - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - {$IFDEF DIRLIST_OPTIMIZE_ASCII} - FindData.dwReserved0 := 0; - P := @ FindData.cFileName[0]; - while P^ <> #0 do - begin - if PWord( P )^ > 255 then - begin - inc( FindData.dwReserved0 ); - break; - end; - inc( P ); - end; - {$ENDIF} - {$ENDIF} - {$ENDIF} - fStoreFiles.Write( FindData, Sizeof( FindData ) ); - {$IFDEF DIRLIST_FASTER} - FListPositions.Add( fStoreFiles.fData.fJustWrittenBlkAddress ); - {$ENDIF} - end; - diCancel: break; - END; - end; - if not Find_Next( FindData ) then break; - end; - Find_Close( FindData ); - end; - Free_And_Nil(fFilters); //D[u]fa - {$IFnDEF SPEED_FASTER} - if fStoreFiles <> nil then - begin - fStoreFiles.fData.fCapacity := 0; - fStoreFiles.Size := fStoreFiles.Position; - end; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure TDirList.ScanDirectoryEx(const DirPath, Filters: KOLString; - Attr: DWord); -var F, FF: KOLString; -begin - FF := Filters; - Free_And_Nil( fFilters ); - fFilters := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF}; - repeat - F := Trim( Parse( FF, ';' ) ); - if F <> '' then - fFilters.Add( F ); - until FF = ''; - ScanDirectory( DirPath, '', Attr ); -end; -{$ENDIF PAS_VERSION} - -type - PSortDirData = ^TSortDirData; - TSortDirData = packed Record - CountRules: Integer; - FoldersFirst, CaseSensitive, InvertSortOrder : Boolean; - Rules : array[ 0..10 ] of TSortDirRules; - Dir : PDirList; - end; - -function CompareDirItems( const Data : PSortDirData; const e1, e2 : DWORD ) : Integer; -var I : Integer; - Item1, Item2 : PFindFileData; - S1, S2 : PKOLChar; - {$IFDEF UNICODE_CTRLS} - W1, W2: KOLWideString; - {$ENDIF} - IsDir1, IsDir2 : Boolean; - {$IFDEF _D4orHigher} - sz1, sz2: I64; - {$ENDIF} -begin - Item1 := Data.Dir.Get( e1 ); // fList.Items[ e1 ]; - Item2 := Data.Dir.Get( e2 ); // fList.Items[ e2 ]; - Result := 0; - if Data.FoldersFirst then - begin - IsDir1 := (Item1.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0; - IsDir2 := (Item2.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0; - if IsDir1 <> IsDir2 then - begin - if IsDir1 then Result := -1 else Result := 1; - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - for I := 0 to High(Data.Rules){Data.CountRules} do - begin - case Data.Rules[ I ] of - sdrByName: - begin - S1 := Item1.cFileName; - S2 := Item2.cFileName; - if not Data.CaseSensitive then - begin - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - {$IFDEF DIRLIST_OPTIMIZE_ASCII} - if Item1.dwReserved0 or Item2.dwReserved1 = 0 then - begin - //// ATTANTION: _AnsiCompareStrNoCaseA( '', '' ); must be called before sort! - while TRUE do - begin - Result := SortAnsiOrderNoCase[ Char( S1^ ) ] - - SortAnsiOrderNoCase[ Char( S2^ ) ]; - if Result <> 0 then break; - if S1^ = #0 then break; - inc( S1 ); - inc( S2 ); - end; - if Result = 0 then - Result := _AnsiCompareStr( Item1.cFileName, Item2.cFileName ); - end else - {$ENDIF} - {$ENDIF} - begin - W1 := S1; - W2 := S2; - CharUpperBuffW(Pointer(@W1[1]), Length(W1)); - CharUpperBuffW(Pointer(@W2[1]), Length(W2)); - Result := _WStrComp( @W1[1], @W2[1] ); - end; - {$ELSE not UNICODE_CTRLS} - Result := _AnsiCompareStrNoCaseA( S1, S2 ); - if Result = 0 then - Result := _AnsiCompareStr( S1, S2 ); - {$ENDIF} - end else - Result := {$IFDEF UNICODE_CTRLS} - _WStrComp( S1, S2 ) - {$ELSE} - _AnsiCompareStrA( S1, S2 ) - {$ENDIF}; - end; - sdrByExt: - begin - S1 := Item1.cFileName; - S2 := Item2.cFileName; - S1 := {$IFDEF UNICODE_CTRLS} @ S1[ DelimiterLast( KOLWideString( S1 ), '.' ) - 1 ] - {$ELSE} __DelimiterLast( S1, '.' ) {$ENDIF}; - S2 := {$IFDEF UNICODE_CTRLS} @ S2[ DelimiterLast( KOLWideString( S2 ), '.' ) - 1 ] - {$ELSE} __DelimiterLast( S2, '.' ) {$ENDIF}; - if not Data.CaseSensitive then - Result := {$IFDEF UNICODE_CTRLS} - WStrComp( WAnsiUpperCase( S1 ), WAnsiUpperCase( S2 ) ) - {$ELSE} _AnsiCompareStrNoCase( S1, S2 ) {$ENDIF} - else Result := {$IFDEF UNICODE_CTRLS} WStrComp( S1, S2 ) - {$ELSE} _AnsiCompareStr( S1, S2 ) {$ENDIF}; - end; - sdrBySize, sdrBySizeDescending: - begin - {$IFDEF _D5orHigher} - sz1 := MakeInt64( Item1.nFileSizeLow, Item1.nFileSizeHigh ); - sz2 := MakeInt64( Item2.nFileSizeLow, Item2.nFileSizeHigh ); - if Int64(sz1) < Int64(sz2) then - Result := -1 - else if Int64(sz1) > Int64(sz2) then - Result := 1 - else - Result := 0; - {$ELSE} - {$IFDEF _D4orHigher} - sz1 := MakeInt64( Item1.nFileSizeLow, Item1.nFileSizeHigh ); - sz2 := MakeInt64( Item2.nFileSizeLow, Item2.nFileSizeHigh ); - Result := Cmp64(sz1, sz2); - {$ELSE} - if Item1.nFileSizeHigh < Item2.nFileSizeHigh then - Result := -1 - else if Item1.nFileSizeHigh > Item2.nFileSizeHigh then - Result := 1 - else if Item1.nFileSizeLow < Item2.nFileSizeLow then - Result := -1 - else if Item1.nFileSizeLow > Item2.nFileSizeLow then - Result := 1; - {$ENDIF} - {$ENDIF} - if Data.Rules[ I ] = sdrBySizeDescending then - Result := -Result; - end; - sdrByDateCreate: - Result := CompareFileTime( Item1.ftCreationTime, Item2.ftCreationTime ); - sdrByDateChanged: - Result := CompareFileTime( Item1.ftLastWriteTime, Item2.ftLastWriteTime ); - sdrByDateAccessed: - Result := CompareFileTime( Item1.ftLastAccessTime, Item2.ftLastAccessTime ); - sdrNone: break; - end; {case} - if Result <> 0 then break; - end; - if Data.InvertSortOrder then - Result := -Result; -end; - -procedure SwapDirItems( Data : PSortDirData; const e1, e2 : DWORD ); forward; -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure SwapDirItems( Data : PSortDirData; const e1, e2 : DWORD ); -begin - Data.Dir.FListPositions.Swap( e1, e2 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF noASM_VERSION} -procedure TDirList.Sort(Rules: array of TSortDirRules); -const high_DefSortDirRules = High( DefSortDirRules ); -asm - PUSH EBX - PUSH ESI - XOR EBX,EBX - CMP [EAX].FListPositions, EBX - JE @@exit - - PUSH EAX // prepare Dir = @Self - XOR EAX, EAX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EAX - MOV ESI, ESP - INC ECX // ECX = High(Rules) - JZ @@2 -@@1: MOV AH, [EDX] // AH = Rules[ I ] - INC EDX - CALL @@add_rule - LOOP @@1 -@@2: LEA EDX, [DefSortDirRules] - MOV CL, high_DefSortDirRules + 1 -@@21: MOV AH, [EDX] - INC EDX - CALL @@add_rule - LOOP @@21 - - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - MOV EAX, offset[@@emptyStr] - MOV EDX, EAX - CALL dword ptr [_AnsiCompareStrNoCaseA] - {$ENDIF} - {$ENDIF} - - PUSH BX // prepare FoldersFirst(BL), CaseSensitive(BH) - MOV EBX, [ESP].TSortDirData.Dir - MOV EAX, ESP - PUSH BX - PUSH offset[SwapDirItems] - MOV ECX, offset[CompareDirItems] - MOV EDX, [EBX].FListPositions - MOV EDX, [EDX].TList.fCount - CALL SortData - - ADD ESP, 20 - JMP @@exit - - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} -@@emptyStr: - DW 0 - {$ENDIF} - {$ENDIF} - -@@add_rule: - PUSH ESI - PUSH ECX - MOV CL, 11 -@@a1: LODSB - TEST AL, AL - JZ @@a2 - CMP AL, AH - JE @@a3 - LOOP @@a1 -@@a2: DEC ESI - MOV [ESI], AH - CMP AH, sdrFoldersFirst - JNE @@a4 - INC BL -@@a4: CMP AH, sdrCaseSensitive - JNE @@a3 - INC BH -@@a3: POP ECX - POP ESI - RET - -@@exit: - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -procedure TDirList.Sort(Rules: array of TSortDirRules); -var SortDirData : TSortDirData; - I, J : Integer; - - function RulePresent( Rule : TSortDirRules ) : Boolean; - var K : Integer; - begin - Result := True; - for K := J - 1 downto 0 do - if Rule = SortDirData.Rules[ K ] then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := False; - end; - - procedure AddRule( Rule : TSortDirRules ); - begin - if Rule in [sdrFoldersFirst, sdrCaseSensitive, sdrInvertOrder] then - begin - if Rule = sdrFoldersFirst then - SortDirData.FoldersFirst := TRUE; - if Rule = sdrCaseSensitive then - SortDirData.CaseSensitive := TRUE; - if Rule = sdrInvertOrder then - SortDirData.InvertSortOrder := TRUE; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - {$IFDEF SAFE_CODE} - if J > High( SortDirData.Rules ) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - if RulePresent( Rule ) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SortDirData.Rules[ J ] := Rule; - Inc( J ); - end; -begin - if FListPositions = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ZeroMemory( @ SortDirData, Sizeof( SortDirData ) ); //.CaseSensitive := false; // MTsv DN - J := 0; - for I := 0 to High(Rules) do - AddRule( Rules[ I ] ); - for I := 0 to High(DefSortDirRules) do - AddRule( DefSortDirRules[ I ] ); - SortDirData.CountRules := J; - SortDirData.Dir := @Self; - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - _AnsiCompareStrNoCaseA( '', '' ); - {$ENDIF} - {$ENDIF} - SortData( Pointer( @SortDirData ), FListPositions.fCount, @CompareDirItems, @SwapDirItems ); -end; -{$ENDIF PAS_VERSION} - -function TDirList.FileList(const Separator: KOLString; Dirs, - FullPaths: Boolean): KOLString; -var I: Integer; -begin - Result := ''; - for I := 0 to Count-1 do - begin - if not Dirs and IsDirectory[ I ] then Continue; - if FullPaths then - Result := Result + Path; - Result := Result + Names[ I ] + Separator; - end; -end; - -procedure TDirList.DeleteItem(Idx: Integer); -begin - FListPositions.Delete( Idx ); -end; - -procedure TDirList.AddItem(FindData: PFindFileData); -begin - if fStoreFiles = nil then - begin - {$IFDEF DIRLIST_FASTER} - fStoreFiles := NewMemBlkStream_WriteOnly( 32 * Sizeof( FindData ) ); - {$ELSE} - fStoreFiles := NewMemoryStream( ); - fStoreFiles.Capacity := 64 * Sizeof( FindData ); - {$ENDIF} - FListPositions := NewList; - end; - {$IFDEF DIRLIST_FASTER}{$ELSE} - FListPositions.Add( Pointer( fStoreFiles.Position ) ); - {$ENDIF} - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - {$IFDEF DIRLIST_OPTIMIZE_ASCII} - FindData.dwReserved0 := 0; - P := @ FindData.cFileName[0]; - while P^ <> #0 do - begin - if PWord( P )^ > 255 then - begin - inc( FindData.dwReserved0 ); - break; - end; - inc( P ); - end; - {$ENDIF} - {$ENDIF} - {$ENDIF} - fStoreFiles.Write( FindData^, Sizeof( FindData^ ) ); - {$IFDEF DIRLIST_FASTER} - FListPositions.Add( fStoreFiles.fData.fJustWrittenBlkAddress ); - {$ENDIF} -end; - -procedure TDirList.InsertItem(idx: Integer; FindData: PFindFileData); -begin - if fStoreFiles = nil then - begin - {$IFDEF DIRLIST_FASTER} - fStoreFiles := NewMemBlkStream_WriteOnly( 32 * Sizeof( FindData ) ); - {$ELSE} - fStoreFiles := NewMemoryStream( ); - fStoreFiles.Capacity := 64 * Sizeof( FindData ); - {$ENDIF} - FListPositions := NewList; - end; - {$IFDEF DIRLIST_FASTER}{$ELSE} - FListPositions.Insert( idx, Pointer( fStoreFiles.Position ) ); - {$ENDIF} - {$IFDEF UNICODE_CTRLS} - {$IFDEF SPEED_FASTER} - {$IFDEF DIRLIST_OPTIMIZE_ASCII} - FindData.dwReserved0 := 0; - P := @ FindData.cFileName[0]; - while P^ <> #0 do - begin - if PWord( P )^ > 255 then - begin - inc( FindData.dwReserved0 ); - break; - end; - inc( P ); - end; - {$ENDIF} - {$ENDIF} - {$ENDIF} - fStoreFiles.Write( FindData^, Sizeof( FindData^ ) ); - {$IFDEF DIRLIST_FASTER} - FListPositions.Insert( idx, fStoreFiles.fData.fJustWrittenBlkAddress ); - {$ENDIF} -end; - -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -//////////////////////////////////////////////////////////////////////// -// R E G I S T R Y // -//////////////////////////////////////////////////////////////////////// - -{ -- registry -- } - -function RegKeyOpenRead( Key: HKey; const SubKey: KOLString ): HKey; -begin - if RegOpenKeyEx( Key, PKOLChar( SubKey ), 0, KEY_READ, Result ) <> ERROR_SUCCESS then - Result := 0; -end; - -function RegKeyOpenWrite( Key: HKey; const SubKey: KOLString ): HKey; -begin - if RegOpenKeyEx( Key, PKOLChar( SubKey ), 0, KEY_READ or KEY_WRITE, Result ) <> ERROR_SUCCESS then - Result := 0; -end; - -function RegKeyOpenCreate( Key: HKey; const SubKey: KOLString ): HKey; -var dwDisp: DWORD; -begin - if RegCreateKeyEx( Key, PKOLChar( SubKey ), 0, nil, 0, KEY_ALL_ACCESS, nil, Result, - @dwDisp ) <> ERROR_SUCCESS then - Result := 0; -end; - -function RegKeyGetDw( Key: HKey; const ValueName: KOLString ): DWORD; -var dwType, dwSize: DWORD; -begin - dwSize := sizeof( DWORD ); - Result := 0; - if (Key = 0) or - (RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType, PByte( @Result ), @dwSize ) <> ERROR_SUCCESS) - or (dwType <> REG_DWORD) then Result := 0; -end; - -{$IFDEF REGKEYGETSTREX_ALWAYS} -function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString; -begin - Result := RegKeyGetStrEx( Key, ValueName - {$IFDEF OPTIONAL_REG_EXPAND_SZ}, FALSE {$ENDIF} ); -end; -{$ELSE} -function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString; -var dwType, dwSize: DWORD; - Buffer: PKOLChar; - - function Query: Boolean; - begin - Result := RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType, - Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS; - end; -begin - Result := ''; - if Key = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - dwSize := 0; - Buffer := nil; - if not Query or (dwType <> REG_SZ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - GetMem( Buffer, dwSize * Sizeof( KOLChar ) ); - if Query then - Result := Buffer; - FreeMem( Buffer ); -end; -{$ENDIF} - -function RegKeyGetStrEx( Key: HKey; const ValueName: KOLString - {$IFDEF OPTIONAL_REG_EXPAND_SZ} ; ExpandEnvVars: Boolean {$ENDIF} ): -KOLString; -var dwType, dwSize: DWORD; - Buffer, Buffer2: PKOLChar; - Sz: Integer; - function Query: Boolean; - begin - Result := RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType, - Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS; - end; -begin - Result := ''; - if Key = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - dwSize := 0; - Buffer := nil; - if not Query or ((dwType <> REG_SZ) and (dwtype <> REG_EXPAND_SZ)) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - GetMem( Buffer, dwSize * Sizeof( KOLChar ) ); - if Query then - begin - if (dwtype = REG_EXPAND_SZ) {$IFDEF OPTIONAL_REG_EXPAND_SZ} and (ExpandEnvVars) {$ENDIF} then - begin - Sz := ExpandEnvironmentStrings(Buffer,nil,0); - GetMem(Buffer2,Sz * Sizeof( KOLChar )); // - ExpandEnvironmentStrings(Buffer, Buffer2, Sz); // - Result:=Buffer2; // - FreeMem(Buffer2); // - end else Result := Buffer; - end; - FreeMem( Buffer ); -end; - -function RegKeySetDw( Key: HKey; const ValueName: KOLString; Value: DWORD ): Boolean; -begin - Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0, - REG_DWORD, @Value, sizeof( DWORD ) ) = ERROR_SUCCESS); -end; - -function RegKeySetStr( Key: HKey; const ValueName: KOLString; const Value: KOLString ): Boolean; -begin - Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0, - REG_SZ, PKOLChar(Value), - (Length( Value ) + 1)*Sizeof(KOLChar) ) = ERROR_SUCCESS); -end; - -function RegKeySetStrEx( Key: HKey; const ValueName: KOLString; const Value: KOLString; - expand: Boolean): Boolean; -var dwType: DWORD; -begin - dwType := REG_SZ; - if expand then - dwType := REG_EXPAND_SZ; - Result := (Key <> 0) and (RegSetValueEx(Key, PKOLChar(ValueName), 0, dwType, - PKOLChar(Value), (Length(Value) + 1)*Sizeof(KOLChar)) = ERROR_SUCCESS); -end; - -procedure RegKeyClose( Key: HKey ); -begin - if Key <> 0 then - RegCloseKey( Key ); -end; - -function RegKeyDelete( Key: HKey; const SubKey: KOLString ): Boolean; -begin - Result := FALSE; - if Key <> 0 then - Result := RegDeleteKey( Key, PKOLChar( SubKey ) ) = ERROR_SUCCESS; -end; - -function RegKeyDeleteValue( Key: HKey; const SubKey: KOLString ): Boolean; -begin - Result := FALSE; - if Key <> 0 then - Result := RegDeleteValue( Key, PKOLChar( SubKey ) ) = ERROR_SUCCESS; -end; - -function RegKeyExists( Key: HKey; const SubKey: KOLString ): Boolean; -var K: Integer; -begin - if Key = 0 then - begin - Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - K := RegKeyOpenRead( Key, SubKey ); - Result := K <> 0; - if K <> 0 then - RegKeyClose( K ); -end; - -function RegKeyValExists( Key: HKey; const ValueName: KOLString ): Boolean; -var dwType, dwSize: DWORD; -begin - Result := (Key <> 0) and - (RegQueryValueEx( Key, PKOLChar( ValueName ), nil, - @dwType, nil, @dwSize ) = ERROR_SUCCESS); -end; - -function RegKeyValueSize( Key: HKey; const ValueName: KOLString ): Integer; -begin - Result := 0; - if Key = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RegQueryValueEx( Key, PKOLChar( ValueName ), nil, nil, nil, @ DWORD( Result ) ); -end; - -function RegKeyGetBinary( Key: HKey; const ValueName: KOLString; var Buffer; Count: Integer ): Integer; -begin - Result := 0; - if Key = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Count; - RegQueryValueEx( Key, PKOLChar( ValueName ), nil, nil, @ Buffer, @ Result ); -end; - -function RegKeySetBinary( Key: HKey; const ValueName: KOLString; const Buffer; Count: Integer ): Boolean; -begin - Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0, - REG_BINARY, @ Buffer, Count ) = ERROR_SUCCESS); -end; - -function RegKeyGetDateTime(Key: HKey; const ValueName: KOLString): TDateTime; -begin - RegKeyGetBinary( Key, ValueName, Result, Sizeof( Result ) ); -end; - -function RegKeySetDateTime(Key: HKey; const ValueName: KOLString; DateTime: TDateTime): Boolean; -begin - Result := RegKeySetBinary( Key, ValueName, DateTime, Sizeof( DateTime ) ); -end; - -{$IFDEF OLD_REGKEYGETSUBKEYS} -//----------------------------------------------- -// functions by Valerian Luft -//----------------------------------------------- -function RegKeyGetSubKeys( const Key: HKEY; List: PKOLStrList) : Boolean; -var - I, Size, NumSubKeys, MaxSubKeyLen : DWORD; - KeyName: KOLString; -begin - Result := False; - List.Clear ; - if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, @MaxSubKeyLen, nil, nil, nil, nil, -nil, nil) = ERROR_SUCCESS then - begin - if NumSubKeys > 0 then begin - for I := 0 to NumSubKeys-1 do - begin - Size := MaxSubKeyLen+1; - SetLength(KeyName, Size); - RegEnumKeyEx(Key, I, @KeyName[1], Size, nil, nil, nil, nil); - KeyName := Trim(KeyName); // fixed by Jon - List.Add(KeyName); - end; - end; - Result:= True; - end; -end; -{$ELSE} // new (faster) version by Alex Shyshko (Psychedelic) -function RegKeyGetSubKeys(const Key: HKEY; List: PKOLStrList) : Boolean; -var - i, MaxSubKeyLen, Size: DWORD; - Buf: PKOLChar; -begin - Result:=false; - List.Clear; - - if RegQueryInfoKey(Key, nil, nil, nil, nil, @MaxSubKeyLen, nil, nil, nil, nil, - nil, nil) = ERROR_SUCCESS then - begin - if MaxSubKeyLen > 0 then - begin - Size:=MaxSubKeyLen + 1; // - GetMem(Buf,Size*Sizeof(KOLChar)); // fixed by Jon - i:=0; - - while RegEnumKeyEx(Key,i,buf,Size,nil,nil,nil,nil) <> ERROR_NO_MORE_ITEMS do - begin - List.Add(KOLString(Buf)); - Size:=MaxSubKeyLen + 1; - inc(i); - end; - - FreeMem(Buf{,MaxSubKeyLen + 1}); - end; // if MaxSubKeyLen - Result:=true; - end; // if RegQueryInfoKey - -end; -{$ENDIF} - -{$IFDEF OLD_REGKEYGETVALUENAMES} -function RegKeyGetValueNames(const Key: HKEY; List: PKOLStrList): Boolean; -var - I, Size, NumSubKeys, NumValueNames, MaxValueNameLen: DWORD; - ValueName: KOLString; -begin - List.Clear ; - Result:=False; - if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, nil, nil, @NumValueNames, -@MaxValueNameLen, nil, nil, nil) = ERROR_SUCCESS then - begin - if NumValueNames > 0 then - for I := 0 to NumValueNames - 1 do begin - Size := MaxValueNameLen + 1; - SetLength(ValueName, Size); - //FillChar(ValueName[1],Size,#0); - RegEnumValue(Key, I, @ValueName[1], Size, nil, nil, nil, nil); - ValueName := Trim(ValueName); - List.Add(ValueName); - end; - Result := True; - end ; -end; -{$ELSE} // new (faster) version by Alex Shyshko (Psychedelic) -function RegKeyGetValueNames(const Key: HKEY; List: PKOLStrList) : Boolean; -var - i, MaxValueNameLen, Size: DWORD; - Buf: PKOLchar; -begin - Result:=false; - List.Clear; - - if RegQueryInfoKey(Key, nil, nil, nil, nil, nil, nil, nil, @MaxValueNameLen, nil, - nil, nil) = ERROR_SUCCESS then - begin - if MaxValueNameLen > 0 then - begin - Size:=MaxValueNameLen+1; - GetMem(Buf,Size * SizeOf(KOLChar) ); - i:=0; - while RegEnumValue(Key,i,buf,Size,nil,nil,nil,nil) <> ERROR_NO_MORE_ITEMS do - begin - List.Add(KOLString(Buf)); - Size:=MaxValueNameLen+1; - inc(i); - end; - - FreeMem(Buf {,MaxValueNameLen + ... system always knows how long buffer is}); - end; // if MaxValueNameLen - Result:=true; - end; // if RegQueryInfoKey - -end; -{$ENDIF} - -function RegKeyGetValueTyp (const Key:HKEY; const ValueName: KOLString) : DWORD; -begin -Result:= Key ; -if Key <> 0 then - RegQueryValueEx (Key,@ValueName[1],NIL,@Result,NIL,NIL) -end; - -////////////////////////////////////////////////////////////////////// -// D A T E A N D T I M E -////////////////////////////////////////////////////////////////////// - -{ -- date and time utilities -- } - -{* This part of the unit contains date-time routines. It is not a simple compilation - of Delphi VCL date-time. E.g., TDateTime type is not based on 31-Dec-1899, - but it is based on 31-Dec-0000 instead, allowing easy manipulating of dates - at all Christian era, and all other historical era too. } - -{$UNDEF PAS_LOCAL} -{$IFDEF F_P} {$DEFINE PAS_LOCAL} {$ENDIF} -{$IFDEF PAS_ONLY} {$DEFINE PAS_LOCAL} {$ENDIF} - -procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word); -{$IFDEF PAS_ONLY} -begin - Result := Dividend div Divisor; - Remainder := Dividend mod Divisor; -end; -{$ELSE DELPHI} -asm - PUSH EBX - MOV EBX,EDX - MOV EDX,EAX - SHR EDX,16 - DIV BX - MOV EBX,Remainder - MOV [ECX],AX - MOV [EBX],DX - POP EBX -end; -{$ENDIF} - -function Now : TDateTime; -var SystemTime : TSystemTime; -begin - GetLocalTime( SystemTime ); - SystemTime2DateTime( SystemTime, Result ); -end; - -function Date: TDateTime; -begin - Result := Trunc( Now ); -end; - -procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD ); -var ST: TSystemTime; -begin - DateTime2SystemTime( DateTime, ST ); - Year := ST.wYear; - Month := ST.wMonth; - Day := ST.wDay; - DayOfWeek := ST.wDayOfWeek; -end; - -procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD ); -var Dummy: Word; -begin - DecodeDateFully( DateTime, Year, Month, Day, Dummy ); -end; - -function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean; -var ST: TSystemTime; -begin - //FillChar( ST, Sizeof( ST ), #0 ); - ZeroMemory( @ST, Sizeof(ST) ); - ST.wYear := Year; - ST.wMonth := Month; - ST.wDay := Day; - Result := SystemTime2DateTime( ST, DateTime ); -end; - -procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer ); -var DateTime : TDateTime; -begin - SystemTime2DateTime( SystemTime, DateTime ); - DateTime := DateTime + DaysNum; - DateTime2SystemTime( DateTime, SystemTime ); -end; - -procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer ); -var M : Integer; - DateTime : TDateTime; -begin - M := SystemTime.wMonth + MonthsNum - 1; - Inc( SystemTime.wYear, M div 12 ); - SystemTime.wMonth := M mod 12 + 1; - - // Normalize wDayOfWeek field: - SystemTime2DateTime( SystemTime, DateTime ); - DateTime2SystemTime( DateTime, SystemTime ); -end; - -function IsLeapYear(Year: Integer): Boolean; -begin - Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0)); -end; - -function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean; -{$IFDEF DATE0_1601} -type - TTimeRec = record - CASE Integer OF - 0: ( ft: TFileTime ); - 1: ( it: I64 ); - END; -var TR: TTimeRec; -{$ELSE} -var I : Integer; - _Day : Integer; - DayTable: PDayTable; -{$ENDIF} -begin - {$IFDEF DATE0_1601} -//Result := FALSE; -//if (SystemTime.wYear < 1601) or (SystemTime.wYear > 30827) then Exit; {>>>>>} - Result := SystemTimeToFileTime( SystemTime, TR.ft ); - if Result then - DateTime := Int64( TR.it ) / (10000000.0 * 24 * 3600 ) + Date1601; - {$ELSE} - Result := False; - DateTime := 0.0; - DayTable := @MonthDays[IsLeapYear(SystemTime.wYear)]; - with SystemTime do - if {(wYear >= 0) !always true! and} (wYear <= 9999) and - {(wMonth >= 1) and !otherwise can not convert time only!} - (wMonth <= 12) and - {(wDay >= 1) and !otherwise can not convert time only!} - (wDay <= DayTable^[wMonth]) - {$IFDEF SAFEST_CODE} - and (wHour < 24) and (wMinute < 60) - and (wSecond < 60) and (wMilliSeconds < 1000) - {$ENDIF} then // - begin - _Day := wDay; - for I := 1 to wMonth - 1 do - Inc(_Day, DayTable^[I]); - I := wYear - 1; - //--------------- by Vadim Petrov ------++ - if I<0 then i := 0; // - //--------------------------------------++ - DateTime := (((wHour * 60 + wMinute) * 60 + wSecond) * 1000 + wMilliSeconds) - / MSecsPerDay; - DateTime := DateTime + I * 365 + I div 4 - I div 100 + I div 400 + _Day; - Result := True; - end; - {$ENDIF DATE0_0001} -end; - -function DayOfWeek(Date: TDateTime): Integer; -begin - Result := (Trunc( Date ) + 6) mod 7 + 1; -end; - -{$IFDEF DATE0_1601} - -{$UNDEF ASM_LOCAL} -{$IFDEF ASM_VERSION} -{$IFDEF _D6orHigher} {$DEFINE ASM_LOCAL} -{$ENDIF} -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_LOCAL} -function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean; -asm - PUSH EDI - XCHG EDI, EAX - FLD qword ptr [DateTime] - FSUB dword ptr [@@date1601] - FLD tbyte ptr [@@nsecsperday] - DB $DE, $C9 //FMULP ST(1) - JMP @@truncD7 -@@date1601: DB $50, $AC, $0E, $49 -@@nsecsperday: DB 0,0,0,0,$C0,$69,$2A,$C9,$26,$40 -@@truncD7: CALL System.@TRUNC - PUSH EDX - PUSH EAX - MOV EAX, ESP - PUSH EDI - PUSH EAX - CALL Windows.FileTimeToSystemTime - POP ECX - POP ECX - CMP EAX, 1 - SBB EAX, EAX - INC EAX - POP EDI -end; -{$ELSE} -function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean; -type - TTimeRec = record - CASE Integer OF - 0: ( ft: TFileTime ); - 1: ( it: I64 ); - END; -var TR: TTimeRec; - {$IFnDEF _D6orHigher} - DD, DH, DL: Double; - {$ENDIF} -begin - {$IFDEF _D6orHigher} - TR.it := I64( - Trunc( (DateTime - Date1601) * (24.0 * 3600 * 10000000) ) ); - {$ELSE} - DD := Trunc( (DateTime - Date1601) * (24.0 * 3600 * 10000000) ); - DH := DD / (4.0 * 1024.0 * 1024.0 * 1024.0); - TR.it.Hi := Trunc( DH ); - DL := DD - TR.it.Hi * (4.0 * 1024.0 * 1024.0); - TR.it.Lo := Trunc( DL ); - {$ENDIF} - Result := FileTimeToSystemTime( TR.ft, SystemTime ); -end; -{$ENDIF PAS_VERSION} -{$ELSE DATE0_0001} - -{$UNDEF ASM_LOCAL} -{$IFDEF ASM_VERSION} -{$IFDEF DATE0_0001} - {$DEFINE ASM_LOCAL} -{$ENDIF DATE0_0001} -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_LOCAL} -var _MSecsPerDay: Double = MSecsPerDay; -//function DateTime2SystemTime_Asm(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean; -function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean; -const - D1 = 365; - D4 = D1 * 4 + 1; - D100 = D4 * 25 - 1; - D400 = D100 * 4 + 1; -asm - PUSH EBX - PUSH ESI - PUSH EDI - MOV ESI, SystemTime - FLD QWORD PTR [DateTime] - CALL System.@TRUNC - XCHG EDI, EAX // EDI = Days - PUSH EDI - FILD DWORD PTR [ESP] - POP ECX - FSUBR QWORD PTR [DateTime] - FMUL QWORD PTR [_MSecsPerDay] - CALL System.@ROUND - XCHG EBX, EAX // EBX = MSecs - XOR EAX, EAX - CMP EDI, EAX - JLE @@retFalse - - DEC EDI - INC EAX // EAX = Y = 1 - MOV ECX, D400 -@@while1:CMP EDI, ECX - JL @@1end - SUB EDI, ECX - ADD EAX, 400 - JMP @@while1 -@@1end: PUSH EAX - - MOV EAX, EDI - XOR EDX, EDX - MOV ECX, D100 - DIV ECX // EAX = division = I, EDX = reminder = D - CMP EAX, 4 - JNZ @@4 - DEC EAX - ADD EDX, D100 -@@4: - XCHG EDX, [ESP] // EDX = Y, [ESP] = D - MOV ECX, EDX - XOR EDX, EDX - OR DL, 100 - MUL EDX // EAX = I * 100 - ADD ECX, EAX // ECX = Y + I * 100 - XCHG [ESP], ECX // ECX = D, [ESP] = Y - - XCHG EAX, ECX - XOR EDX, EDX - MOV ECX, D4 - DIV ECX // EAX = [D/D4] = I, EDX = D mod D4 = D - SHL EAX, 2 - ADD [ESP], EAX // Y := Y + I * 4; - - XCHG EAX, EDX - XOR EDX, EDX - XOR ECX, ECX - MOV CX, D1 - DIV ECX - - CMP EAX, 4 - JNZ @@4x - DEC EAX - ADD EDX, D1 -@@4x: - POP ECX - ADD EAX, ECX // inc( Y, I ) - - PUSH EDX // save D - MOV [ESI].TSystemTime.wYear, AX - CALL IsLeapYear - SHR EAX, 1 - SBB EAX, EAX - AND EAX, 12 - LEA ECX, [EAX+MonthDays]// ECX = DayTable - POP EAX // restore D - PUSH ECX -@@whTrue: - MOVZX EDX, byte ptr [ECX] - CMP EAX, EDX - JL @@brk - SUB EAX, EDX - INC ECX - JMP @@whTrue -@@brk: - POP EDX - SUB ECX, EDX - INC ECX - MOV [ESI].TSystemTime.wMonth, CX - INC EAX - MOV [ESI].TSystemTime.wDay, AX - - PUSH dword ptr [DateTime+4] - PUSH dword ptr [DateTime] - CALL KOL.DayOfWeek - MOV [ESI].TSystemTime.wDayOfWeek, AX - - XCHG EAX, EBX - XOR EDX, EDX - MOV ECX, 60000 - DIV ECX // EAX = MinCount, EDX = MSecCount - PUSH EDX - XOR EDX, EDX - XOR ECX, ECX - MOV CL, 60 - DIV ECX // EAX = hours, EDX = minutes - MOV [ESI].TSystemTime.wHour, AX - MOV [ESI].TSystemTime.wMinute, DX - POP EAX - XOR EDX, EDX - MOV CX, 1000 - DIV ECX // EAX = seconds, EDX = milliseconds - MOV [ESI].TSystemTime.wSecond, AX - MOV [ESI].TSystemTime.wMilliseconds, DX - MOV AL, 1 -@@retFalse: - POP EDI - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} -//function DateTime2SystemTime_Pas(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean; -function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean; -const - D1 = 365; - D4 = D1 * 4 + 1; - D100 = D4 * 25 - 1; - D400 = D100 * 4 + 1; -var Days : Integer; - Y, M, D, I: Word; - MSec : Integer; - DayTable: PDayTable; - MinCount, MSecCount: Word; -begin - Days := Trunc( DateTime ); - MSec := Round((DateTime - Days) * MSecsPerDay); - Result := False; - if IsNAN( DateTime ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - with SystemTime do - if Days > 0 then - begin - Dec(Days); - Y := 1; - while Days >= D400 do - begin - Dec(Days, D400); - Inc(Y, 400); - end; - DivMod(Days, D100, I, D); - if I = 4 then - begin - Dec(I); - Inc(D, D100); - end; - Inc(Y, I * 100); - DivMod(D, D4, I, D); - Inc(Y, I * 4); - DivMod(D, D1, I, D); - if I = 4 then - begin - Dec(I); - Inc(D, D1); - end; - Inc(Y, I); - DayTable := @MonthDays[IsLeapYear(Y)]; - M := 1; - while True do - begin - I := DayTable^[M]; - if D < I then Break; - Dec(D, I); - Inc(M); - end; - wYear := Y; - wMonth := M; - wDay := D + 1; - wDayOfWeek := KOL.DayOfWeek( DateTime ); - DivMod(MSec, 60000, MinCount, MSecCount); - DivMod(MinCount, 60, wHour, wMinute); - DivMod(MSecCount, 1000, wSecond, wMilliSeconds); - Result := True; - end; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF DATE0_0001} - -{function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean; -var ST_Pas, ST_Asm: TSystemTime; -begin - if IsNAN( DateTime ) then - asm - nop - end; - Result := DateTime2SystemTime_Pas( DateTime, ST_Pas ); - DateTime2SystemTime_Asm( DateTime, ST_Asm ); - if Result and not CompareMem( @ ST_Asm, @ST_Pas, Sizeof( TSystemTime ) ) then - while TRUE do - begin - DateTime2SystemTime_Pas( DateTime, ST_Pas ); - DateTime2SystemTime_Asm( DateTime, ST_Asm ); - end; - Result := DateTime2SystemTime_Pas( DateTime, SystemTime ); -end;} - -function DateTime_DiffSysLoc: TDateTime; -var ST, LT: TSystemTime; - FT, FT1: TFileTime; - D1, D2: TDateTime; -begin - GetSystemTime( ST ); - SystemTimeToFileTime( ST, FT ); - FileTimeToLocalFileTime( FT, FT1 ); - FileTimeToSystemTime( FT1, LT ); - SystemTime2DateTime( ST, D1 ); - SystemTime2DateTime( LT, D2 ); - Result := D2 - D1; -end; - -function DateTime_System2Local( DTSys: TDateTime ): TDateTime; -begin - Result := DTSys + DateTime_DiffSysLoc; -end; - -function DateTime_Local2System( DTLoc: TDateTime ): TDateTime; -begin - Result := DTLoc - DateTime_DiffSysLoc; -end; - -function FileTime2DateTime( const ft: TFileTime; var DT: TDateTime ): Boolean; -var ft1: TFileTime; - st: TSystemTime; -begin - Result := FileTimeToLocalFileTime( ft, ft1 ) and - FileTimeToSystemTime( ft1, st ) and - SystemTime2DateTime( st, dt ); -end; - -function DateTime2FileTime( DT: TDateTime; var ft: TFileTime ): Boolean; -var st: TSystemTime; -begin - Result := DateTime2SystemTime( DT, ST ) and - SystemTimeToFileTime( st, ft ) and - LocalFileTimeToFileTime( ft, ft ); -end; - -function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD; - const DfltDateFormat : TDateFormat; - const DateFormat : PKOLChar ) : KOLString; -var Buf : PKOLChar; - Sz : Integer; - Flags : DWORD; -begin - Sz := 100; - Buf := nil; - Result := ''; - Flags := 0; - if DateFormat = nil then - if DfltDateFormat = dfShortDate then - Flags := DATE_SHORTDATE - else Flags := DATE_LONGDATE; - while True do - begin - if Buf <> nil then - FreeMem( Buf ); - GetMem( Buf, Sz * Sizeof( KOLChar ) ); - if Buf = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if GetDateFormat( LocaleID, Flags, @SystemTime, DateFormat, Buf, Sz ) = 0 then - begin - if GetLastError = ERROR_INSUFFICIENT_BUFFER then - Sz := Sz * 2 - else break; - end else - begin - Result := Buf; - break; - end; - end; - if Buf <> nil then - FreeMem( Buf ); -end; - -function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD; - const Flags : TTimeFormatFlags; - const TimeFormat : PKOLChar ) : KOLString; -var Buf : PKOLChar; - Sz : Integer; - Flg : DWORD; -begin - Sz := 100; - Buf := nil; - Result := ''; - Flg := 0; - if tffNoMinutes in Flags then - Flg := TIME_NOMINUTESORSECONDS - else if tffNoSeconds in Flags then - Flg := TIME_NOSECONDS; - if tffNoMarker in Flags then - Flg := Flg or TIME_NOTIMEMARKER; - if tffForce24 in Flags then - Flg := Flg or TIME_FORCE24HOURFORMAT; - while True do - begin - if Buf <> nil then - FreeMem( Buf ); - GetMem( Buf, Sz * Sizeof( KOLChar ) ); - if Buf = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if GetTimeFormat( LocaleID, Flg, @SystemTime, TimeFormat, Buf, Sz ) - = 0 then - begin - if GetLastError = ERROR_INSUFFICIENT_BUFFER then - Sz := Sz * 2 - else break; - end else - begin - Result := Buf; - break; - end; - end; - if Buf <> nil then - FreeMem( Buf ); -end; - -function Date2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString; -var ST: TSystemTime; - lpFmt: PKOLChar; -begin - DateTime2SystemTime( D, ST ); - lpFmt := nil; - if Fmt <> '' then lpFmt := PKOLChar( Fmt ); - Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT, dfShortDate, lpFmt ); -end; - -function Time2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString; -var ST: TSystemTime; - lpFmt: PKOLChar; -begin - if D < 1 then D := D + 700000; - DateTime2SystemTime( D, ST ); - lpFmt := nil; - if Fmt <> '' then lpFmt := PKOLChar( Fmt ); - Result := SystemTime2Str( ST, LOCALE_USER_DEFAULT, [], lpFmt ); -end; - -function DateTime2StrShort( D: TDateTime ): KOLString; -var ST: TSystemTime; -begin - //--------- by Vadim Petrov --------++ - if D < 1 then D := D + 1; // - //----------------------------------++ - DateTime2SystemTime( D, ST ); - Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, dfShortDate, nil ) + ' ' + - SystemTime2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, [], nil ); -end; - -function Str2DateTimeFmt( const sFmtStr, sS: KOLString ): TDateTime; -var h12, hAM: Boolean; - FmtStr, S: PKOLChar; - - function GetNum( var S: PKOLChar; NChars: Integer ): Integer; - begin - Result := 0; - while (S^ <> #0) and (NChars <> 0) do - begin - Dec( NChars ); - if (S^ >= '0') and (S^ <= '9') then - begin - Result := Result * 10 + Ord(S^) - Ord('0'); - Inc( S ); - end else break; - end; - end; - - function GetYear( var S: PKOLChar; NChars: Integer ): Integer; - var STNow: TSystemTime; - OldDate: Boolean; - begin - Result := GetNum( S, NChars ); - GetSystemTime( STNow ); - OldDate := (Result >= 50) and (Result < 100); - Result := Result + STNow.wYear - STNow.wYear mod 100; - if OldDate then Dec( Result, 100 ); - end; - - function GetMonth( const fmt: KOLString; var S: PKOLChar ): Integer; - var SD: TSystemTime; - M: Integer; - MonthStr: KOLString; - begin - GetSystemTime( SD ); - SD.wDay := 1; - for M := 1 to 12 do - begin - SD.wMonth := M; - MonthStr := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt {+ '/dd/yyyy/'} ) ); - //MonthStr := Parse( C, '/' ); //++ -- by GMax - if AnsiCompareStrNoCase( MonthStr, Copy( S, 1, Length( MonthStr ) ) ) = 0 then - begin - Inc( S, Length( MonthStr ) ); - Result := M; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := 1; - end; - - procedure SkipDayOfWeek( const fmt: KOLString; var S: PKOLChar ); - var SD: TSystemTime; - Dt: TDateTime; - D: Integer; - C, DayWeekStr: KOLString; - begin - GetSystemTime( SD ); - SystemTime2DateTime( SD, Dt ); - Dt := Dt - SD.wDayOfWeek; - for D := 0 to 6 do - begin - DateTime2SystemTime( Dt, SD ); - C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/MM/yyyy/' ) ); - DayWeekStr := Parse( C, '/' ); - if AnsiCompareStrNoCase( DayWeekStr, Copy( S, 1, Length( DayWeekStr ) ) ) = 0 then - begin - Inc( S, Length( DayWeekStr ) ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Dt := Dt + 1.0; - end; - end; - - procedure GetTimeMark( const fmt: KOLString; var S: PKOLChar ); - var SD: TSystemTime; - AM: Boolean; - C, TimeMarkStr: KOLString; - begin - GetSystemTime( SD ); - SD.wHour := 0; - for AM := FALSE to TRUE do - begin - C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/HH/mm' ) ); - TimeMarkStr := Parse( C, '/' ); - if AnsiCompareStrNoCase( TimeMarkStr, Copy( S, 1, Length( TimeMarkStr ) ) ) = 0 then - begin - Inc( S, Length( TimeMarkStr ) ); - hAM := AM; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - SD.wHour := 13; - end; - Result := 1; - end; - - function FmtIs1( S: PKOLChar ): Boolean; - begin - if StrIsStartingFrom( FmtStr, S ) then - begin - Inc( FmtStr, {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( S ) ); - Result := TRUE; - end else Result := FALSE; - end; - - function FmtIs( S1, S2: PKOLChar ): Boolean; - begin - Result := FmtIs1( S1 ) or FmtIs1( S2 ); - end; - -var ST: TSystemTime; -begin - FmtStr := PKOLChar( sFmtStr); - S := PKOLChar( sS ); - //FillChar( ST, Sizeof( ST ), #0 ); - ZeroMemory( @ST, Sizeof( ST ) ); - h12 := FALSE; - hAM := FALSE; - while (FmtStr^ <> #0) and (S^ <> #0) do - begin - if ((FmtStr^ >= 'a') and (FmtStr^ <= 'z') or - (FmtStr^ >= 'A') and (FmtStr^ <= 'Z')) and - (S^ >= '0') and (S^ <= '9') then - begin - if FmtIs1( 'yyyy' ) then ST.wYear := GetNum( S, 4 ) - else if FmtIs1( 'yy' ) then ST.wYear := GetYear( S, 2 ) - else if FmtIs1( 'y' ) then ST.wYear := GetYear( S, -1 ) - else if FmtIs( 'dd', 'd' ) then ST.wDay := GetNum( S, 2 ) - else if FmtIs( 'MM', 'M' ) then ST.wMonth := GetNum( S, 2 ) - else if FmtIs( 'HH', 'H' ) then ST.wHour := GetNum( S, 2 ) - else if FmtIs( 'hh', 'h' ) then begin ST.wHour := GetNum( S, 2 ); h12 := TRUE end - else if FmtIs( 'mm', 'm' ) then ST.wMinute := GetNum( S, 2 ) - else if FmtIs( 'ss', 's' ) then ST.wSecond := GetNum( S, 2 ) - else break; // + ECM - end - else - if (FmtStr^ = 'M') or (FmtStr^ = 'd') or (FmtStr^ = 'g') then - begin - if FmtIs1( 'MMMM' ) then ST.wMonth := GetMonth( 'MMMM', S ) - else if FmtIs1( 'MMM' ) then ST.wMonth := GetMonth( 'MMM', S ) - else if FmtIs1( 'dddd' ) then SkipDayOfWeek( 'dddd', S ) - else if FmtIs1( 'ddd' ) then SkipDayOfWeek( 'ddd', S ) - else if FmtIs1( 'tt' ) then GetTimeMark( 'tt', S ) - else if FmtIs1( 't' ) then GetTimeMark( 't', S ) - else break; // + ECM - end - else - begin - if FmtStr^ = S^ then - Inc( FmtStr ); - Inc( S ); - end; - end; - - if h12 then - if hAM then - Inc( ST.wHour, 12 ); - - SystemTime2DateTime( ST, Result ); -end; - -function Str2TimeFmt(const sFmtStr, sS: KOLString): TDateTime; -begin - Result := Frac(Str2DateTimeFmt( 'y/M/d ' + sFmtStr, '2000/1/1 ' + sS )); -end; - -var FmtBuf: PKOLChar; - DateSeparator : KOLChar = #0; // + ECM - -function Str2DateTimeShort( const S: KOLString ): TDateTime; -var FmtStr, FmtStr2: KOLString; - - function EnumDateFmt( lpstrFmt: PKOLChar ): Boolean; stdcall; - begin - GetMem( FmtBuf, ({$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF} - ( lpstrFmt ) + 1) * Sizeof( KOLChar ) ); - {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF} - ( FmtBuf, lpstrFmt ); - Result := FALSE; - end; - -begin - FmtStr := 'dd.MM.yyyy'; - FmtBuf := nil; - EnumDateFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, DATE_SHORTDATE ); - if FmtBuf <> nil then - begin - FmtStr := FmtBuf; - FreeMem( FmtBuf ); - end; - - FmtStr2 := 'H:mm:ss'; - FmtBuf := nil; - EnumTimeFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, 0 ); - if FmtBuf <> nil then - begin - FmtStr2 := FmtBuf; - FreeMem( FmtBuf ); - end; - - Result := Str2DateTimeFmt( FmtStr + ' ' + FmtStr2, S ); -end; - -function Str2TimeShort(const S: KOLString): TDateTime; -begin - Result := Frac( Str2DateTimeShort( Date2StrFmt( '', Now ) + ' ' + S ) ); -end; - -// + ECM -function Str2DateTimeShortEx( const S: KOLString ): TDateTime; -var - Buff: Array[0..1] of KOLChar; -begin - if DateSeparator = #0 then - begin - if GetLocaleInfo(GetThreadLocale,LOCALE_SDATE,Buff,2) > 0 then - DateSeparator := Buff[0]; - end; - if Pos(DateSeparator,S) = 0 then - //St := '0.0.0 '+S; - Result := Str2TimeShort(S) - else - Result := Str2DateTimeShort(S); -end; - -/////////////////////////////////////////////////////////////////////// -// T H R E A D S -/////////////////////////////////////////////////////////////////////// - -{ -- Thread -- } - -function ThreadFunc(Thread: PThread): integer; stdcall; -begin - Result := Thread.Execute; -end; - -{$IFDEF USE_CONSTRUCTORS} -function NewThread: PThread; -begin - new( Result, ThreadCreate ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TThread'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -function NewThread: PThread; -begin - {$IFNDEF FPC105ORBELOW} - IsMultiThread := True; - {$ENDIF} - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TThread'; - {$ENDIF} - Result.FSuspended := True; - {$IFDEF PSEUDO_THREADS} - {$ELSE} - Result.FHandle := CreateThread( nil, // no security - 0, // the same stack size - @ThreadFunc, // thread entry point - Result, // parameter to pass to ThreadFunc - CREATE_SUSPENDED, // always SUSPENDED - Result.FThreadID ); // receive thread ID - {$ENDIF} -end; -{$ENDIF USE_CONSTRUCTORS} - -{$IFDEF USE_CONSTRUCTORS} -function NewThreadEx( const Proc: TOnThreadExecute ): PThread; -begin - new( Result, ThreadCreateEx( Proc ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TThreadEx'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_!VERSION} -function NewThreadEx( const Proc: TOnThreadExecute ): PThread; -asm - CALL NewThread - POP EBP - POP ECX - POP EDX - MOV [EAX].TThread.fOnExecute.TMethod.Code, EDX - POP EDX - MOV [EAX].TThread.fOnExecute.TMethod.Data, EDX - PUSH ECX - PUSH EAX - CALL TThread.Resume - POP EAX - RET -end; -{$ELSE PAS_VERSION} //Pascal -function NewThreadEx( const Proc: TOnThreadExecute ): PThread; -begin - Result := NewThread; - Result.OnExecute := Proc; - Result.Resume; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread; -begin - Result := NewThread; - Result.OnExecute := Proc; - Result.F_AutoFree := TRUE; - {$IFDEF SAFE_CODE} - if Assigned( Proc ) then - {$ENDIF} - Result.Resume; -end; - -{ TThread } - -function WndProcCMExec( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; -var Thread: PThread; -begin - Result := FALSE; - if Msg.message = CM_EXECPROC then - begin - Thread := PThread( Msg.lParam ); - if Msg.wParam <> 0 then - Thread.FMethodEx( Thread, Pointer( Msg.wParam ) ) - else Thread.FMethod( ); - Rslt := 0; - end; -end; - -{$IFDEF PSEUDO_THREADS} -function timeBeginPeriod(uPeriod: UINT): UINT; stdcall; -external 'winmm.dll' name 'timeBeginPeriod'; -function timeEndPeriod(uPeriod: UINT): UINT; stdcall; -external 'winmm.dll' name 'timeEndPeriod'; -{$ENDIF} - -procedure TThread.Init; -begin - {$IFDEF CALL_INHERITED} - inherited; - {$ENDIF} - if Applet <> nil then - Applet.AttachProc( WndProcCMExec ); - {$IFDEF PSEUDO_THREADS} - if (MainThread = nil) and not CreatingMainThread then - begin // creating main thread - CreatingMainThread := TRUE; - new( MainThread, Create ); - {$IFDEF DEBUG_OBJKIND} - MainThread.fObjKind := 'MainThread'; - {$ENDIF} - CreatingMainThread := FALSE; - end; - if CreatingMainThread then - begin - MainThread := @ Self; - {MainThread.}AllThreads := NewList; - {MainThread.}CurrentThread := MainThread; - TimeBeginPeriod( 10 ); - end; - if not CreatingMainThread and (MainThread <> @ Self) then - begin // creating other threads - GetMem( StackBottom, PseudoThreadStackSize ); - CurStackPos := Pointer( DWORD( StackBottom ) + PseudoThreadStackSize ); - Stack_Empty := TRUE; - end; - MainThread.AllThreads.Add( @ Self ); - {$ENDIF} -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TThread.Destroy; -begin - RefInc; - if not FTerminated then - begin - Terminate; - WaitFor; - end; - if (FHandle <> 0) then - CloseHandle(FHandle); - {$IFDEF PSEUDO_THREADS} - if StackBottom <> nil then - FreeMem( StackBottom ); - if MainThread = @ Self then - begin - TimeEndPeriod( 10 ); - AllThreads.Free; - end else - if MainThread <> nil then - begin - MainThread.AllThreads.Remove( @ Self ); - if MainThread.AllThreads.Count <= 1 then - Free_And_Nil( MainThread ); - end; - {$ENDIF} - inherited; -end; -{$ENDIF PAS_VERSION} - -function TThread.Execute: integer; -{$IFDEF TERMAUTOFREE_THREAD} -var H: THandle; -{$ENDIF} -begin - {$IFDEF SAFE_CODE} - Result := 0; - if Assigned( FOnExecute ) then - {$ENDIF} - Result := FOnExecute( @Self ); - FResult := Result; - FTerminated := TRUE; // fake thread object (to prevent terminating while freeing) - if F_AutoFree then - begin - {$IFDEF TERMAUTOFREE_THREAD} - H := FHandle; - {$ENDIF} - CloseHandle( FHandle ); - FHandle := 0; - Free; - {$IFDEF TERMAUTOFREE_THREAD} - TerminateThread( H, 0 ); - {$ENDIF} - end; -end; - -function TThread.GetPriorityCls: Integer; -begin - {$IFDEF PSEUDO_THREADS} - Result := FPrtyCls; - {$ELSE} - Result := GetPriorityClass(FHandle); - {$ENDIF} -end; - -function TThread.GetThrdPriority: Integer; -begin - {$IFDEF PSEUDO_THREADS} - Result := FPriority; - {$ELSE} - Result := GetThreadPriority(FHandle); - {$ENDIF} -end; - -procedure TThread.Resume; -begin - {$IFDEF PSEUDO_THREADS} - if MainThread.CurrentThread = @ Self then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>} - MainThread.SwitchToThread( @ Self ); - {$ELSE} - FSuspended := False; - if (ResumeThread(FHandle) > 1) then - FSuspended := True - else if Assigned(FOnResume) then - FOnResume(@Self); - {$ENDIF} -end; - -procedure TThread.SetPriorityCls(Value: Integer); -begin - {$IFDEF DEBUG_ANY} - if not SetPriorityClass(GetCurrentProcess, Value) then - begin - ShowMessage( SysErrorMessage( GetLastError ) ); - end; - {$ELSE} - {$IFDEF PSEUDO_THREADS} - FPrtyCls := Value; - {$ELSE} - SetPriorityClass(GetCurrentProcess, Value); - {$ENDIF} - {$ENDIF DEBUG_ANY} -end; - -procedure TThread.SetThrdPriority(Value: Integer); -begin - FPriority := Value; - {$IFDEF PSEUDO_THREADS} - {$ELSE} - SetThreadPriority(FHandle, Value); - {$ENDIF} -end; - -procedure TThread.Suspend; -begin - {$IFDEF PSEUDO_THREADS} - if MainThread <> @ Self then - FSuspended := TRUE; - if MainThread.CurrentThread = @ Self then - MainThread.NextThread; - {$ELSE} - FSuspended := TRUE; - if Assigned(FOnSuspend) then - Synchronize( FOnSuspend ); - SuspendThread(FHandle); - {$ENDIF} -end; - -{$IFDEF PSEUDO_THREADS} -procedure FinishThread; -begin - MainThread.CurrentThread.fTerminated := TRUE; - MainThread.CurrentThread.Stack_Empty := TRUE; - MainThread.NextThread; -end; - -procedure TThread.SwitchToThread(T: PThread); -begin - {$IFDEF SAFE_CODE} - if (T <> MainThread) - and not Assigned( T.OnExecute ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - if Assigned( MainThread.CurrentThread.OnSuspend ) then - begin - MainThread.CurrentThread.OnExecute( MainThread.CurrentThread ); - end; - asm - mov edx, [T] - // 1. Suspending current thread - mov ecx, [MainThread] - mov eax, [ecx].CurrentThread - push ebx - push ebp - push esi - push edi - mov [eax].CurStackPos, esp - mov [eax].Stack_Empty, 0 - // 2. Switching to another thread - - mov [ecx].CurrentThread, edx - - cmp [edx].Stack_Empty, 0 - jz @@1 - // the first call - mov [edx].Stack_Empty, 0 - cmp [edx].FSuspended, 0 - jz @@0 - mov [edx].FSuspended, 0 - - mov esp, [edx].CurStackPos - mov ecx, [edx].fOnResume.TMethod.Code - jecxz @@0 - mov eax, [edx].fOnResume.TMethod.Data - call ecx // calling OnResume for resuming thread - @@0: - mov eax, [edx].fOnExecute.TMethod.Data - mov ecx, [edx].fOnExecute.TMethod.Code - push offset [FinishThread] // if thread will be finished it will jump there - jmp ecx - @@1: - // other calls - resuming - mov esp, [edx].CurStackPos - pop edi - pop esi - pop ebp - pop ebx - cmp [edx].FSuspended, 0 - jz @@2 - mov [edx].FSuspended, 0 - - mov ecx, [edx].fOnResume.TMethod.Code - jecxz @@2 - mov eax, [edx].fOnResume.TMethod.Data - call ecx // calling OnResume for resuming thread - @@2: - end; - // At this point, thread is resumed -end; - -procedure TThread.NextThread; -var i: Integer; - T: PThread; - C: DWORD; -begin - i := MainThread.AllThreads.IndexOf( MainThread.CurrentThread ); - if i >= 0 then - begin - C := GetTickCount; - while TRUE do - begin - inc( i ); - if i >= MainThread.AllThreads.Count then i := 0; - T := MainThread.AllThreads.Items[ i ]; - if (T.DoNotWakeUntil > C) and (T <> MainThread) then continue; - if (T = MainThread) and (MainThread.CurrentThread = T) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if not T.Terminated and not ((T <> MainThread) and (T.Suspended)) then - begin - break; - end; - end; - MainThread.SwitchToThread( MainThread.AllThreads.Items[ i ] ); - end; -end; - -procedure Sleep( n: DWORD ); -begin - if Assigned( MainThread ) then - begin - MainThread.CurrentThread.DoNotWakeUntil := GetTickCount + n; - MainThread.NextThread; - end else - if n > 0 then Windows.Sleep( n ); -end; - -function WaitForMultipleObjects( nCount: DWORD; - lpHandles: PHandle; fWaitAll: BOOL; dwMilliseconds: DWORD ): DWORD; stdcall; -var i: Integer; - w: DWORD; - Ph: PHandle; - Limit: DWORD; -begin - if dwMilliseconds = INFINITE then - Limit := INFINITE - else Limit := GetTickCount + dwMilliseconds; - while TRUE do - begin - Ph := lpHandles; - w := 0; - for i := 0 to nCount-1 do - begin - if Windows.WaitForSingleObject( Ph^, 0 ) = WAIT_OBJECT_0 then - begin - inc( w ); - if not fWaitAll then - begin - Result := WAIT_OBJECT_0 + i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - inc( Ph ); - end; - if w = nCount then - begin - Result := WAIT_OBJECT_0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if (Limit <> INFINITE) and (GetTickCount > Limit) then - begin - Result := WAIT_TIMEOUT; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if Assigned( MainThread ) then - MainThread.NextThread; - {$IFDEF WAIT_SLEEP} - Sleep( 10 ); - {$ENDIF} - end; -end; - -function WaitForSingleObject( hHandle: THandle; dwMilliseconds: DWORD ): DWORD; stdcall; -begin - Result := WaitForMultipleObjects( 1, @ hHandle, TRUE, dwMilliseconds ); -end; -{$ENDIF PSEUDO_THREADS} - -procedure TThread.Synchronize(Method: TThreadMethod); -begin - {$IFDEF PSEUDO_THREADS} - Method; - {$ELSE} - FMethod := Method; - if Applet <> nil then - SendMessage( Applet.fHandle, CM_EXECPROC, 0, Integer( @Self ) ); - {$ENDIF} -end; - -procedure TThread.SynchronizeEx( Method: TThreadMethodEx; Param: Pointer ); -begin - {$IFDEF KOL_ASSERTIONS} - Assert( Param <> nil, 'Parameter must not be NIL' ); - {$ENDIF KOL_ASSERTIONS} - {$IFDEF PSEUDO_THREADS} - Method( TMethod( Method ).Data, Param ); - {$ELSE} - FMethodEx := Method; - SendMessage( Applet.fHandle, CM_EXECPROC, Integer( Param ), Integer( @Self ) ); - {$ENDIF} -end; - -procedure TThread.Terminate; -begin - {$IFDEF PSEUDO_THREADS} - FTerminated := TRUE; - if Assigned( MainThread ) then - if MainThread.CurrentThread = @ Self then - MainThread.NextThread; - {$ELSE} - TerminateThread(FHandle,0); - FTerminated := True; - {$ENDIF} -end; - -function TThread.WaitFor: Integer; -begin - RefInc; - Result := -1; - {$IFDEF PSEUDO_THREADS} - while not Terminated do - Resume; - if Terminated then - Result := FResult; - {$ELSE} - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - WaitForSingleObject(FHandle, INFINITE); - GetExitCodeThread(FHandle, DWORD(Result)); - {$ENDIF} - RefDec; -end; - -function TThread.WaitForTime(T: DWORD): Integer; -{$IFDEF PSEUDO_THREADS} - var LimitTime: DWORD; -{$ENDIF} -begin - {$IFDEF PSEUDO_THREADS} - LimitTime := GetTickCount + T; - RefInc; - while not Terminated and (GetTickCount < LimitTime) do - Resume; - Result := -1; - if Terminated then - Result := FResult; - RefDec; - {$ELSE} - Result := WAIT_OBJECT_0; - RefInc; - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := WaitForSingleObject(FHandle, T); - if Result = WAIT_OBJECT_0 then - GetExitCodeThread(FHandle, T); - RefDec; - {$ENDIF} -end; - -{$IFDEF _D2} - {$DEFINE _D2orFPC} -{$ENDIF} -{$IFDEF _FPC} - {$IFNDEF _D2orFPC} - {$DEFINE _D2orFPC} - {$ENDIF} -{$ENDIF} - -function TThread.GetPriorityBoost: Boolean; -type TGetPriorityBoost = function(hThread: THandle; - var DisablePriorityBoost: Bool): BOOL; stdcall; -var B: Bool; - GPB: TGetPriorityBoost; - M: THandle; -begin - Result := TRUE; - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (WinVer >= WvNT) then // by TK: only evaluate if this is true, regardless of evaluation settings - begin - M := GetModuleHandle( 'kernel32' ); - GPB := GetProcAddress( M, 'GetThreadPriorityBoost' ); - {$IFDEF SAFE_CODE} - if Assigned( GPB ) then - {$ENDIF} - if GPB( fHandle, B ) then - Result := B; - end; -end; - -procedure TThread.SetPriorityBoost(const Value: Boolean); -type TSetPriorityBoost = function(hThread: THandle; - DisablePriorityBoost: Bool): Bool; stdcall; -var M: THandle; - SPB: TSetPriorityBoost; -begin - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if WinVer >= WvNT then - begin - M := GetModuleHandle( 'kernel32' ); - SPB := GetProcAddress( M, 'SetThreadPriorityBoost' ); - {$IFDEF SAFE_CODE} - if Assigned( SPB ) then - {$ENDIF} - SPB( fHandle, not Value ); - end; -end; - -{ TStream } - -{* This part of the unit contains implementation of streams for KOL. Please note, - that both stream types (file stream and memory stream) are incapsulated - by a single object type TStream. To avoid including unnedeed code, - use constructing functions NewReadFileStream and NewWriteFileStream - to work with file streams, which do not require both types of operation. } - -{* To create new type of stream, define your own methods, and in your - constructing function, pass it to _NewStream function (through - TStreamMethods record). In a field Custom, You can store a reference to - your own data of any type (but do not forget to define correct releasing - of such data in your fClose procedure). } - -function TStream.GetPosition: TStrmSize; -begin - Result := Seek( 0, spCurrent ); -end; - -procedure TStream.SetPosition(const Value: TStrmSize); -begin - Seek( Value, spBegin ); -end; - -{$IFDEF ASM_STREAM} -function TStream.GetSize: TStrmSize; -asm - CALL [EAX].fMethods.fGetSiz -end; -{$ELSE PAS_VERSION} //Pascal -function TStream.GetSize: TStrmSize; -begin - Result := fMethods.fGetSiz( @Self ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_STREAM} -procedure TStream.SetSize(const NewSize: TStrmSize); -asm - CALL [EAX].fMethods.fSetSiz -end; -{$ELSE PAS_VERSION} //Pascal -procedure TStream.SetSize(const NewSize: TStrmSize); -begin - fMethods.fSetSiz( @Self, NewSize ); -end; -{$ENDIF PAS_VERSION} - -function TStream.GetFileStreamHandle: THandle; -begin - Result := fData.fHandle; -end; - -{$IFDEF ASM_STREAM} -function TStream.Read(var Buffer; const Count: TStrmSize): TStrmSize; -asm - CALL [EAX].fMethods.fRead -end; -{$ELSE PAS_VERSION} //Pascal -function TStream.Read(var Buffer; const Count: TStrmSize): TStrmSize; -begin - Result := fMethods.fRead( @Self, Buffer, Count ); -end; -{$ENDIF PAS_VERSION} - -function TStream.GetCapacity: TStrmSize; -begin - Result := fData.fCapacity; -end; - -procedure TStream.SetCapacity(const Value: TStrmSize); -var OldSize: DWORD; - V: TStrmSize; -begin - V := Value; - {$IFDEF OLD_STREAM_CAPACITY} - if fData.fCapacity >= Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - OldSize := Size; - Size := V; - Size := OldSize; - {$ELSE} - if Value < fData.fSize then V := fData.fSize; - if Value > fData.fCapacity then - begin - OldSize := Size; - Size := V; - Size := OldSize; - end else - if fMemory <> nil then - begin - {$IFDEF _D4orHigher} - fMemory := ReallocMemory( fMemory, V ); - {$ELSE} - ReallocMem( fMemory, V ); - {$ENDIF} - fData.fCapacity := V; - end; - {$ENDIF} -end; - -function TStream.Busy: Boolean; -begin - Result := ( fData.fThread <> nil ); -end; - -function TStream.DoAsyncRead( Sender: PThread ): Integer; -begin - Read( Pointer( fParam1 )^, fParam2 ); - fData.fThread := nil; - Result := 0; -end; - -procedure TStream.ReadAsync(var Buffer; Count: DWord); -begin - if Busy then Wait; - fData.fThread := NewThreadAutoFree( nil ); - fData.fThread.OnExecute := DoAsyncRead; - fParam1 := DWORD( @ Buffer ); - fParam2 := Count; - fData.fThread.Resume; -end; - -function TStream.DoAsyncSeek( Sender: PThread ): Integer; -begin - Seek( fParam1, TMoveMethod( fParam2 ) ); - fData.fThread := nil; - Result := 0; -end; - -procedure TStream.SeekAsync(MoveTo: TStrmMove; MoveMethod: TMoveMethod); -begin - if Busy then Wait; - fData.fThread := NewThreadAutoFree( nil ); - fData.fThread.OnExecute := DoAsyncSeek; - fParam1 := MoveTo; - fParam2 := Ord( MoveMethod ); - fData.fThread.Resume; -end; - -function TStream.DoAsyncWrite( Sender: PThread ): Integer; -begin - Write( Pointer( fParam1 )^, fParam2 ); - fData.fThread := nil; - Result := 0; -end; - -procedure TStream.WriteAsync(var Buffer; Count: DWord); -begin - if Busy then Wait; - fData.fThread := NewThreadAutoFree( nil ); - fData.fThread.OnExecute := DoAsyncWrite; - fParam1 := DWORD( @ Buffer ); - fParam2 := Count; - fData.fThread.Resume; -end; - -procedure TStream.Wait; -begin - if ( fData.fThread = nil ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Assigned( fMethods.fWait ) then - fMethods.fWait( @Self ) - else fData.fThread.WaitFor; -end; - -{$IFDEF ASM_STREAM} -function TStream.Write(var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize; -asm - CALL [EAX].fMethods.fWrite -end; -{$ELSE PAS_VERSION} //Pascal -function TStream.Write(var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize; -begin - Result := fMethods.fWrite( @Self, Buffer, Count ); -end; -{$ENDIF PAS_VERSION} - -function TStream.WriteVal(Value, Count: DWORD): DWORD; -begin - Result := Write( Value, Count ); -end; - -function TStream.WriteStr(S: AnsiString): DWORD; -begin - if S <> '' then - Result := fMethods.fWrite( @Self, S[1], Length( S ) ) - else Result := 0; -end; - -function TStream.ReadStrZ: AnsiString; -var C: AnsiChar; -begin - Result := ''; - REPEAT - C := #0; - Read( C, 1 ); - if C <> #0 then Result := Result + C; - UNTIL C = #0; -end; - -{$IFDEF _D3orHigher} -function TStream.ReadWStrZ: KOLWideString; -var C: WideChar; -begin - Result := ''; - REPEAT - C := #0; - Read( C, 2 ); - if C <> #0 then - Result := Result + - {$IFDEF _D3} - KOLWideString( C ) - {$ELSE} - C - {$ENDIF}; - UNTIL C = #0; -end; -{$ENDIF _D3orHigher} - -function TStream.ReadStr: AnsiString; -var C: AnsiChar; -begin - Result := ''; - REPEAT - C := #0; - Read( C, 1 ); - if C <> #0 then - begin - if C = #13 then - begin - C := #0; - Read( C, 1 ); - if C <> #10 then Position := Position - 1; - C := #13; - end else if C = #10 then - C := #13; - if C <> #13 then - Result := Result + C; - end; - UNTIL (C = #13) or (C = #0); -end; - -function TStream.ReadStrLen(Len: Integer): AnsiString; -var i: Integer; -begin - SetLength( Result, Len ); - i := Read( Result[1], Len ); - SetLength( Result, i ); -end; - -function TStream.WriteStrZ(S: AnsiString): DWORD; -var C: AnsiChar; -begin - if S = '' then - begin - C := #0; - Result := Write( C, 1 ); - end - else Result := Write( S[ 1 ], Length( S ) + 1 ); -end; - -{$IFDEF _D3orHigher} -function TStream.WriteWStrZ(S: KOLWideString): DWORD; -var C: WideChar; -begin - if S = '' then - begin - C := #0; - Result := Write( C, 2 ); - end - else Result := Write( S[ 1 ], (Length( S ) + 1) * 2 ); -end; -{$ENDIF _D3orHigher} - -function TStream.WriteStrEx(S: AnsiString): DWord; -var L: DWORD; -begin - L := length(s); - result:=fmethods.fwrite(@self,L,Sizeof(DWORD)); - if result = Sizeof(DWORD) then - Inc( result, fmethods.fwrite(@self,s[1],L) ); -end; - -function TStream.ReadStrExVar(var S: AnsiString): DWord; -begin - fmethods.fread(@self,result,Sizeof(DWORD)); - setlength(s,result); - if result<>0 then result:=fmethods.fread(@self,s[1],result); -end; - -function TStream.ReadStrEx: AnsiString; -begin - readstrexvar(result); -end; - -function TStream.WriteStrPas( S: AnsiString ): DWORD; -var L: Integer; -begin - Result := 0; - L := Length( S ); - if L > 255 then L := 255; - if Write( L, 1 ) < 1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := 1; - if L > 0 then - Result := Write( S[ 1 ], L ) + 1; -end; - -function TStream.ReadStrPas: AnsiString; -var L: Byte; -begin - Result := ''; - if Read( L, 1 ) < 1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SetLength( Result, L ); - L := Read( Result[ 1 ], L ); - Result := Copy( Result, 1, L ); -end; - -{$IFDEF ASM_STREAM} -function TStream.Seek({$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize; -//function TStream.Seek(MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize; -asm - CALL [EAX].fMethods.fSeek -end; -{$ELSE PAS_VERSION} //Pascal -function TStream.Seek({$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod): TStrmSize; -begin - Result := fMethods.fSeek( @Self, MoveTo, MoveMethod ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TStream.Destroy; -begin - fMethods.fClose( @Self ); - fData.fThread.Free; - inherited; -end; -{$ENDIF PAS_VERSION} - -procedure TStream.SaveToFile(const Filename: KOLString; const Start, CountSave: TStrmSize); -var F: PStream; - SavePos: DWORD; -begin - F := NewWriteFileStream( Filename ); - SavePos := Position; - Position := Start; - Stream2Stream( F, @ Self, CountSave ); - Position := SavePos; - F.Free; -end; - -function _NewStream( const StreamMethods: TStreamMethods ): PStream; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TStream'; - {$ENDIF} - Move( StreamMethods, Result.fMethods, Sizeof( TStreamMethods ) ); - Result.fPMethods := @Result.fMethods; - TMethod( Result.fOnChangePos ).Code := @DummyObjProc; -end; - -function SeekFileStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -begin - Result := FileSeek( Strm.fData.fHandle, MoveTo, MoveFrom ); - {$IFDEF FILESTREAM_POSITION} - Strm.fData.fPosition := Result; - {$ENDIF} -end; - -function GetSizeFileStream( Strm: PStream ): TStrmSize; -{$IFDEF STREAM_LARGE64} -var SizeHigh: DWORD; -{$ENDIF} -begin - {$IFDEF STREAM_LARGE64} - Result := GetFileSize( Strm.fData.fHandle, @ SizeHigh ); - Result := Result or SizeHigh shl 32; - {$ELSE} - Result := GetFileSize( Strm.fData.fHandle, nil ); - if Result = DWORD( -1 ) then Result := 0; - {$ENDIF} -end; - -procedure DummySetSize( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Value: TStrmSize ); -begin -end; - -procedure DummyStreamProc(Strm: PStream); -begin -end; - -function DummyReadWrite( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -asm - XOR EAX, EAX - {$IFDEF STREAM_LARGE64} - XOR EDX, EDX - {$ENDIF} -end; - -function DummySeek( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveMethod: TMoveMethod ): TStrmSize; -asm - XOR EAX, EAX - {$IFDEF STREAM_LARGE64} - XOR EDX, EDX - {$ENDIF} -end; - -function ReadFileStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := FileRead( Strm.fData.fHandle, Buffer, Count ); - {$IFDEF FILESTREAM_POSITION} - inc( Strm.fData.fPosition, Result ); - {$ENDIF} -end; - -function ReadFileStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := FileRead( Strm.fData.fHandle, Buffer, Count ); - inc( Strm.fData.fPosition, Result ); - if (Result > 0) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then - Strm.OnChangePos( Strm ); -end; - -function WriteFileStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := FileWrite( Strm.fData.fHandle, Buffer, Count ); - {$IFDEF FILESTREAM_POSITION} - inc( Strm.fData.fPosition, Result ); - {$ENDIF} -end; - -function WriteFileStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := FileWrite( Strm.fData.fHandle, Buffer, Count ); - inc( Strm.fData.fPosition, Result ); - if (Result > 0) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then - Strm.OnChangePos( Strm ); -end; - -{$IFDEF ASM_STREAM} -function WriteFileStreamEOF( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -asm - PUSH EBX - PUSH [EAX].TStream.fData.fHandle - CALL WriteFileStream - XCHG EBX, EAX - CALL SetEndOfFile - XCHG EAX, EBX - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function WriteFileStreamEOF( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := WriteFileStream( Strm, Buffer, Count ); - {$IFDEF FILESTREAM_POSITION} - inc( Strm.fData.fPosition, Result ); - {$ENDIF} - SetEndOfFile( Strm.fData.fHandle ); -end; -{$ENDIF PAS_VERSION} - -function WriteFileStreamEOFWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := WriteFileStream( Strm, Buffer, Count ); - inc( Strm.fData.fPosition, Result ); - SetEndOfFile( Strm.fData.fHandle ); - if (Result > 0) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then - Strm.OnChangePos( Strm ); -end; - -procedure CloseFileStream( Strm: PStream ); -begin - if Strm.fData.fHandle <> INVALID_HANDLE_VALUE then - FileClose( Strm.fData.fHandle ); - Strm.fData.fHandle := INVALID_HANDLE_VALUE; -end; - -{$IFDEF ASM_STREAM} -function SeekMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} - MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -asm - PUSH EBX - MOV EBX, EDX - AND ECX, $FF - LOOP @@not_from_cur - ADD EBX, [EAX].TStream.fData.fPosition -@@not_from_cur: - LOOP @@not_from_end - ADD EBX, [EAX].TStream.fData.fSize -@@not_from_end: - CMP EBX, [EAX].TStream.fData.fSize - JLE @@space_ok - PUSH EAX - MOV EDX, EBX - CALL TStream.SetSize - POP EAX -@@space_ok: - XCHG EAX, EBX - MOV [EBX].TStream.fData.fPosition, EAX - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function SeekMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} - MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -var NewPos: DWORD; -begin - case MoveFrom of - spBegin: NewPos := MoveTo; - spCurrent: NewPos := Strm.fData.fPosition + DWORD( MoveTo ); - else //spEnd: - NewPos := Strm.fData.fSize + DWORD( MoveTo ); - end; - if NewPos > Strm.fData.fSize then - Strm.SetSize( NewPos ); - Strm.fData.fPosition := NewPos; - Result := NewPos; -end; -{$ENDIF PAS_VERSION} - -function SeekMemStreamWithEvent( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -var OldPos: DWORD; -begin - OldPos := Strm.Position; - Result := SeekMemStream( Strm, MoveTo, MoveFrom ); - if (OldPos <> Strm.Position) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then - Strm.OnChangePos( Strm ); -end; - -function GetSizeMemStream( Strm: PStream ): TStrmSize; -begin - Result := Strm.fData.fSize; -end; - -{$IFDEF ASM_STREAM} -procedure SetSizeMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -asm - push ebx - push edx - xchg ebx, eax - cmp [ebx].TStream.fData.fCapacity, edx - jae @@mem_ok - {$IFDEF OLD_MEMSTREAMS_SETSIZE} - or edx, [CapacityMask] - inc edx - {$ENDIF} - mov [ebx].TStream.fData.fCapacity, edx - mov ecx, [ebx].TStream.fMemory - jecxz @@getmem - lea eax, [ebx].TStream.fMemory - call System.@ReallocMem - jmp @@setmem - -@@getmem: - or ecx, edx - jz @@mem_ok - xchg eax, ecx - call System.@GetMem -@@setmem: - mov [ebx].TStream.fMemory, eax - -@@mem_ok: - pop ecx // NewSize - inc ecx - loop @@set_new_sz - cmp [ebx].TStream.fData.fSize, ecx - jz @@set_new_sz - - mov [ebx].TStream.fData.fCapacity, ecx - xchg ecx, [ebx].TStream.fMemory - jecxz @@mem_freed - xchg eax, ecx - call System.@FreeMem -@@mem_freed: - xor ecx, ecx - -@@set_new_sz: - mov [ebx].TStream.fData.fSize, ecx - cmp [ebx].TStream.fData.fPosition, ecx - jb @@exit - mov [ebx].TStream.fData.fPosition, ecx - -@@exit: - pop ebx -end; -{$ELSE PAS_VERSION} //Pascal -procedure SetSizeMemStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -var S: PStream; - NewCapacity: DWORD; -begin - S := Strm; - if S.fData.fCapacity < NewSize then - begin - {$IFDEF OLD_MEMSTREAMS_SETSIZE} - NewCapacity := (NewSize or CapacityMask) + 1; - {$ELSE} - NewCapacity := NewSize; - {$ENDIF} - if S.fMemory = nil then - begin - if NewSize <> 0 then - GetMem( S.fMemory, NewCapacity ); - end else ReallocMem( S.fMemory, NewCapacity ); - S.fData.fCapacity := NewCapacity; - end else - if (NewSize = 0) and (S.Size > 0) then - begin - if S.fMemory <> nil then - begin - FreeMem( S.fMemory ); - S.fMemory := nil; - S.fData.fCapacity := 0; - end; - end; - S.fData.fSize := NewSize; - if S.fData.fPosition > S.fData.fSize then - S.fData.fPosition := S.fData.fSize; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_STREAM} -function ReadMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, [EBX].TStream.fData.fPosition - ADD EAX, ECX - CMP EAX, [EBX].TStream.fData.fSize - JLE @@count_ok - MOV ECX, [EBX].TStream.fData.fSize - SUB ECX, [EBX].TStream.fData.fPosition -@@count_ok: - PUSH ECX - MOV EAX, [EBX].TStream.fMemory - ADD EAX, [EBX].TStream.fData.fPosition - CALL System.Move - POP EAX - ADD [EBX].TStream.fData.fPosition, EAX - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function ReadMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var S: PStream; - C: TStrmSize; -begin - S := Strm; - C := Count; - if C + S.fData.fPosition > S.fData.fSize then - C := S.fData.fSize - S.fData.fPosition; - Result := C; - Move( Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Buffer, Result ); - Inc( S.fData.fPosition, Result ); -end; -{$ENDIF PAS_VERSION} - -function ReadMemStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := ReadMemStream( Strm, Buffer, Count ); - if (Result > 0) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then - Strm.OnChangePos( Strm ); -end; - -{$IFDEF ASM_STREAM} -function WriteMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, [EBX].TStream.fData.fPosition - ADD EAX, ECX - CMP EAX, [EBX].TStream.fData.fSize - PUSH EDX - PUSH ECX - JLE @@count_ok - XCHG EDX, EAX - MOV EAX, EBX - CALL TStream.SetSize -@@count_ok: - POP ECX - POP EAX - MOV EDX, [EBX].TStream.fMemory - ADD EDX, [EBX].TStream.fData.fPosition - PUSH ECX - CALL System.Move - POP EAX - ADD [EBX].TStream.fData.fPosition, EAX - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function WriteMemStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var S: PStream; -begin - S := Strm; - if Count + S.fData.fPosition > S.fData.fSize then - S.SetSize( S.fData.fPosition + Count ); - Result := Count; - Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result ); - Inc( S.fData.fPosition, Result ); -end; -{$ENDIF PAS_VERSION} - -function WriteMemStreamWithEvent( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := WriteMemStream( Strm, Buffer, Count ); - if (Result > 0) - {$IFDEF SAFE_CODE} and Assigned( Strm.OnChangePos ) {$ENDIF} then - Strm.OnChangePos( Strm ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure CloseMemStream( Strm: PStream ); -var S: PStream; -begin - S := Strm; - if S.fMemory <> nil then - begin - FreeMem( S.fMemory ); - S.fMemory := nil; - end; -end; -{$ENDIF PAS_VERSION} - -procedure DummyCloseStream( Strm: PStream ); -begin - // nothing here -end; - -// by Roman Vorobets: -procedure SetSizeFileStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -var P: DWORD; -begin - P:=Strm.Position; - Strm.Position:=NewSize; - SetEndOfFile(Strm.Handle); - if P < NewSize then - Strm.Position:=P; -end; - -function ReadMemBlkStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var P, bStart, bLen, C: DWORD; - bAddr: PByte; - i: Integer; -begin - P := Strm.Position; - i := 0; - bStart := 0; - bLen := 0; - bAddr := nil; - while i < Strm.fData.fBlocks.Count do - begin - bAddr := Strm.fData.fBlocks.fItems[i]; - bLen := Integer( Strm.fData.fBlocks.fItems[i+1] ); - if bStart + bLen > P then - break; - inc( i, 2 ); - inc( bStart, bLen ); - end; - if bStart + bLen < P then - begin - Result := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - inc( bAddr, P - bStart ); - C := Count; - if C > bLen - (P - bStart) then - C := bLen - (P - bStart); - if C > 0 then - Move( bAddr^, Buffer, C ); - Result := C; - inc( Strm.fData.fPosition, C ); -end; - -function SeekMemBlkStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -var P: Integer; -begin - P := MoveTo; - CASE MoveFrom OF - spCurrent: P := P + Integer( Strm.fData.fPosition ); - spEnd: P := P + Integer( Strm.fData.fSize ); - END; - if P < 0 then P := 0; - if P > Integer( Strm.fData.fSize ) then - P := Strm.fData.fSize; - Strm.fData.fPosition := P; - Result := P; -end; - -function WriteMemBlkStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var LastBlkAddr: PByte; - LastBlkUsed, C: Integer; - NewBlkSz: Integer; -begin - C := Strm.fData.fBlocks.Count; - LastBlkUsed := Strm.fData.fBlkSize; - LastBlkAddr := nil; - if C > 1 then - begin - LastBlkAddr := Strm.fData.fBlocks.Items[C-2]; - LastBlkUsed := Integer( Strm.fData.fBlocks.Items[C-1] ); - end; - if Strm.fData.fBlkSize - LastBlkUsed < Integer( Count ) then - begin - NewBlkSz := Strm.fData.fBlkSize; - if NewBlkSz < Integer( Count ) then - NewBlkSz := Count; - GetMem( LastBlkAddr, NewBlkSz ); - LastBlkUsed := 0; - Strm.fData.fBlocks.Add( LastBlkAddr ); - Strm.fData.fBlocks.Add( nil ); - inc( C, 2 ); - end; - inc( LastBlkAddr, LastBlkUsed ); - Strm.fData.fJustWrittenBlkAddress := LastBlkAddr; - Move( Buffer, LastBlkAddr^, Count ); - inc( LastBlkUsed, Count ); - Strm.fData.fBlocks.fItems[ C-1 ] := Pointer( LastBlkUsed ); - inc( Strm.fData.fSize, Count ); - Strm.fData.fPosition := Strm.fData.fSize; - Result := Count; -end; - -procedure ResizeMemBlkStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -var i, del: Integer; - LastBlkAddr: PByte; - LastBlkUsed: Integer; -begin - while Strm.fData.fSize > NewSize do - begin - i := Strm.fData.fBlocks.Count-2; - LastBlkAddr := Strm.fData.fBlocks.fItems[i]; - LastBlkUsed := Integer( Strm.fData.fBlocks.fItems[i+1] ); - del := Strm.fData.fSize - NewSize; - if del >= LastBlkUsed then - begin - FreeMem( LastBlkAddr ); - Strm.fData.fBlocks.DeleteRange( i, 2 ); - dec( Strm.fData.fSize, LastBlkUsed ); - end else - begin - Strm.fData.fBlocks.fItems[ i+1 ] := Pointer( LastBlkUsed - del ); - dec( Strm.fData.fSize, del ); - end; - end; - if Strm.fData.fSize > Strm.fData.fPosition then - Strm.fData.fPosition := Strm.fData.fSize; -end; - -procedure FreeMemBlkStream( Strm: PStream ); -var i: Integer; -begin - i := 0; - while i < Strm.fData.fBlocks.Count do - begin - FreeMem( Strm.fData.fBlocks.fItems[i] ); - inc( i, 2 ); - end; - {$IFDEF SAFE_CODE} - Free_And_Nil( Strm.fData.fBlocks ); - Strm.fData.fPosition := 0; - Strm.fData.fSize := 0; - {$ELSE} - Strm.fData.fBlocks.Free; - {$ENDIF} -end; - -function SeekConcatStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -var NewPos: TStrmSize; -begin - NewPos := MoveTo; - CASE MoveFrom OF - spCurrent: NewPos := TStrmMove( Strm.fData.fPosition ) + MoveTo; - spEnd : NewPos := TStrmMove( Strm.Size ) + MoveTo; - END; - if Strm.fData.fStream1.Size > NewPos then - begin - Strm.fData.fStream1.Position := NewPos; - Strm.fData.fStream2.Position := 0; - end else - begin - Strm.fData.fStream1.Position := Strm.fData.fStream1.Size; - Strm.fData.fStream2.Position := NewPos - Strm.fData.fStream1.Size; - end; - Strm.fData.fPosition := Strm.fData.fStream1.Position + Strm.fData.fStream2.Position; - Result := Strm.fData.fPosition; -end; - -function GetSizeConcatStream( Strm: PStream ): TStrmSize; -begin - Result := Strm.fData.fStream1.Size + Strm.fData.fStream2.Size; -end; - -procedure SetSizeConcatStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -var New_Sz, Sz1: TStrmSize; -begin - New_Sz := NewSize; - Sz1 := Strm.fData.fStream1.Size; - if New_Sz < Sz1 then - New_Sz := Sz1; - Strm.fData.fStream2.Size := New_Sz - Sz1; -end; - -function ReadConcatStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var C, Sz1, ToRead: TStrmSize; - ToAddr: PByte; -begin - C := Count; - Sz1 := Strm.fData.fStream1.Size; - ToAddr := @ Buffer; - Result := 0; - if Strm.Position < Sz1 then - begin - ToRead := C; - if Strm.Position + C > Sz1 then - ToRead := Sz1 - Strm.Position; - Result := Strm.fData.fStream1.Read( ToAddr^, ToRead ); - Strm.fData.fPosition := Strm.fData.fStream1.Position; - dec( C, Result ); - inc( ToAddr, Result ); - if Result < ToRead then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Strm.fData.fStream2.Position := 0; - end; - if C <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Result + Strm.fData.fStream2.Read( ToAddr^, C ); - Strm.fData.fPosition := Strm.fData.fStream1.Size + - Strm.fData.fStream2.Position; -end; - -function WriteConcatStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var C, Sz1, ToWrite: TStrmSize; - FromAddr: PByte; -begin - C := Count; - Sz1 := Strm.fData.fStream1.Size; - FromAddr := @ Buffer; - Result := 0; - if Strm.Position < Sz1 then - begin - ToWrite := C; - if Strm.Position + C > Sz1 then - ToWrite := Sz1 - Strm.Position; - Result := Strm.fData.fStream1.Write( FromAddr^, ToWrite ); - Strm.fData.fPosition := Strm.fData.fStream1.Position; - dec( C, Result ); - inc( FromAddr, Result ); - if Result < ToWrite then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Strm.fData.fStream2.Position := 0; - end; - if C <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Result + Strm.fData.fStream2.Write( FromAddr^, C ); - Strm.fData.fPosition := Strm.fData.fStream1.Size + - Strm.fData.fStream2.Position; -end; - -procedure CloseConcatStream( Strm: PStream ); -begin - Strm.fData.fStream1.fMethods.fClose( Strm.fData.fStream1 ); - Strm.fData.fStream2.fMethods.fClose( Strm.fData.fStream2 ); -end; - -function SeekSubStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} MoveTo: TStrmMove; MoveFrom: TMoveMethod ): TStrmSize; -var NewPos, OldPos: TStrmMove; -begin - OldPos := Strm.fData.fBaseStream.Position - Strm.fData.fFromPos; - {$IFDEF STREAM_LARGE64} - if OldPos < 0 then OldPos := 0; - {$ENDIF} - CASE MoveFrom OF - spCurrent: NewPos := OldPos + MoveTo; - spEnd : NewPos := TStrmMove( Strm.Size ) + MoveTo; - else NewPos := MoveTo; - END; - {$IFDEF STREAM_LARGE64} - if NewPos < 0 then NewPos := 0; - {$ENDIF} - Strm.fData.fBaseStream.Position := Strm.fData.fFromPos + TStrmSize( NewPos ); - Result := Strm.fData.fBaseStream.Position - Strm.fData.fFromPos; - if Result > Strm.fData.fSize then - Strm.fData.fSize := Result; -end; - -function GetSizeSubStream( Strm: PStream ): TStrmSize; -begin - Result := Strm.fData.fSize; -end; - -procedure SetSizeSubStream( Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} NewSize: TStrmSize ); -begin - {$IFDEF STREAM_LARGE64} - if NewSize >= 0 then - {$ENDIF} - Strm.fData.fSize := NewSize; -end; - -function ReadSubStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var C: TStrmSize; -begin - C := Count; - if Strm.Position + C > Strm.Size then - C := Strm.Size - Strm.Position; - Result := Strm.fData.fBaseStream.Read( Buffer, C ); -end; - -function WriteSubStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := Strm.fData.fBaseStream.Write( Buffer, Count ); -end; - -procedure CloseSubStream( Strm: PStream ); -begin - Strm.fData.fBaseStream.fMethods.fClose( Strm.fData.fBaseStream ); -end; - - -function NewFileStream( const FileName: KOLString; Options: DWORD ): PStream; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fRead := ReadFileStreamProc; - Result.fMethods.fWrite := WriteFileStream; // not WriteStreamEOF, Алексей Шувалов - Result.fMethods.fSetSiz := SetSizeFileStream; - Result.fData.fHandle := FileCreate( FileName, Options ); -end; - -function NewFileStreamWithEvent( const FileName: KOLString; Options: DWORD ): PStream; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fRead := ReadFileStreamWithEvent; - Result.fMethods.fWrite := WriteFileStreamWithEvent; // not WriteStreamEOF, Алексей Шувалов - Result.fMethods.fSetSiz := SetSizeFileStream; - Result.fData.fHandle := FileCreate( FileName, Options ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewReadFileStream( const FileName: KOLString ): PStream; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fRead := ReadFileStreamProc; - Result.fData.fHandle := FileCreate( FileName, - ofOpenRead or ofShareDenyWrite or ofOpenExisting ); -end; -{$ENDIF PAS_VERSION} - -function NewReadFileStreamWithEvent( const FileName: KOLString ): PStream; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fRead := ReadFileStreamWithEvent; - Result.fData.fHandle := FileCreate( FileName, - ofOpenRead or ofShareDenyWrite or ofOpenExisting ); -end; - -function NewExFileStream( F: HFile ): PStream; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fRead := ReadFileStreamProc; - Result.fMethods.fWrite := WriteFileStream; - Result.fData.fHandle := F; - Result.fMethods.fClose := DummyCloseStream; -end; - -{$IFDEF _D3orHigher} -function NewReadFileStreamW( const FileName: KOLWideString ): PStream; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fRead := ReadFileStreamProc; - Result.fData.fHandle := WFileCreate( FileName, - ofOpenRead or ofShareDenyWrite or ofOpenExisting ); -end; -{$ENDIF _D3orHigher} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewWriteFileStream( const FileName: KOLString ): PStream; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fWrite := WriteFileStreamEOF; - Result.fMethods.fSetSiz := SetSizeFileStream; - Result.fData.fHandle := FileCreate( FileName, - ofOpenWrite or ofCreateAlways or ofShareDenyWrite ); -end; -{$ENDIF PAS_VERSION} - -function NewWriteFileStreamWithEvent( const FileName: KOLString ): PStream; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fWrite := WriteFileStreamEOFWithEvent; - Result.fMethods.fSetSiz := SetSizeFileStream; - Result.fData.fHandle := FileCreate( FileName, - ofOpenWrite or ofCreateAlways or ofShareDenyWrite ); -end; - -{$IFDEF _D3orHigher} -function NewWriteFileStreamW( const FileName: KOLWideString ): PStream; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fWrite := WriteFileStreamEOF; - Result.fMethods.fSetSiz := SetSizeFileStream; - Result.fData.fHandle := WFileCreate( FileName, - ofOpenWrite or ofCreateAlways or ofShareDenyWrite ); -end; -{$ENDIF _D3orHigher} - -{$IFDEF ASM_noVERSION} -function NewReadWriteFileStream( const FileName: AnsiString ): PStream; -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, offset[BaseFileMethods] - CALL _NewStream - MOV EDX, [ReadFileStreamProc] - MOV [EAX].TStream.fMethods.fRead, EDX - MOV [EAX].TStream.fMethods.fWrite, offset[WriteFileStream] - MOV [EAX].TStream.fMethods.fSetSiz, offset[SetSizeFileStream] - XCHG EBX, EAX - - PUSH EAX - CALL FileExists - MOV EDX, ofOpenReadWrite or ofCreateAlways or ofShareDenyWrite - ADD DH, AL // $200 (ofCreateAlways) -> $300 (ofCreateExisting) - POP EAX - - CALL FileCreate - MOV [EBX].TStream.fData.fHandle, EAX - XCHG EAX, EBX - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function NewReadWriteFileStream( const FileName: KOLString ): PStream; -var Creation: DWORD; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fRead := ReadFileStreamProc; - Result.fMethods.fWrite := WriteFileStream; - Result.fMethods.fSetSiz := SetSizeFileStream; - Creation := ofCreateAlways; - if FileExists( FileName ) then Creation := ofOpenExisting; - Result.fData.fHandle := FileCreate( FileName, - ofOpenReadWrite or Creation or ofShareDenyWrite ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF _D3orHigher} -function NewReadWriteFileStreamW( const FileName: KOLWideString ): PStream; -var Creation: DWORD; -begin - Result := _NewStream( BaseFileMethods ); - Result.fMethods.fRead := ReadFileStreamProc; - Result.fMethods.fWrite := WriteFileStream; - Result.fMethods.fSetSiz := SetSizeFileStream; - Creation := ofCreateAlways; - if WFileExists( FileName ) then Creation := ofOpenExisting; - Result.fData.fHandle := WFileCreate( FileName, - ofOpenReadWrite or Creation or ofShareDenyWrite ); -end; -{$ENDIF _D3orHigher} - -function NewMemoryStream: PStream; -begin - Result := _NewStream( MemoryMethods ); -end; - -function NewMemoryStreamWithEvent: PStream; -begin - Result := _NewStream( MemoryMethods ); - Result.fMethods.fRead := ReadMemStreamWithEvent; - Result.fMethods.fWrite := WriteMemStreamWithEvent; -end; - -{$IFDEF ASM_STREAM} -function WriteExMemoryStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -asm - PUSH EBX - XCHG EBX, EAX - MOV EAX, [EBX].TStream.fData.fSize - SUB EAX, [EBX].TStream.fData.fPosition - CMP EAX, ECX - JGE @@1 - XCHG ECX, EAX -@@1: - PUSH EDX - PUSH ECX - JLE @@count_ok - XCHG EDX, EAX - MOV EAX, EBX - CALL TStream.SetSize -@@count_ok: - POP ECX - POP EAX - MOV EDX, [EBX].TStream.fMemory - ADD EDX, [EBX].TStream.fData.fPosition - PUSH ECX - CALL System.Move - POP EAX - ADD [EBX].TStream.fData.fPosition, EAX - POP EBX -end; -{$ELSE PAS_VERSION} -function WriteExMemoryStream( Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var S: PStream; - C: TStrmSize; -begin - S := Strm; - C := Count; - if C + S.fData.fPosition > S.fData.fSize then - C := S.fData.fSize - S.fData.fPosition; - Result := C; - Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result ); - Inc( S.fData.fPosition, Result ); -end; -{$ENDIF PAS_VERSION} - -procedure DummyClose_ExMemStream( Strm: PStream ); -begin - // nothing to do - ignore call (memory is not released by any way) -end; - -function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream; -begin - Result := NewMemoryStream; - Result.fMemory := ExistingMem; - Result.fData.fCapacity := Size; - Result.fData.fSize := Size; - Result.fMethods.fWrite := WriteExMemoryStream; - Result.fMethods.fSetSiz := DummySetSize; - Result.fMethods.fClose := DummyClose_ExMemStream; -end; - -function NewMemBlkStream( BlkSize: Integer ): PStream; -begin - Result := NewMemoryStream; - Result.fData.fBlkSize := BlkSize; - Result.fData.fBlocks := NewList; - Result.fMethods.fWrite := WriteMemBlkStream; - Result.fMethods.fSetSiz := DummySetSize; - Result.fMethods.fClose := DummyClose_ExMemStream; - Result.fMethods.fRead := ReadMemBlkStream; - Result.fMethods.fSeek := SeekMemBlkStream; - Result.fMethods.fSetSiz := ResizeMemBlkStream; - Result.Add2AutoFreeEx( TObjectMethod( MakeMethod( Result, @FreeMemBlkStream ) ) ); -end; - -function NewMemBlkStream_WriteOnly( BlkSize: Integer ): PStream; -begin - Result := NewMemoryStream; - Result.fData.fBlkSize := BlkSize; - Result.fData.fBlocks := NewList; - Result.fMethods.fWrite := WriteMemBlkStream; - Result.fMethods.fSetSiz := DummySetSize; - Result.fMethods.fClose := DummyClose_ExMemStream; - Result.fMethods.fRead := DummyReadWrite; - Result.fMethods.fSeek := DummySeek; - Result.fMethods.fSetSiz := ResizeMemBlkStream; - Result.Add2AutoFreeEx( TObjectMethod( MakeMethod( Result, @FreeMemBlkStream ) ) ); -end; - -function NewConcatStream( Stream1, Stream2: PStream ): PStream; -begin - Result := _NewStream( ConcatStreamMethods ); - Result.fData.fStream1 := Stream1; - Result.fData.fStream2 := Stream2; - Result.Add2AutoFree( Stream1 ); - Result.Add2AutoFree( Stream2 ); -end; - -function NewSubStream( BaseStream: PStream; const FromPos, Size: TStrmSize ): PStream; -begin - Result := _NewStream( SubStreamMethods ); - Result.fData.fBaseStream := BaseStream; - Result.fData.fFromPos := FromPos; - Result.fData.fSize := Size; - Result.Position := 0; - Result.Add2AutoFree( BaseStream ); -end; - -function Stream2Stream( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -var Buf: Pointer; - C: TStrmSize; -begin - C := Count; - if Src.fMemory <> nil then - begin - if Src.fData.fPosition + C > Src.fData.fSize then - C := Src.fData.fSize - Src.fData.fPosition; - Result := Dst.Write( Pointer(DWORD(Src.fMemory)+Src.fData.fPosition)^, - C ); - Inc( Src.fData.fPosition, Result ); - end else - if Dst.fMemory <> nil then - begin - if Dst.fData.fPosition + C > Dst.fData.fSize then - Dst.SetSize( Dst.fData.fPosition + C ); - Result := Src.Read( Pointer( DWORD( Dst.fMemory ) + Dst.fData.fPosition )^, - C ); - Inc( Dst.fData.fPosition, Result ); - end else - begin - GetMem( Buf, C ); - C := Src.Read( Buf^, C ); - Result := Dst.Write( Buf^, C ); - FreeMem( Buf ); - end; -end; - -function Stream2StreamEx( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize ): TStrmSize; -begin - Result := Stream2StreamExBufSz( Dst, Src, Count, 65536 ); -end; - -function Stream2StreamExBufSz( Dst, Src: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize; BufSz: DWORD ): TStrmSize; -var - buf:pointer; - rd, wr:dword; - C: TStrmSize; -begin - C := Count; - if C=0 then result:=0 - else begin - result:=0; - BufSz := Min( BufSz, C ); - if BufSz = 0 then BufSz := C; - getmem(buf,BufSz); - repeat - if CBufSz) or (C=0); - freemem(buf); - end; -end; - -{$IFDEF ASM_UNICODE} - {$IFNDEF STREAM_LARGE64} - {$DEFINE ASM_Resource2Stream} - {$ENDIF} -{$ENDIF} - -{$IFDEF ASM_Resource2Stream} -function Resource2Stream( DestStrm : PStream; Inst : HInst; - ResName : PAnsiChar; ResType : PAnsiChar ): Integer; -asm - PUSH EBX - PUSH ESI - MOV EBX, EDX // EBX = Inst - PUSH EAX // DestStrm - PUSH ResType - PUSH ECX - PUSH EDX - CALL FindResource - TEST EAX, EAX - JZ @@exit0 - - PUSH EAX - PUSH EBX - PUSH EAX - PUSH EBX - CALL SizeofResource - XCHG EBX, EAX - CALL LoadResource - TEST EAX, EAX - JZ @@exit0 - XCHG ESI, EAX - - PUSH ESI - CALL GlobalLock - TEST EAX, EAX - JNZ @@P_ok - - CALL GetLastError - CMP EAX, ERROR_INVALID_HANDLE - JNZ @@exit_00 - MOV EAX, ESI - -@@P_ok: - XCHG EDX, EAX - POP EAX // DestStrm - PUSH EDX - MOV ECX, EBX - CALL TStream.Write - - //EAX = Result (length of written data) - XCHG EBX, EAX - POP EAX - CMP ESI, EAX - JE @@not_unlock - - PUSH ESI - CALL GlobalUnlock -@@not_unlock: - XCHG EAX, EBX - JMP @@exit - -@@exit_00: - XOR EAX, EAX -@@exit0: - POP ECX -@@exit: - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function Resource2Stream( DestStrm : PStream; Inst : HInst; - ResName : PKOLChar; ResType : PKOLChar ): Integer; -var R : HRSRC; - G : HGlobal; - P : PAnsiChar; - Sz : DWORD; - E : Integer; -begin - Result := 0; - R := FindResource( Inst, ResName, ResType ); - if R <> 0 then - begin - Sz := SizeofResource( Inst, R ); - G := LoadResource( Inst, R ); - if G <> 0 then - begin - P := GlobalLock( G ); - if P = nil then - begin - E := GetLastError; - if E = ERROR_INVALID_HANDLE then - P := Pointer( G ) - else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := DestStrm.Write( P^, Sz ); - if P <> Pointer( G ) then - GlobalUnlock( G ); - //FreeResource( G ); -- not necessary for resource loaded by LoadResource - end; - end; -end; -{$ENDIF PAS_VERSION} - -/////////////////////////////////////////////////////////////////////////// -// I N I - F I L E S -/////////////////////////////////////////////////////////////////////////// - -{ TIniFile } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TIniFile.Destroy; -begin - fFileName := ''; - fSection := ''; - inherited; -end; -{$ENDIF PAS_VERSION} - -procedure TIniFile.ClearAll; -begin - WritePrivateProfileString( nil, nil, nil, - PKOLChar( fFileName ) ); -end; - -procedure TIniFile.ClearKey(const Key: KOLString); -begin - WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ), nil, - PKOLChar( fFileName ) ); -end; - -procedure TIniFile.ClearSection; -begin - WritePrivateProfileString( PKOLChar( fSection ), nil, nil, - PKOLChar( fFileName ) ); -end; - -function TIniFile.ValueBoolean(const Key: KOLString; Value: Boolean): Boolean; -var sec: PKOLChar; -begin - sec := PKOLChar( fSection ); - if fSection = '' then - sec := nil; - if fMode = ifmRead then - Result := GetPrivateProfileInt( sec, PKOLChar( Key ), - Integer( Value ), PKOLChar( fFileName ) ) <> 0 - else - begin - WritePrivateProfileString( sec, PKOLChar( Key ), - PKOLChar( KOLString( Int2Str( Integer( Value ) ) ) ), - PKOLChar( fFileName ) ); - Result := Value; - end; -end; - -function TIniFile.ValueData(const Key: KOLString; Value: Pointer; - Count: Integer): Boolean; -begin - if fMode = ifmRead then - Result := GetPrivateProfileStruct( PKOLChar( fSection ), PKOLChar( Key ), - Value, Count, PKOLChar( fFileName ) ) - else Result := WritePrivateProfileStruct( PKOLChar( fSection ), PKOLChar( Key ), - Value, Count, PKOLChar( fFileName ) ); -end; - -function TIniFile.ValueInteger(const Key: KOLString; Value: Integer): Integer; -begin - if fMode = ifmRead then - Result := GetPrivateProfileInt( PKOLChar( fSection ), PKOLChar( Key ), - Integer( Value ), PKOLChar( fFileName ) ) - else - begin - Result := Value; - WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ), - PKOLChar( KOLString( Int2Str( Value ) ) ), PKOLChar( fFileName ) ); - end; -end; - -function TIniFile.ValueString(const Key, Value: KOLString): KOLString; -var - Buffer: array[0..4095] of KOLChar; -begin - if fMode = ifmRead then - begin - Buffer[ 0 ] := #0; - if GetPrivateProfileString(PKOLChar(fSection), - PKOLChar(Key), PKOLChar(Value), Buffer, SizeOf(Buffer) div Sizeof(KOLChar), - PKOLChar(fFileName)) <> 0 then - Result := Buffer - else Result := ''; //: FPC выдает ошибку при отсутствии Key в INI-файле // MTsv DN - end else - begin - Result := Value; - WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ), - PKOLChar( Value ), PKOLChar( fFileName ) ); - end; -end; - -function TIniFile.ValueDouble(const Key: KOLString; const Value: Double): Double; -begin - Result := Str2Double( ValueString( Key, Double2Str( Value ) ) ); -end; - -function OpenIniFile( const FileName: KOLString ): PIniFile; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TIniFile'; - {$ENDIF} - Result.fFileName := FileName; -end; - -/////////////////////////////////////////////////// GetSectionNames, SectionData -// - by Vyacheslav A. Gavrik : - -const - IniBufferSize = 32767; - IniBufferStrSize = IniBufferSize+4; /// для махинаций :) - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure TIniFile.GetSectionNames(Names:PKOLStrList); -var - i:integer; - Pc:PKOLChar; - PcEnd:PKOLChar; - Buffer:Pointer; -begin - GetMem(Buffer,IniBufferSize * Sizeof( KOLChar )); - Pc:=Buffer; - i := GetPrivateProfileSectionNames(Buffer, IniBufferSize, PKOLChar(fFileName)); - PcEnd:=Pc+i; - repeat - Names.Add(Pc); - Pc:=PC+Length(PC)+1; - until PC>=PcEnd; - FreeMem(Buffer); -end; - -procedure TIniFile.SectionData(Names: PKOLStrList); -var - i:integer; - Pc:PKOLChar; - PcEnd:PKOLChar; - Buffer:Pointer; -begin - GetMem(Buffer,IniBufferSize * Sizeof(KOLChar)); - Pc:=Buffer; - if fMode = ifmRead then - begin - i:=GetPrivateProfileSection(PKOLChar(fSection), Buffer, IniBufferSize, PKOLChar(fFileName)); - PcEnd:=Pc+i; - while PC < PcEnd do // Chg by ECM from REPEAT-UNTIL: i=0 (empty section) => Names.Count=1 - begin - Names.Add(Pc); - Pc:=PC+Length(PC)+1; - end; - end else - begin - for i:= 0 to Names.Count-1 do - begin - {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF} - (Pc,Names.ItemPtrs[i]); - Pc:=PC+Length(PC)+1; - end; - Pc[0]:=#0; - ClearSection; - WritePrivateProfileSection(PKOLChar(fSection), Buffer, PKOLChar(fFileName)); - - end; - FreeMem(Buffer); -end; -{$ENDIF PAS_VERSION} - -///////////////////////////////////////////////////////////////////////// -// M E N U -///////////////////////////////////////////////////////////////////////// - -{ -- Menu implementation -- } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator; -begin - Result.fVirt := fVirt; - Result.Key := Key; -end; -{$ENDIF PAS_VERSION} - -function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLString; -var - KeyName: array[0..255] of KOLChar; - - procedure AddKeyName( Code: Integer ); - begin - Code := MapVirtualKey(Code, 0); - if Code = 0 then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if GetKeyNameText(Code shl 16, KeyName, 256) > 0 then begin - if Result <> '' then - Result := Result + '+'; - Result := Result + KOLString(KeyName); - end; - end; - -begin - Result := ''; - with Accelerator do begin - if fVirt and FCONTROL <> 0 then - AddKeyName(VK_CONTROL); - if fVirt and FSHIFT <> 0 then - AddKeyName(VK_SHIFT); - if fVirt and FALT <> 0 then - AddKeyName(VK_ALT); - if fVirt and $20 <> 0 then - AddKeyName(VK_LWIN); - if fVirt and $40 <> 0 then - AddKeyName(VK_RWIN); - - AddKeyName(Key); - end; -end; - -const - MIDATA_CHECKITEM = $40000000; - MIDATA_RADIOITEM = $80000000; - - -{$IFNDEF NEW_MENU_ACCELL} -function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -var M, M1: PMenu; - Idx: Integer; - Id: Integer; -begin - Result := False; - if Msg.message = WM_COMMAND then - begin - if (Msg.lParam = 0) and (HIWORD( Msg.wParam ) <= 1) then - begin - M := PMenu( Sender.fMenuObj ); - while (M = nil) and (Sender.Parent <> nil) do - begin - Sender := Sender.Parent; - M := PMenu( Sender.fMenuObj ); - end; - while M <> nil do - begin - Id := LoWord( Msg.wParam ); - M1 := M.Items[ Id ]; - if M1 <> nil then - begin - Result := True; - Rslt := 0; - Idx := M.IndexOf( M1 ); - M.fByAccel := HiWord( Msg.wParam ) <> 0; - if M1.FRadioGroup <> 0 then - M1.RadioCheckItem - else if M1.FIsCheckItem then - M1.Checked := not M1.Checked; - if Assigned(M1.FOnMenuItem) then - M1.FOnMenuItem( M, Idx ) - else if Assigned( M.FOnMenuItem ) then - M.FOnMenuItem( M, Idx ); - break; - end; - M := M.fNextMenu; - end; - end; - end; -end; - -{$ELSE} - -function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; - - function ProcessMenuItem(M: PMenu; Id: Integer): Boolean; - var - M1: PMenu; - Idx: Integer; - begin - M1 := M.Items[ Id ]; - Result := (M1 <> nil); - if Result then - begin - Idx := M.IndexOf( M1 ); - M.fByAccel := HiWord( Msg.wParam ) <> 0; - if M1.FRadioGroup <> 0 then - M1.RadioCheckItem - else if M1.FIsCheckItem then - M1.Checked := not M1.Checked; - if Assigned(M1.FOnMenuItem) then - begin - {$IFDEF USE_MENU_CURCTL} - M.fCurCtl := Sender; // fixed - {$ENDIF} - M1.FOnMenuItem( M, Idx ) - end else if Assigned( M.FOnMenuItem ) then - M.FOnMenuItem( M, Idx ); - end; - end; - -var - M: PMenu; - Id: Integer; -begin - Result := False; - if Msg.message = WM_COMMAND then - if (Msg.lParam = 0) and (HIWORD( Msg.wParam ) <= 1) then begin - Id := LoWord(Msg.wParam); - M := PMenu(Sender.fAutoPopupMenu); - if (M <> nil) and ProcessMenuItem(M, Id) then begin - Result := True; - Rslt := 0; - end else - begin - M := PMenu(Sender.fMenuObj); - while M <> nil do begin - if ProcessMenuItem(M, Id) then begin - Result := True; - Rslt := 0; - Break; - end; - M := M.fNextMenu; - end; - end; - end; -end; -{$ENDIF} - -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -function NewMenu( AParent : PControl; MaxCmdReserve : DWORD; - const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu; -var M: PMenu; - {$IFDEF INITIALFORMSIZE_FIXMENU} - R: TRect; - {$ENDIF} -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TMenu'; - {$ENDIF} - Result.FVisible := TRUE; - Result.FPopupFlags := TPM_LEFTALIGN or TPM_LEFTBUTTON; - Result.FMenuItems := NewList; - Result.FOnMenuItem := aOnMenuItem; - if (High(Template)>=0) and (Template[0] <> nil) then - begin - if (AParent <> nil) and (AParent.fMenuObj = nil) and - {$IFDEF USE_FLAGS} not (G3_IsControl in AParent.fFlagsG3) - {$ELSE} not AParent.fIsControl {$ENDIF} then - Result.FHandle := CreateMenu - else Result.FHandle := CreatePopupMenu; - Result.FillMenuItems( Result.FHandle, 0, Template ); - end; - if ( AParent <> nil ) then - begin - Result.FControl := AParent; - if AParent.fMenuObj <> nil then - begin - // add popup menu to the end of menu chain - M := PMenu( AParent.fMenuObj ); - while M.fNextMenu <> nil do - M := M.fNextMenu; - M.fNextMenu := Result; - end else - begin - if {$IFDEF USE_FLAGS} not(G3_IsControl in AParent.fFlagsG3) - {$ELSE} not AParent.fIsControl {$ENDIF} then - begin - {$IFDEF INITIALFORMSIZE_FIXMENU} - R := AParent.ClientRect; - {$ENDIF} - AParent.Menu := Result.FHandle; - {$IFDEF INITIALFORMSIZE_FIXMENU} - AParent.SetClientSize( R.Right, R.Bottom ); - {$ENDIF} - end; - AParent.fMenuObj := Result; - AParent.AttachProc( WndProcMenu ); - {$IFDEF USE_AUTOFREE4CONTROLS} - AParent.Add2AutoFree( Result ); - {$ENDIF} - end; - end; -end; -{$ENDIF GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -//--- some code from samples - may be useful to see "how to" -FUNCTION AddSeparatorToMenu( Menu : PGtkMenu ) : PgtkMenuItem ; -BEGIN - Result := PGtkMenuitem( gtk_menu_item_new ) ; - gtk_menu_append( GTK_WIDGET( Menu ), PGtkWidget( Result ) ) ; - gtk_widget_show( PGtkWidget ( Result ) ) ; -END; - -FUNCTION AddItemToMenu( Menu : PGtkMenu; - ShortCuts : PGtkAccelGroup; - const Caption : AnsiString; - const ShortCut : AnsiString; - CallBack : TGtkSignalFunc; - CallBackdata : Pointer ) : PGtkMenuItem; -VAR - Key, Modifiers : DWORD; - //LocalAccelGroup : PGtkAccelGroup; -- not used since gtk_menu_ensure_uline_accel_group not defined anywhere... - TheLabel : PGtkLabel; -BEGIN - Result := PGtkMenuItem ( gtk_menu_item_new_with_label( '' ) ) ; - TheLabel := GTK_LABEL(GTK_BIN( Result )^.child ) ; - Key:= gtk_label_parse_uline( TheLabel , Pchar ( Caption ) ) ; - //---------------- - {If Key<>0 then // gtk_menu_ensure_uline_accel_group -- not defined anywhere... - begin - LocalAccelGroup := gtk_menu_ensure_uline_accel_group( Menu ); - gtk_widget_add_accelerator( PGtkWidget ( Result ), 'activateitem', - LocalAccelGroup , Key , - 0 , TGtkAccelFlags ( 0 ) ) ; - end;} - //----------------- - gtk_menu_append( GTK_WIDGET( Menu ), PGtkWidget( Result ) ) ; - //----------------- - IF ( ShortCut<>'' ) AND ( ShortCuts<> Nil ) THEN - BEGIN - gtk_accelerator_parse ( pchar( ShortCut ) , @key , @modifiers ) ; - gtk_widget_add_accelerator ( PGtkWidget ( Result ) , ' activateitem' , - ShortCuts, Key, modifiers, GTK_ACCEL_VISIBLE ); - END; - //------------------ - IF Assigned( CallBack ) THEN - BEGIN - gtk_signal_connect( PGtkObject ( Result ) , 'activate' , - CallBack , CallBackdata ) ; - gtk_widget_show( PgtkWidget ( Result ) ) ; - END; -END; - -FUNCTION AddMenuToMenuBar( MenuBar : PGtkMenuBar; - ShortCuts : PGtkAccelGroup; - Caption : AnsiString; - CallBack : TGtkSignalFunc; - CallBackdata : Pointer; - AlignRight : Boolean; - Var MenuItem : PgtkMenuItem ) : PGtkMenu; -VAR Key : DWORD; - TheLabel : PGtkLabel; -BEGIN - MenuItem := PGtkMenuItem( gtk_menu_item_new_with_label( '' ) ) ; - IF AlignRight THEN - gtk_menu_item_right_justify( MenuItem ); - TheLabel := GTK_LABEL( GTK_BIN( MenuItem )^ .child ) ; - Key := gtk_label_parse_uline( TheLabel, Pchar ( Caption ) ) ; - IF Key<>0 THEN - gtk_widget_add_accelerator( PGtkWidget( MenuItem ), 'activateitem', - Shortcuts, Key, GDK_MOD1_MASK, GTK_ACCEL_LOCKED ); - Result := PGtkMenu( gtk_menu_new ); - If Assigned( CallBack ) then - gtk_signal_connect( PGtkObject ( Result ), 'activate', - CallBack, CallBackdata ) ; - gtk_widget_show( PgtkWidget ( MenuItem ) ) ; - gtk_menu_item_set_submenu( MenuItem, PGtkWidget( Result ) ) ; - gtk_menu_bar_append( GTK_WIDGET( MenuBar ), PgtkWidget( MenuItem ) ) ; -END; - -FUNCTION NewMenu( AParent : PControl; MaxCmdReserve : DWORD; - CONST Template : ARRAY of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu; - PROCEDURE CreateMenuItems( ParentMenu: PMenu; var i: Integer ); - VAR Item, PrevItem: PMenu; - s: AnsiString; - j: Integer; - BEGIN - PrevItem := nil; - WHILE i <= High( Template )-1 DO - BEGIN - inc( i ); - s := Template[ i ]; - IF s = '' THEN BREAK; // end of template - - IF s = ')' THEN - inc( i ); break; // end of submenu - - new( Item, Create ); - {$IFDEF DEBUG_OBJKIND} - Item.fObjKind := 'MenuItem'; - {$ENDIF} - Item.FCaption := s; - Item.FVisible := TRUE; - Item.FParentMenu := ParentMenu; - if ParentMenu.FItems = nil then - ParentMenu.FItems := NewList; - ParentMenu.FItems.Add( Item ); - - IF (s <> '') AND ((s[ 1 ] = '+') or (s[ 1 ] = '-')) THEN - BEGIN - Item.fIsCheckItem := TRUE; - Item.fChecked := S[ 1 ] = '+'; - s := CopyEnd( s, 2 ); - IF (s <> '') and (s[ 1 ] = '!') THEN - BEGIN - IF PrevItem <> nil THEN - BEGIN - if PrevItem.fRadioGroup <> 0 THEN - Item.fRadioGroup := PrevItem.fRadioGroup; - END - ELSE inc( Item.fRadioGroup ); - s := CopyEnd( s, 2 ); - END; - END; - - IF s = '-' THEN - Item.fIsSeparator := TRUE - ELSE - BEGIN - FOR j := Length( s )-1 DOWNTO 1 DO // extract mnemonic - BEGIN - IF (s[ j ] = '&') and (s[ j+1 ] <> '&') then // mnemonic - BEGIN - Item.fMnemonics := Item.fMnemonics + s[ j+1 ]; - Delete( s, j, 1 );//? m ? - END; - END; - END; - - //---------------------------- now call gtk for create item's widget - IF Item.FIsSeparator THEN - Item.fGtkMenuItem := gtk_menu_item_new - ELSE Item.fGtkMenuItem := gtk_menu_item_new_with_label( PAnsiChar( s ) ); - IF ParentMenu.fGtkMenuBar <> nil THEN - gtk_menu_bar_append( ParentMenu.fGtkMenuBar, Item.fGtkMenuItem ) - ELSE gtk_menu_shell_append( - GTK_MENU_SHELL( ParentMenu.fGtkMenuShell ), Item.fGtkMenuItem ); - - IF s = '(' THEN - BEGIN - inc( i ); - IF PrevItem <> nil THEN - BEGIN - PrevItem.fGtkMenuShell := gtk_menu_new; - gtk_menu_item_set_submenu( - GTK_MENU_ITEM( PrevItem.fGtkMenuItem ), - PrevItem.fGtkMenuShell ); - CreateMenuItems( PrevItem, i ); - END; - END; - - PrevItem := Item; - END; - END; -VAR i: Integer; -BEGIN - new( Result, Create ); - i := -1; - IF AParent.fMenuObj = nil THEN - BEGIN // создается главное меню с линейкой меню (наверху формы? любого контрола?) - AParent.fMenuObj := Result; - Result.fGtkMenuBar := gtk_menu_bar_new; - //AParent.fMenuBar := Result.fGtkMenuBar; - gtk_container_add( GTK_CONTAINER( AParent.fClient ), Result.fGtkMenuBar ); - gtk_widget_show( Result.fGtkMenuBar ); - END else - BEGIN - PMenu( AParent.fMenuObj ).fNextMenu := Result; - Result.fGtkMenuShell := gtk_menu_new; - END; - CreateMenuItems( Result, i ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -function NewMenuEx( AParent : PControl; FirstCmd : Integer; - const Template : array of PKOLChar; aOnMenuItems: array of TOnMenuItem ): PMenu; -begin - Result := NewMenu( AParent, FirstCmd, Template, nil ); - {$IFDEF GDI} - Result.AssignEvents( 0, aOnMenuItems ); - {$ENDIF GDI} -end; - -{$IFDEF WIN_GDI} -{ TMenu } - -const - Breaks: array[ TMenuBreak ] of DWORD = ( 0, MFT_MENUBREAK, MFT_MENUBARBREAK ); - -{ + by AK - Andrzej Kubaszek } -function MenuStructSize: Integer; -begin - Result := 44; - if not( WinVer in [wv31, wv95, wvNT] ) then - Result := {48=} Sizeof( TMenuItemInfo ); -end; -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -destructor TMenu.Destroy; -var Next, Prnt: PMenu; -begin - {$IFDEF DEBUG_MENU_DESTROY} - LogFileOutput( GetStartDir + 'TMenu.Destroy.txt', - Int2Hex( DWORD( @ Self ), 6 ) + ' ' + Int2Str( RefCount ) ); - {$ENDIF} - if Count > 0 then - begin - FMenuItems.ReleaseObjects; - FMenuItems := NewList; - end; - if FParentMenu <> nil then - begin - Prnt := FParentMenu; - Next := Prnt.RemoveSubMenu( FId ); - FParentMenu := nil; - Prnt.FMenuItems.Remove( @ Self ); - if Next = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if (FControl <> nil) and (FControl.fMenu = FHandle) and (FHandle <> 0) then - begin - if {$IFDEF USE_FLAGS} not (G2_Destroying in FControl.fFlagsG2) - {$ELSE} not FControl.fDestroying {$ENDIF} then //!!!fix by Galkov - begin - Windows.SetMenu( FControl.fHandle, 0 ); - // this removes main menu from window, but does not destroy it - end; - FControl.fMenu := 0; - Next := PMenu( FControl.fMenuObj ); - while Next <> nil do - begin - if Next.fNextMenu = @Self then - begin - Next.fNextMenu := fNextMenu; - break; - end; - Next := Next.fNextMenu; - end; - end; - Next := fNextMenu; - if FBitmap <> 0 then - Bitmap := 0; - if FHandle <> 0 then - begin - //if not - DestroyMenu( FHandle ) - // then LogFileOutput( GetStartDir + 'err.log.txt', SysErrorMessage( GetLastError ) ) - ; - end; - FCaption := ''; - FMenuItems.Free; - Next.Free; - inherited; - // all later created (popup) menus (of the same control) - // are destroyed too -end; -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -DESTRUCTOR TMenu.Destroy; -//var Next, Prnt: PMenu; -BEGIN - {$IFDEF DEBUG_MENU_DESTROY} - LogFileOutput( GetStartDir + 'TMenu.Destroy.txt', - Int2Hex( DWORD( @ Self ), 6 ) + ' ' + Int2Str( RefCount ) ); - {$ENDIF} - //if Count > 0 then - IF ( fMenuItems <> nil ) THEN - BEGIN - FMenuItems.ReleaseObjects; - FMenuItems := NewList; - END; - FCaption := ''; - fMnemonics := ''; - FMenuItems.Free; - INHERITED; - // all later created (popup) menus (of the same control) - // are destroyed too -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -function TMenu.GetInfo( var MII: TMenuItemInfo ): Boolean; -begin - MII.cbSize := MenuStructSize; - Result := GetMenuItemInfo( Parent.FHandle, FId, FALSE, - Windows.PMenuitemInfo( @ MII )^ ); -end; - -procedure TMenu.RedrawFormMenuBar; -var C: PControl; -begin - C := TopParent.FControl; - if not AppletTerminated then - if (C <> nil) and (Pointer( C.fMenuObj ) = Pointer( TopParent )) then - DrawMenuBar( C.FHandle ); -end; - -function TMenu.SetInfo( var MII: TMenuItemInfo ): Boolean; -var H: THandle; -begin - MII.cbSize := MenuStructSize; - H := FHandle; - if FParentMenu <> nil then - H := FParentMenu.FHandle; - {$IFNDEF UNICODE_CTRLS} - Result := SetMenuItemInfo( H, FId, FALSE, Windows.PMenuitemInfo( @ MII )^ ); - {$ELSE} - Result := SetMenuItemInfoW( H, FId, FALSE, Windows.PMenuitemInfoW( @ MII )^ ); - {$ENDIF} - if Result and ((FParentMenu = nil) or (FParentMenu.FParentMenu = nil)) then {YS} - RedrawFormMenuBar; -end; - -function TMenu.SetTypeInfo( var MII: TMenuItemInfo ): Boolean; -begin - if not FIsSeparator then - begin - if FBmpItem = 0 then - MII.dwTypeData := PKOLChar( FCaption ) - else MII.dwTypeData := Pointer( FBmpItem ); - MII.cch := Length( FCaption )*SizeOfKOLChar; - end; - Result := SetInfo( MII ); -end; - -function TMenu.GetTopParent: PMenu; -begin - Result := @ Self; - while Result.FParentMenu <> nil do - Result := Result.FParentMenu; -end; - -function TMenu.GetControl: PControl; -begin - Result := TopParent.FControl; -end; - -function TMenu.GetItems( Id: HMenu ): PMenu; - function SearchItems( ParentMenu: PMenu; var FromIdx: Integer ): PMenu; - var I: Integer; - begin - Result := ParentMenu; - if Id = HMenu( FromIdx ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (Id >= 4096) and (DWORD( ParentMenu.FId ) = Id) then Exit; {>>>>>>>>>>>>} - if ParentMenu.FMenuItems = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - for I := 0 to ParentMenu.FMenuItems.FCount-1 do - begin - Inc( FromIdx ); - Result := SearchItems( ParentMenu.FMenuItems.Items[ I ], FromIdx ); - if Result <> nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := nil; - end; -var I: Integer; -begin - I := -1; - Result := SearchItems( @ Self, I ); -end; - -function TMenu.GetCount: Integer; -var I: Integer; - SubM: PMenu; -begin - Result := FMenuItems.FCount; - for I := 0 to Result-1 do - begin - SubM := FMenuItems.Items[ I ]; - Result := Result + SubM.Count; - end; -end; - -function TMenu.IndexOf( Item: PMenu ): Integer; - function SearchMenu( ParentMenu: PMenu; var FromIdx: Integer ): PMenu; - var I: Integer; - begin - Result := ParentMenu; - if Result = Item then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - for I := 0 to ParentMenu.FMenuItems.FCount-1 do - begin - Inc( FromIdx ); - Result := SearchMenu( ParentMenu.FMenuItems.Items[ I ], FromIdx ); - if Result <> nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := nil; - end; -begin - Result := -1; - if SearchMenu( @ Self, Result ) = nil then - Result := -2; -end; - -function TMenu.GetState( const Index: Integer ): Boolean; -var MII: TMenuItemInfo; -begin - if FVisible then - begin - MII.fMask := MIIM_STATE; - if GetInfo( MII ) then - FSavedState := MII.fState; - end; - Result := LongBool( FSavedState and Index ); - if Index < 0 then - Result := not Result; -end; - -procedure TMenu.SetState( const Index: Integer; Value: Boolean ); -var MII: TMenuItemInfo; -begin - GetState( 0 ); - if Value xor (Index < 0) then - FSavedState := FSavedState or DWORD( Index and $7FFFFFFF ) - else FSavedState := FSavedState and not DWORD( Index ); - if FVisible then - begin - MII.fMask := MIIM_STATE; - if GetInfo( MII ) then - begin - MII.fState := FSavedState; - SetInfo( MII ); - end; - end; -end; - -procedure TMenu.SetData( Value: Pointer ); -var MII: TMenuItemInfo; -begin - MII.fMask := MIIM_DATA; - MII.dwItemData := DWORD( Value ); - SetInfo( MII ); - FData := Value; -end; - -procedure TMenu.ClearBitmaps; -begin - if FBitmap <> 0 then - DeleteObject( FBitmap ); - if FBmpChecked <> 0 then - DeleteObject( FBmpChecked ); - if FBmpItem <> 0 then - DeleteObject( FBmpItem ); -end; - -procedure TMenu.SetBitmap( Value: HBitmap ); -var MII: TMenuItemInfo; -begin - if not FClearBitmaps then - begin - FClearBitmaps := TRUE; - Add2AutoFreeEx( ClearBitmaps ); - end; - if Value = FBitmap then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if FBitmap <> 0 then - DeleteObject( FBitmap ); // seems not necessary. - FBitmap := Value; - MII.fMask := MIIM_CHECKMARKS; - MII.hbmpChecked := FBmpChecked; - MII.hbmpUnchecked := FBitmap; - SetInfo( MII ); -end; - -procedure TMenu.SetBmpChecked( Value: HBitmap ); -var MII: TMenuItemInfo; -begin - if not FClearBitmaps then - begin - FClearBitmaps := TRUE; - Add2AutoFreeEx( ClearBitmaps ); - end; - if Value = FBmpChecked then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if FBmpChecked <> 0 then - DeleteObject( FBmpChecked ); - FBmpChecked := Value; - MII.fMask := MIIM_CHECKMARKS; - MII.hbmpChecked := FBmpChecked; - MII.hbmpUnchecked := FBitmap; - SetInfo( MII ); -end; - -procedure TMenu.SetBmpItem( Value: HBitmap ); -var MII: TMenuItemInfo; -begin - if not FClearBitmaps then - begin - FClearBitmaps := TRUE; - Add2AutoFreeEx( ClearBitmaps ); - end; - if Value = FBmpItem then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if FBmpItem <> 0 then - DeleteObject( FBmpItem ); - FBmpItem := Value; - if WinVer >= wv98 then {AK} - begin {AK} - MII.fMask := $80 {MIIM_BITMAP} ; {AK} - MII.hbmpItem:=Value; {AK} - end else {AK} - begin//I haven't possibility to test it in Win95 {AK} - MII.fType := MFT_BITMAP; - MII.dwItemData := Value; - end; {AK} - SetInfo( MII ); -end; - -{$IFNDEF NEW_MENU_ACCELL} -procedure TMenu.SetAccelerator(const Value: TMenuAccelerator); -const MaxAccel = 1000; -type TAccTab = array[0..10000] of TAccel; - PAccTab = ^TAccTab; -var AccTab: PAccTab; - I, N : Integer; - M, SubM: PMenu; - C: PControl; - Main: Boolean; -begin - if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FAccelerator := Value; - C := TopParent.FControl; - if C = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if C.fAccelTable <> 0 then - DestroyAcceleratorTable( C.fAccelTable ); - C.fAccelTable := 0; - GetMem( AccTab, sizeof( TAccel ) * MaxAccel ); - N := 0; - M := PMenu( C.fMenuObj ); - Main := TRUE; - while M <> nil do - begin - if Main or M.Visible then - begin - for I := 0 to MaxInt-1 do - begin - SubM := M.Items[ I ]; - if SubM = nil then break; - if SubM.FVisible then - if (SubM.FAccelerator.Key <> 0) or (SubM.FAccelerator.fVirt <> 0) then - begin - AccTab[ N ].fVirt := SubM.FAccelerator.fVirt; - AccTab[ N ].key := SubM.FAccelerator.Key; - AccTab[ N ].cmd := WORD( SubM.FId ); - Inc( N ); - if N > MaxAccel then break; - end; - end; - end; - if N > MaxAccel then break; - M := M.fNextMenu; - end; - if N > 0 then - begin - C.fAccelTable := CreateAcceleratorTable( AccTab[ 0 ], N ); - {$IFDEF USE_AUTOFREE4CONTROLS} - C.Add2AutoFreeEx( C.DoDestroyAccelTable ); - {$ENDIF} - C := C.ParentForm; - if C <> nil then - C.SupportMnemonics; - end; - FreeMem( AccTab ); -end; - -{$ELSE NEW_MENU_ACCELL} - -procedure TMenu.SetAccelerator(const Value: TMenuAccelerator); -var C: PControl; - M: PMenu; -begin - if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FAccelerator := Value; - C := FControl; - M := @Self; - while (C = nil) and (M <> nil) do begin - M := M.Parent; - if (M <> nil) then C := M.FControl; - end; - if C <> nil then C.SupportMnemonics; -end; - -{$ENDIF NEW_MENU_ACCELL} - -procedure TMenu.SetMenuItemCaption( const Value: KOLString ); -var MII: TMenuItemInfo; -begin - FCaption := Value; - if FParentMenu = nil then Exit; {+ecm} {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} -{AK}if not (WinVer in [wv95,wvNT]) then -{AK} MII.fMask := $40 {MIIM_STRING} -{AK}else begin - MII.fMask := MIIM_TYPE; - MII.fType := MFT_STRING; -{AK}end; - MII.cch := 0; // to fix turning radio mark to check mark in NT4 - GetInfo( MII ); //----------------------------------------------- - MII.dwTypeData := PKOLChar( Value ); - MII.cch := Length( Value )*SizeOfKOLChar; - SetInfo( MII ); -end; - -procedure TMenu.SetMenuBreak( Value: TMenuBreak ); -var MII: TMenuItemInfo; -begin - if FId = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if FMenuBreak = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FMenuBreak := Value; - //FillChar( MII, Sizeof( MII ), #0 ); - ZeroMemory( @MII, Sizeof( MII ) ); - MII.fMask := MIIM_TYPE; - MII.dwTypeData := nil; - if GetInfo( MII ) then - begin - MII.fType := MII.fType and not( MFT_MENUBREAK or MFT_MENUBARBREAK ) or - Breaks[ Value ]; - SetTypeInfo( MII ); - end; -end; - -procedure TMenu.SetMenuVisible( Value: Boolean ); -var I, J: Integer; - M: PMenu; - Before: Integer; - ByPosition: Boolean; - MII: TMenuItemInfo; -begin - if Value then - if FParentMenu <> nil then - FParentMenu.Visible := TRUE; - if Value = FVisible then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FVisible := Value; - if (FControl <> nil) and (FControl.fMenuObj = @ Self) then - begin - FControl.GetWindowHandle; - if Value then - SetMenu( FControl.fHandle, FHandle ) - else - SetMenu( FControl.fHandle, 0 ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if FId = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if FParentMenu = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Value then - begin // show menu item inserting it again into appropriate position - Before := -1; - ByPosition := TRUE; - I := FParentMenu.FMenuItems.IndexOf( @ Self ); - for J := I + 1 to FParentMenu.FMenuItems.FCount-1 do - begin - M := FParentMenu.FMenuItems.Items[ J ]; - if M.FVisible then - begin - Before := M.FId; - ByPosition := FALSE; - break; - end; - end; - ZeroMemory( @MII, Sizeof( MII ) ); - MII.cbSize := MenuStructSize; - MII.fMask := MII.fMask or - (MIIM_CHECKMARKS or MIIM_ID or MIIM_STATE or MIIM_TYPE); - MII.fType := Breaks[ FMenuBreak ]; - MII.fState := FSavedState; - MII.wID := FId; - MII.dwItemData := DWORD( FData ); - if not FIsSeparator then - begin - //MII.fType := MII.fType or MFT_STRING { = 0 }; - MII.dwTypeData := PKOLChar( FCaption ); - MII.cch := Length( FCaption )*SizeOfKOLChar; - end else - MII.fType := MII.fType or MFT_SEPARATOR; - if FRadioGroup <> 0 then - MII.fType := MII.fType or MFT_RADIOCHECK; - if FOwnerDraw then - MII.fType := MII.fType or MFT_OWNERDRAW; - if FBitmap <> 0 then - begin - MII.fMask := MII.fMask or MIIM_CHECKMARKS; - MII.hbmpUnchecked := FBitmap; - end; - if FHandle <> 0 then - begin - MII.fMask := MII.fMask or MIIM_SUBMENU; - MII.hSubMenu := FHandle; - end; - {$IFNDEF UNICODE_CTRLS} - InsertMenuItem( FParentMenu.FHandle, Before, ByPosition, - Windows.PMenuitemInfo( @ MII )^ ); - {$ELSE} - InsertMenuItemW( FParentMenu.FHandle, Before, ByPosition, - Windows.PMenuitemInfoW( @ MII )^ ); - {$ENDIF} - end else - begin // hide menu item removing it - GetState( 0 ); // store menu item state in FSavedState to allow - // changing its state while it is not attached to - // a menu - RemoveMenu( TopParent.FHandle, FId, MF_BYCOMMAND ); - end; - if (FControl <> nil) or (FParentMenu <> nil) and (FParentMenu.FControl <> nil) then - RedrawFormMenuBar; -end; - -procedure TMenu.RadioCheckItem; -var I, J: Integer; - M, First, Last: PMenu; -begin - if (FParentMenu <> nil) and (FRadioGroup <> 0) then - begin - I := FParentMenu.FMenuItems.IndexOf( @ Self ); - if I >= 0 then - begin - First := @ Self; - Last := @ Self; - for J := I-1 downto 0 do - begin - M := FParentMenu.FMenuItems.Items[ J ]; - if M.FRadioGroup <> FRadioGroup then break; - if M.FVisible then - First := M; - end; - for J := I+1 to FParentMenu.FMenuItems.FCount-1 do - begin - M := FParentMenu.FMenuItems.Items[ J ]; - if M.FRadioGroup <> FRadioGroup then break; - if M.FVisible then - Last := M; - end; - if First <> Last then - begin - CheckMenuRadioItem( FParentMenu.FHandle, First.FId, Last.FId, - FId, MF_BYCOMMAND ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; - Checked := TRUE; -end; - -function TMenu.FillMenuItems(AHandle: HMenu; StartIdx: Integer; - const Template: array of PKOLChar): Integer; -var S, S1: PKOLChar; - I: Integer; - MII: TMenuItemInfo; - Item, PrevItem: PMenu; -begin - PrevItem := nil; - I := StartIdx; - while I <= High( Template ) do - begin - S := Template[ I ]; - if (S = nil) or (S^ = #0) then break; - {$IFDEF UNICODE_CTRLS} - if KOLString( S ) = {$IFDEF F_P}'' +{$ENDIF} ')' then - {$ELSE} - if PWORD(S)^ = WORD(')') then - {$ENDIF} - begin - Result := I + 1; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - - new( Item, Create ); - {$IFDEF DEBUG_OBJKIND} - Item.fObjKind := 'MenuItem'; - {$ENDIF} - Item.FVisible := TRUE; - Item.FParentMenu := @ Self; - Item.FMenuItems := NewList; - FMenuItems.Add( Item ); - - ZeroMemory( @MII, Sizeof( MII ) ); - MII.cbSize := MenuStructSize; - MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE; - {$IFDEF UNICODE_CTRLS} - if KOLString( S ) <> {$IFDEF F_P}'' +{$ENDIF} '-' then - {$ELSE} - if PWORD(S)^ <> WORD('-') then - {$ENDIF} - begin - if (S^ = {$IFDEF F_P}'' +{$ENDIF} '-') or - (S^ = {$IFDEF F_P}'' +{$ENDIF} '+') then - begin - Item.FIsCheckItem := TRUE; - MII.dwItemData := MIDATA_CHECKITEM; - if S^ <> {$IFDEF F_P}'' +{$ENDIF} '-' then - MII.fState := MII.fState or MFS_CHECKED; - Inc( S ); - if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then - begin - MII.fType := MII.fType or MFT_RADIOCHECK; - MII.dwItemData := MII.dwItemData or MIDATA_RADIOITEM; - Inc( S ); - if PrevItem <> nil then - begin - if PrevItem.FRadioGroup <> 0 then - Item.FRadioGroup := PrevItem.FRadioGroup; - end; - if Item.FRadioGroup = 0 then - Inc( Item.FRadioGroup ); - if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then - begin - Inc( S ); - Inc( Item.FRadioGroup ); - end; - end; - end; - Item.FCaption := S; - end - else - begin - Item.FIsSeparator := TRUE; - MII.fType := MFT_SEPARATOR; - MII.fState := MFS_GRAYED; - //MII.wID := 0; - end; - Item.FId := FDynamicMenuID; - Inc( FDynamicMenuID ); - MII.wID := Item.FId; - if I <> High( Template ) then //YS - begin //YS - S1 := Template[ I + 1 ]; - {$IFDEF UNICODE_CTRLS} - if KOLString( S1 ) = {$IFDEF F_P}'' +{$ENDIF} '(' then - {$ELSE} - if (S1 <> nil) and (PWORD(S1)^ = WORD('(')) then - {$ENDIF} - Item.FHandle := CreatePopupMenu; - end; //YS - MII.hSubMenu := Item.FHandle; - MII.dwTypeData := PKOLChar( S ); - MII.cch := {$IFDEF UNICODE_CTRLS} WStrLen( S ) {$ELSE} StrLen( S ) {$ENDIF}; - InsertMenuItem( AHandle, DWORD(-1), True, PMenuitemInfo( @ MII )^ ); - if Item.FHandle <> 0 then - I := Item.FillMenuItems( Item.FHandle, I + 2, Template ) - else - Inc( I ); - PrevItem := Item; - end; - Result := I; -end; - -procedure TMenu.AssignEvents(StartIdx: Integer; - const Events: array of TOnMenuItem); -var I: Integer; - M: PMenu; -begin - for I := 0 to High(Events) do - begin - M := Items[ StartIdx ]; - if M = nil then break; - M.FOnMenuItem := Events[ I ]; - Inc( StartIdx ); - end; -end; - -function TMenu.Popup(X, Y: Integer): Integer; -begin - {$IFDEF GDI} - if Assigned( fOnPopup ) then fOnPopup( @Self ); - if not FNotPopup then - Result := Integer( TrackPopupMenu( FHandle, FPopupFlags, {*ecm} - X, Y, 0, FControl.Handle, nil ) ) {*ecm} - else Result := 0; {*ecm} - {$ENDIF GDI} -end; - -function TMenu.PopupEx( X, Y: Integer ): Integer; -{$IFDEF GDI} -var OldBounds: TRect; - WasVisible: Boolean; -{$ENDIF GDI} -begin - {$IFDEF GDI} - WasVisible := TRUE; - if FControl <> nil then - begin - OldBounds := FControl.BoundsRect; - if {$IFDEF USE_FLAGS} not(G3_IsControl in FControl.fFlagsG3) - {$ELSE} not FControl.fIsControl {$ENDIF} then - begin - WasVisible := FControl.Visible; - if not WasVisible then - FControl.Top := ScreenHeight + 50; - FControl.Show; - end; - end; - // -- by Martin Larsen: ----------------------- - FControl.ProcessMessage; // specific for Win9x! - Result := Popup( X, Y ); {*ecm} - if FControl <> nil then - begin - if FControl.Top = ScreenHeight + 50 then - begin - if not WasVisible then - FControl.Visible := FALSE; - FControl.BoundsRect := OldBounds; - end; - end; - {$ENDIF GDI} -end; - -function TMenu.GetItemChecked( Item : Integer ) : Boolean; -begin - Result := Items[ Item ].Checked; -end; - -procedure TMenu.SetItemChecked( Item : Integer; Value : Boolean ); -begin - Items[ Item ].Checked := Value; -end; - -function TMenu.GetMenuItemHandle( Idx : Integer ): DWORD; -begin - Result := Items[ Idx ].FId; -end; - -procedure TMenu.RadioCheck( Idx : Integer ); -begin - Items[ Idx ].RadioCheckItem; -end; - -function TMenu.GetItemBitmap(Idx: Integer): HBitmap; -begin - Result := Items[ Idx ].Bitmap; -end; - -procedure TMenu.SetItemBitmap(Idx: Integer; const Value: HBitmap); -begin - Items[ Idx ].Bitmap := Value; -end; - -procedure TMenu.AssignBitmaps(StartIdx: Integer; Bitmaps: array of HBitmap); -var I: Integer; -begin - for I := 0 to High(Bitmaps) do - ItemBitmap[ I + StartIdx ] := Bitmaps[ I ]; -end; - -function TMenu.GetItemText(Idx: Integer): KOLString; -begin - Result := Items[ Idx ].FCaption; -end; - -procedure TMenu.SetItemText(Idx: Integer; const Value: KOLString); -begin - Items[ Idx ].Caption := Value; -end; - -function TMenu.GetItemEnabled(Idx: Integer): Boolean; -begin - Result := Items[ Idx ].Enabled; -end; - -procedure TMenu.SetItemEnabled(Idx: Integer; const Value: Boolean); -begin - Items[ Idx ].Enabled := Value; -end; - -function TMenu.GetItemVisible(Idx: Integer): Boolean; -begin - Result := Items[ Idx ].Visible; -end; - -procedure TMenu.SetItemVisible(Idx: Integer; const Value: Boolean); -begin - Items[ Idx ].Visible := Value; -end; - -function TMenu.ParentItem( Idx: Integer ): Integer; -begin - Result := TopParent.IndexOf( Items[ Idx ].FParentMenu ); -end; - -function TMenu.GetItemAccelerator(Idx: Integer): TMenuAccelerator; -begin - Result := Items[ Idx ].Accelerator; -end; - -procedure TMenu.SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator); -begin - Items[ Idx ].Accelerator := Value; -end; - -function TMenu.GetItemSubMenu( Idx: Integer ): HMenu; -begin - Result := Items[ Idx ].SubMenu; -end; - -function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -forward; - -{$IFDEF GDI} -procedure TMenu.SetHelpContext( Value: Integer ); -var Form, C: PControl; -begin - if TopParent <> @ Self then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // Help context can not be associated with individual menu items - FHelpContext := Value; - C := FControl; - if C = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Form := C.ParentForm; - Form.AttachProc( WndProcHelp ); - SetMenuContextHelpID( FHandle, Value ); -end; -{$ENDIF GDI} - -procedure TMenu.SetSubmenu( Value: HMenu ); -var MII: TMenuItemInfo; -begin - MII.fMask := MIIM_SUBMENU; - MII.hSubMenu := Value; - SetInfo( MII ); - FHandle := Value; -end; - -function WndProcMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var MIS: PMeasureItemStruct; - M, SM: PMenu; - H, I: Integer; -begin - Result := FALSE; - if (Msg.message = WM_MEASUREITEM) and (Msg.wParam = 0) then - begin - MIS := Pointer( Msg.lParam ); - if MIS.CtlType = ODT_MENU then - begin - M := Pointer( Sender.fMenuObj ); - while M <> nil do - begin - SM := M.Items[ MIS.itemID ]; - if SM <> nil then - begin - Sender.CallDefWndProc( Msg ); - I := M.IndexOf( SM ); - if Assigned( SM.OnMeasureItem ) then - M := SM; - if not Assigned( M.OnMeasureItem ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - H := M.OnMeasureItem( M, I ); - if HiWord( H ) <> 0 then - MIS.itemWidth := HiWord( H ); - if LoWord( H ) <> 0 then - MIS.itemHeight := LoWord( H ); - Rslt := 1; - Result := TRUE; - break; - end; - M := M.fNextMenu; - end; - end; - end; -end; - -procedure TMenu.SetOnMeasureItem( const Value: TOnMeasureItem ); -var C: PControl; -begin - FOnMeasureItem := Value; - C := TopParent.FControl; - if C <> nil then - C.AttachProc( WndProcMeasureItem ); -end; - -function WndProcDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -type PDrawAction = ^TDrawAction; - PDrawState = ^TDrawState; -var DIS: PDrawItemStruct; - M, SM: PMenu; - I: Integer; -begin - Result := FALSE; - if (Msg.message = WM_DRAWITEM) and (Msg.wParam = 0) then - begin - DIS := Pointer( Msg.lParam ); - if DIS.CtlType = ODT_MENU then - begin - M := Pointer( Sender.fMenuObj ); - while M <> nil do - begin - SM := M.Items[ DIS.itemID ]; - if SM <> nil then - begin - I := M.IndexOf( SM ); - if Assigned( SM.OnDrawItem ) then - M := SM; - if Assigned( M.OnDrawItem ) then - begin - if not M.OnDrawItem( M, DIS.hDC, DIS.rcItem, I, - PDrawAction( @ DIS.itemAction )^, - PDrawState( @ DIS.itemState )^ ) then Exit; {>>>>>>>>} - end else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Rslt := 1; - Result := TRUE; - break; - end; - M := M.fNextMenu; - end; - end; - end; -end; - -procedure TMenu.SetOnDrawItem( const Value: TOnDrawItem ); -var C: PControl; -begin - FOnDrawItem := Value; - C := TopParent.FControl; - if C <> nil then - C.AttachProc( WndProcDrawItem ); -end; - -procedure TMenu.SetOwnerDraw( Value: Boolean ); -const Masks: array[ Boolean ] of DWORD = ( 0, $FFFFFFFF ); -var MII: TMenuItemInfo; -begin - FOwnerDraw := Value; - //FillChar( MII, Sizeof( MII ), #0 ); - ZeroMemory( @MII, Sizeof( MII ) ); - MII.fMask := MIIM_TYPE; - MII.dwTypeData := nil; - if GetInfo( MII ) then - begin - MII.fType := MII.fType and not MFT_OWNERDRAW or - (MFT_OWNERDRAW and Masks[ Value ]); - SetTypeInfo( MII ); - end; -end; - -function TMenu.Insert(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; - Options: TMenuOptions): PMenu; -const - MenuStateFlags: array[TMenuOption] of Integer = (MFS_DEFAULT, MFS_DISABLED, MFS_CHECKED, 0, 0, - MFS_DISABLED, 0, 0, 0, 0); - MenuTypeFlags: array[TMenuOption] of Integer = (0, 0, 0, 0, MFT_RADIOCHECK, MFT_SEPARATOR, MFT_BITMAP, 0, - MFT_MENUBREAK, MFT_MENUBARBREAK); -var M: PMenu; - MII: TMenuItemInfo; -begin - new( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TMenuItem'; - {$ENDIF} - Result.FVisible := TRUE; - Result.FParentMenu := @ Self; - Result.FMenuItems := NewList; - Result.FIsSeparator := moSeparator in Options; - Result.FIsCheckItem := moCheckMark in Options; //+ by shilou, 12/2009 - if FHandle = 0 then - SetSubMenu( CreatePopupMenu ); - M := nil; - if (InsertBefore >= 0) and (InsertBefore < 4096) then - begin - M := Items[ InsertBefore ]; - if M <> nil then - begin - InsertBefore := M.FId; - M.Parent.FMenuItems.Insert( M.Parent.FMenuItems.IndexOf( M ), Result ); - end; - end; - if M = nil then - begin - InsertBefore := -1; - FMenuItems.Add( Result ); - end; - Result.FOnMenuItem := Event; - - //FillChar( MII, Sizeof( MII ), #0 ); - ZeroMemory( @MII, Sizeof( MII ) ); - MII.cbSize := MenuStructSize; - MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE; - - MII.fState := MakeFlags( Pointer( @Options ), MenuStateFlags); - MII.fType := MakeFlags( Pointer( @Options ), MenuTypeFlags); - Result.FId := FDynamicMenuID; - Inc( FDynamicMenuID ); - MII.wID := Result.FId; - if moSubMenu in Options - then begin - Result.FHandle := CreatePopupMenu; - MII.hSubMenu := Result.FHandle; - end; - MII.dwTypeData := PKOLChar(ACaption); - {$IFNDEF UNICODE_CTRLS} - if not (moBitmap in Options) then MII.cch := StrLen( ACaption ); - {$ELSE} - if not (moBitmap in Options) then MII.cch := WStrLen( ACaption ); - {$ENDIF} - InsertMenuItem( FHandle, InsertBefore, InsertBefore = -1, - PMenuItemInfo( @ MII )^ ); - if moBitmap in Options then - begin - Result.BitmapItem := DWORD( ACaption ); - end - else - Result.FCaption := ACaption; - RedrawFormMenuBar; -end; - -function TMenu.AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer; -begin - Result := InsertItem( -1, ACaption, Event, Options ); -end; - -function TMenu.InsertItem( InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; - Options: TMenuOptions): Integer; -begin - Result := InsertItemEx( InsertBefore, ACaption, Event, Options, FALSE ); -end; - -function TMenu.InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar; - Event: TOnMenuItem; Options: TMenuOptions; ByPosition: Boolean): Integer; -var M: PMenu; -begin - M := Insert( InsertBefore, ACaption, Event, Options ); - Result := M.FId; -end; - -procedure TMenu.InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer ); -var AFlags: DWORD; - M: PMenu; - MII: TMenuItemInfo; -begin - if SubMenuToInsert.FParentMenu <> nil then - SubMenuToInsert := SubMenuToInsert.FParentMenu.RemoveSubMenu( SubMenuToInsert.FId ); - if SubMenuToInsert = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - - AFlags := MF_BYPOSITION; - M := nil; - if (InsertBefore >= 0) and (InsertBefore < 4096) then - begin - M := Items[ InsertBefore ]; - if M = nil then - InsertBefore := -1 - else - InsertBefore := M.FId; - end; - if M = nil then - begin - FMenuItems.Add( SubMenuToInsert ); - SubMenuToInsert.FParentMenu := @ Self; - end - else - begin - M.FParentMenu.FMenuItems.Insert( M.FParentMenu.FMenuItems.IndexOf( M ), SubMenuToInsert ); - SubMenuToInsert.FParentMenu := M.FParentMenu; - end; - - if InsertBefore > 0 then - AFlags := MF_BYCOMMAND; - if SubMenuToInsert.FBmpItem <> 0 then - InsertMenu( FHandle, InsertBefore, AFlags or MF_BITMAP or MF_POPUP, - SubMenuToInsert.FHandle, PKOLChar( SubMenuToInsert.FBmpItem ) ) - else - InsertMenu( FHandle, InsertBefore, AFlags or MF_STRING or MF_POPUP, - SubMenuToInsert.FHandle, PKOLChar( SubMenuToInsert.Caption ) ); - if SubMenuToInsert.FId = 0 then - begin - SubMenuToInsert.FId := FDynamicMenuID; - Inc( FDynamicMenuID ); - MII.cbSize := MenuStructSize; - MII.fMask := MIIM_ID; - MII.wID := SubMenuToInsert.FId; - {$IFNDEF UNICODE_CTRLS} - SetMenuItemInfo( SubMenuToInsert.FParentMenu.FHandle, - SubMenuToInsert.FParentMenu.FMenuItems.IndexOf( SubMenuToInsert ), - TRUE, Windows.PMenuItemInfo( @ MII )^ ); - {$ELSE} - SetMenuItemInfoW( SubMenuToInsert.FParentMenu.FHandle, - SubMenuToInsert.FParentMenu.FMenuItems.IndexOf( SubMenuToInsert ), - TRUE, Windows.PMenuItemInfoW( @ MII )^ ); - {$ENDIF} - end; - RedrawFormMenuBar; -end; - -function TMenu.RemoveSubMenu( ItemToRemove: Integer ): PMenu; -{$IFDEF DEBUG_MENU}var OK: Boolean; {$ENDIF} -var M: PMenu; -begin - Result := Items[ ItemToRemove ]; - if Result = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - M := Result.FParentMenu; - if M = nil then M := @Self; - {$IFDEF DEBUG_MENU} OK := {$ENDIF} - RemoveMenu( M.FHandle, Result.FId, MF_BYCOMMAND ); - M.FMenuItems.Remove( Result ); - {$IFDEF DEBUG_MENU} - if not OK then - ShowMessage( 'Error removing menu: ' + Int2Str( GetLastError ) + ' - ' + - SysErrorMessage( GetLastError ) ); - {$ENDIF} - if Count = 0 then - begin - Result.Free; - Result := nil; - end; - RedrawFormMenuBar; -end; - -function TMenu.GetItemHelpContext(Idx: Integer): Integer; -begin - Result := Items[ Idx ].HelpContext; -end; - -procedure TMenu.SetItemHelpContext(Idx: Integer; const Value: Integer); -begin - Items[ Idx ].HelpContext := Value; -end; - -procedure ClearText( Sender: PControl ); -begin - Sender.Caption := ''; -end; - -procedure ClearListbox( Sender: PControl ); -begin - Sender.Perform( LB_RESETCONTENT, 0, 0 ); -end; - -procedure ClearCombobox( Sender: PControl ); -begin - Sender.Perform( CB_RESETCONTENT, 0, 0 ); -end; - -procedure ClearListView( Sender: PControl ); -begin - Sender.Perform( LVM_DELETEALLITEMS, 0, 0 ); -end; - -procedure ClearToolbar( Sender: PControl ); -begin - while Sender.TBButtonCount > 0 do - Sender.TBDeleteButton( Sender.TBIndex2Item( 0 ) ); - Sender.Perform( TB_SETBITMAPSIZE, 0, 0 ); -end; - -{$ENDIF WIN_GDI} -{ -- Constructor of canvas -- } -function NewCanvas( DC: HDC ): PCanvas; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TCanvas'; - {$ENDIF} - {$IFDEF GDI} - Result.ModeCopy := cmSrcCopy; - if DC <> 0 then - begin - Result.SetHandle( DC ); - {//} Result.fIsAlienDC := True; - // When the Canvas will be destroyed, the DC will not be deleted - end; - {$ENDIF GDI} -end; - -{ -- Contructors of controls -- } - -{$IFDEF GDI} -{$IFDEF COMMANDACTIONS_OBJ} -function NewCommandActionsObj: PCommandActionsObj; -begin - new( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TCommandActionsObj'; - {$ENDIF} -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -function NewCommandActionsObj_Packed( fromPack: PAnsiChar ): PCommandActionsObj; -var Dest: PWord; - N, i: Integer; -begin - new( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TCommandActionsObj'; - {$ENDIF} - if Integer( fromPack ) < 120 then - begin - Result.fIndexInActions := Integer( fromPack ); Exit; {>>>>>>>>>>>>>>>>>} - end; - Result.fIndexInActions := Byte( fromPack^ ); - inc( fromPack ); - Dest := Pointer( @Result.aClick ); - N := 38; - while N > 0 do - begin - if Byte( fromPack^ ) < 200 then - begin - Dest^ := PWord( fromPack )^; - inc( Dest ); - inc( fromPack, 2 ); - dec( N ); - end - else - if Byte( fromPack^ ) = 200 then - begin - inc( fromPack ); - Dest^ := PWord( fromPack )^; - inc( Dest ); - inc( fromPack, 2 ); - dec( N ); - end - else - begin - i := Byte( fromPack^ ) - 200; - while i > 0 do - begin - Dest^ := 0; - inc( Dest ); - dec( i ); - dec( N ); - end; - inc( fromPack ); - end; - end; -end; -{$ENDIF PAS_VERSION} -{$ENDIF COMMANDACTIONS_OBJ} - -function DumpWindowed( c: PControl ): PControl; -var P: PByte; - i, j: Integer; - s, ss: KOLString; -begin - P := Pointer( c ); - ss := ''; - i := 0; - while i < Sizeof( TControl ) do - begin - s := Int2Hex( i, 3 ) + ':'; - for j := 0 to 15 do - begin - s := s + ' ' + Int2Hex( P^, 2 ); - inc( P ); - inc( i ); - if i >= Sizeof( TControl ) then break; - end; - ss := ss + s + #13#10; - end; - LogFileOutput( GetStartDir + 'DumpWindowed.txt', Int2Hex( Integer( c ), 8 ) + - #13#10 + ss ); - Result := c; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar; - Ctl3D: Boolean; ACommandActions: TCommandActionsParam ): PControl; -{$IFDEF COMMANDACTIONS_OBJ} -var IdxActions: Integer; -{$ENDIF} -begin - New( Result, CreateParented( AParent ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl'; - {$ENDIF} - {$IFDEF COMMANDACTIONS_OBJ} - if Integer( ACommandActions ) < 120 then - IdxActions := Integer( ACommandActions ) - else - IdxActions := PByte( ACommandActions )^; - if AllActions_Objs[IdxActions] <> nil then - begin - Result.fCommandActions := AllActions_Objs[IdxActions]; - Result.fCommandActions.RefInc; - end - else - begin - {$IFDEF PACK_COMMANDACTIONS} - Result.fCommandActions := NewCommandActionsObj_Packed( ACommandActions ); - AllActions_Objs[IdxActions] := Result.fCommandActions; - Result.fCommandActions.aClear := ClearText; - {$ELSE} - new( Result.fCommandActions, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fCommandActions.fObjKind := 'TCommandActionsObj'; - {$ENDIF} - AllActions_Objs[IdxActions] := Result.fCommandActions; - if ACommandActions <> nil then - Move( ACommandActions^, Result.fCommandActions.aClear, - Sizeof( TCommandActions ) ) - else - Result.fCommandActions.aClear := ClearText; - {$ENDIF} - end; - Result.Add2AutoFree( Result.fCommandActions ); - {$ELSE} - if ACommandActions <> nil then - Result.fCommandActions := ACommandActions^ - else - Result.fCommandActions.aClear := ClearText; - {$ENDIF} - //Result.fWindowed := TRUE; // is set in TControl.Init - Result.fControlClassName := ControlClassName; - if AParent <> nil then - begin - {$IFDEF WIN_GDI} - //{-2.95}Result.PP.fWndProcResizeFlicks := AParent.PP.fWndProcResizeFlicks; - {$ENDIF WIN_GDI} - Result.PP.fGotoControl := AParent.PP.fGotoControl; - Result.fCtl3D_child := AParent.fCtl3D_child and 2; - if AParent.fCtl3D_child and 2 <> 0 then - Result.fCtl3D_child := Result.fCtl3D_child or Integer( Ctl3D ) and 1 - {else - Result.fCtl3D := False}; // - Result.fMargin := AParent.fMargin; - Result.fTextColor := AParent.fTextColor; - {$IFDEF SMALLEST_CODE} - {$ELSE} - {$IFDEF WIN_GDI} // for now Font is complicated a bit, implement it later - Result.fFont := Result.fFont.Assign( AParent.fFont ); - if Result.fFont <> nil then - begin - {$IFDEF USE_AUTOFREE4CONTROLS} - Result.Add2AutoFree( Result.fFont ); - {$ENDIF USE_AUTOFREE4CONTROLS} - Result.fFont.fParentGDITool := AParent.fFont; - Result.fFont.fOnGTChange := Result.FontChanged; - Result.FontChanged( Result.fFont ); - end; - {$ENDIF WIN_GDI} - {$ENDIF SMALLEST_CODE} - Result.fColor := AParent.fColor; - {$IFDEF WIN_GDI} - Result.fBrush := Result.fBrush.Assign( AParent.fBrush ); - if Result.fBrush <> nil then - begin - {$IFDEF USE_AUTOFREE4CONTROLS} - Result.Add2AutoFree( Result.fBrush ); - {$ENDIF USE_AUTOFREE4CONTROLS} - Result.fBrush.fParentGDITool := AParent.fBrush; - Result.fBrush.fOnGTChange := Result.BrushChanged; - Result.BrushChanged( Result.fBrush ); - end; - {$ENDIF WIN_GDI} - end; - {$IFDEF DUMP_WINDOWED} - DumpWindowed( Result ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -VAR GTK_initialized: Boolean; - argc: Integer = 0; - -PROCEDURE FixedChildSetPos( Ctl, Chld: PControl; x, y: Integer ); -BEGIN - gtk_fixed_move( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y ); -END; - -PROCEDURE LayoutChildSetPos( Ctl, Chld: PControl; x, y: Integer ); -BEGIN - gtk_layout_move( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y ); -END; - -PROCEDURE FixedChildPut( Ctl, Chld: PControl; x, y: Integer ); -BEGIN - gtk_fixed_put( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y ); -END; - -PROCEDURE LayoutChildPut( Ctl, Chld: PControl; x, y: Integer ); -BEGIN - gtk_layout_put( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y ); -END; - -FUNCTION FixedClientArea( Ctl: PControl ): PGtkWidget; -BEGIN - IF Ctl.fClient = nil THEN - BEGIN - Ctl.fClient := gtk_fixed_new; - gtk_container_set_border_width(GTK_CONTAINER(Ctl.fHandle), 0); - gtk_container_add( GTK_CONTAINER( Ctl.fHandle ), Ctl.fClient ); - gtk_container_set_border_width(GTK_CONTAINER(Ctl.fClient), 0); - gtk_widget_show( Ctl.fClient ); - Ctl.fChildPut := FixedChildPut; - Ctl.fChildSetPos := FixedChildSetPos; - END; - Result := Ctl.fClient; -END; - -FUNCTION ClientAreaLayout( Ctl: PControl ): PGtkWidget; -BEGIN - IF Ctl.fClient = nil THEN - BEGIN - Ctl.fClient := gtk_layout_new( {hadjustment} nil, {vadjustment} nil ); - Ctl.fChildPut := LayoutChildPut; - Ctl.fChildSetPos := LayoutChildSetPos; - END; - Result := Ctl.fClient; -END; - -FUNCTION _NewWindowed( AParent: PControl; ControlClassName: PAnsiChar; - widget: PGtkWidget; need_eventbox: Boolean ): PControl; -//var GVal: TGValue; -BEGIN - (*if not GTK_initialized then - begin - GTK_initialized := TRUE; - gtk_init( @ argc, {@ argv} nil ); - end;*) - New( Result, CreateParented( AParent, widget, need_eventbox ) ); - //Result.fWindowed := TRUE; // is set in TControl.Init - //???//Result.fControlClassName := ControlClassName; - IF AParent <> nil THEN - BEGIN - Result.fGotoControl := AParent.fGotoControl; - Result.fMargin := AParent.fMargin; - Result.fTextColor := AParent.fTextColor; - {$IFDEF SMALLEST_CODE} - {$ELSE} - {$IFDEF WIN_GDI} // for now Font is complicated a bit, implement it later - Result.fFont := Result.fFont.Assign( AParent.fFont ); - IF Result.fFont <> nil THEN - begin - {$IFDEF USE_AUTOFREE4CONTROLS} - Result.Add2AutoFree( Result.fFont ); - {$ENDIF USE_AUTOFREE4CONTROLS} - Result.fFont.fParentGDITool := AParent.fFont; - Result.fFont.fOnGTChange := Result.FontChanged; - Result.FontChanged( Result.fFont ); - END; - {$ENDIF WIN_GDI} - {$ENDIF SMALLEST_CODE} - Result.fColor := AParent.fColor; - {$IFDEF WIN_GDI} - Result.fBrush := Result.fBrush.Assign( AParent.fBrush ); - IF Result.fBrush <> nil THEN - BEGIN - {$IFDEF USE_AUTOFREE4CONTROLS} - Result.Add2AutoFree( Result.fBrush ); - {$ENDIF USE_AUTOFREE4CONTROLS} - Result.fBrush.fParentGDITool := AParent.fBrush; - Result.fBrush.fOnGTChange := Result.BrushChanged; - Result.BrushChanged( Result.fBrush ); - END; - {$ENDIF WIN_GDI} - END; - Result.fGetClientArea := FixedClientArea; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -//===================== Form ========================// - -{$IFDEF USE_CONSTRUCTORS} -function NewForm( AParent: PControl; const Caption: AnsiString ): PControl; -begin - new( Result, CreateForm( AParent, Caption ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Form'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewForm( AParent: PControl; const Caption: KOLString ): PControl; -begin - Result := _NewWindowed( AParent, 'Form', True, - {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Form'; - {$ENDIF} - Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS; - Result.AttachProc( WndProcForm ); - Result.AttachProc( WndProcDoEraseBkgnd ); - Result.Caption := Caption; - {$IFDEF USE_FLAGS} Result.fFlagsG3 := Result.fFlagsG3 + [G3_SizeGrip, G3_IsForm]; - {$ELSE} - {$IFNDEF SMALLEST_CODE} - Result.fSizeGrip := TRUE; - {$ENDIF} - Result.fIsForm := TRUE; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -const Edgestyles: array[ TEdgeStyle ] of DWORD = ( WS_DLGFRAME, SS_SUNKEN, 0, 0, 0); - -function NewAlienPanel( AParentWnd: HWnd; EdgeStyle: TEdgeStyle ): PControl; -begin - Result := _NewWindowed( nil, 'KOL', TRUE, - {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS; - Result.FParentWnd := AParentWnd; - Result.AttachProc( WndProcForm ); - Result.AttachProc( WndProcDoEraseBkgnd ); - {$IFDEF USE_FLAGS} Result.fFlagsG3 := Result.fFlagsG3 + [G3_IsForm, G3_IsControl]; - {$ELSE} Result.fIsForm := TRUE; - Result.fIsControl := TRUE; - {$ENDIF} - Result.fStyle.Value := WS_VISIBLE or WS_CHILD or WS_TABSTOP or - WS_CLIPSIBLINGS or WS_CLIPCHILDREN or Edgestyles[ EdgeStyle ]; - Result.fExStyle := Result.fExStyle //or WS_EX_CLIENTEDGE - or WS_EX_CONTROLPARENT; - Result.SetSize( 100, 64 ); -end; - -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION getFormCaption(F: PControl): KOLString; -BEGIN - F.fCaption := gtk_window_get_title( GTK_WINDOW( F.fHandle ) ); - Result := F.fCaption; -END; - -PROCEDURE setFormCaption(F: PControl; const Value: KOLString); -BEGIN - F.fCaption := Value; - gtk_window_set_title( GTK_WINDOW( F.fCaptionHandle ), PAnsiChar( String( Value ) ) ); -END; - -PROCEDURE DestroyForm( Widget: PGtkWidget; Sender: PControl ); CDECL; -VAR Quit: Boolean; -BEGIN - Quit := Sender.IsMainWindow; - Sender.Free; - IF Quit THEN - gtk_main_quit(); -END; - -FUNCTION NewForm( AParent: PControl; const Caption: KOLString ): PControl; -VAR widget: PGtkWidget; -BEGIN - IF not GTK_initialized THEN - BEGIN - GTK_initialized := TRUE; - gtk_init( @ argc, {@ argv} nil ); - END; - widget := gtk_window_new( GTK_WINDOW_TOPLEVEL ); - Result := _NewWindowed( AParent, 'Form', widget, FALSE ); - Result.fGetCaption := getFormCaption; - Result.fSetCaption := setFormCaption; - Result.Caption := Caption; - {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsForm ); - {$ELSE} Result.fIsForm := TRUE; {$ENDIF} - gtk_signal_connect( Pointer( Result.fHandle ), 'destroy', - @ DestroyForm, Result ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$ENDIF USE_CONSTRUCTORS} - -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -//===================== Applet button ========================// - -//22{$IFDEF ASM_VERSION} -{$IFNDEF PAS_ONLY} - function WndProcAppAsm(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; - asm - CMP word ptr [EDX].TMsg.message, WM_SETFOCUS - JNZ @@chk_CLOSE - MOV ECX, [EAX].TControl.DF.FCurrentControl - JECXZ @@ret_false - XCHG EAX, ECX - PUSH EAX - CALL CallTControlCreateWindow - TEST AL, AL - POP EAX - JZ @@1 - PUSH [EAX].TControl.fHandle - CALL SetFocus - @@1: MOV AL, 1 - RET - @@chk_CLOSE: - CMP word ptr [EDX].TMsg.message, WM_SYSCOMMAND - JNZ @@ret_false - MOV EDX, dword ptr [EDX].TMsg.wParam - AND DX, $FFF0 - CMP DX, SC_CLOSE - JNZ @@ret_false - PUSH ECX - MOV ECX, [EAX].TControl.fChildren - JECXZ @@ret_false1 - XCHG EAX, ECX - MOV ECX, [EAX].TList.fCount - JECXZ @@ret_false1 - MOV EAX, [EAX].TList.fItems - MOV ECX, dword ptr [EAX] - JECXZ @@ret_false1 - XCHG EAX, ECX - PUSH EAX - CALL TControl.IsMainWindow - TEST EAX, EAX - POP EAX - JZ @@ret_false1 - CALL TControl.Close - POP ECX - XOR EAX, EAX - MOV dword ptr [ECX], EAX - INC EAX - JMP @@exit - @@ret_false1: - POP ECX - @@ret_false: - XOR EAX, EAX - @@exit: - end; -{$ENDIF not PAS_ONLY} -//22{$ENDIF} - -function WndProcAppPas(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -begin - Result := False; - case Msg.message of - WM_SETFOCUS: - {$IFDEF NEW_MODAL} - if Self_.DF.fModalForm <> nil then - SetFocus( Self_.DF.fModalForm.fHandle ) - else if ( Self_.DF.FCurrentControl <> nil ) and not - ( {$IFDEF USE_FLAGS} (G3_IsForm in Self_.DF.fCurrentControl.fFlagsG3) - {$ELSE} Self_.DF.fCurrentControl.fIsForm {$ENDIF} - xor - {$IFDEF USE_FLAGS} (G3_IsApplet in Self_.fFlagsG3) - {$ELSE} Self_.fIsApplet {$ENDIF} ) then - {$ELSE not_NEW_MODAL} - if Self_.DF.fCurrentControl <> nil then - {$ENDIF NEW_MODAL} - begin - if Self_.DF.FCurrentControl.CreateWindow then - SetFocus( Self_.DF.FCurrentControl.fHandle ); - Result := True; - end; - WM_SYSCOMMAND: - CASE Msg.wParam and $FFF0 OF - SC_CLOSE: - if (Self_.fChildren <> nil) and (Self_.fChildren.fCount > 0) and - PControl( Self_.fChildren.fItems[ 0 ] ).IsMainWindow then - begin - PControl( Self_.fChildren.fItems[ 0 ] ).Close; - Rslt := 0; - Result := TRUE; - end; - END; - end; -end; - -{$IFDEF USE_CONSTRUCTORS} -{$DEFINE CREATEAPPBUTTON_USED} -function NewApplet( const Caption: AnsiString ): PControl; -begin - new( Result, CreateApplet( Caption ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Applet'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_TLIST} -function NewApplet( const Caption: KOLString ): PControl; -const AppClass: array[ 0..3 ] of KOLChar = ( 'A', 'p', 'p', #0 ); -asm - XOR ECX, ECX - INC ECX - MOV [AppButtonUsed], CL - PUSH EAX - MOV EDX, offset[AppClass] - XOR EAX, EAX - PUSH EAX - CALL _NewWindowed - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG3, (1 shl G3_IsApplet) - {$ELSE} - INC [EAX].TControl.FIsApplet - {$ENDIF} - MOV word ptr [EAX].TControl.fStyle + 2, $90CA //WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX or WS_CAPTION - MOV byte ptr [EAX].TControl.fExStyle + 2, WS_EX_APPWINDOW shr 16 // WS_EX_APPWINDOW = $40000 - CALL @@newapp1 - - PUSH ESI // BODY of CreateAppButton here - PUSH 0 - PUSH [EAX].TControl.fHandle - CALL GetSystemMenu - MOV ESI, offset[DeleteMenu] - - XCHG ECX, EAX - MOV EAX, SC_MAXIMIZE - CDQ - - PUSH EDX - PUSH EAX - PUSH ECX - - PUSH EDX - {$IFDEF PARANOIA} DB $2C, $20 {$ELSE} SUB AL, $20 {$ENDIF} // SC_MOVE - PUSH EAX - PUSH ECX - - PUSH EDX - {$IFDEF PARANOIA} DB $2C, $10 {$ELSE} SUB AL, $10 {$ENDIF} // SC_SIZE - PUSH EAX - PUSH ECX - - PUSH 1 // MF_GRAYED or MF_BYCOMMAND - MOV AX, SC_RESTORE - PUSH EAX - PUSH ECX - - CALL EnableMenuItem - CALL ESI - CALL ESI - CALL ESI - POP ESI -@@ret_false: - XOR EAX, EAX - RET - -@@chk_CLOSE: - CMP word ptr [EDX].TMsg.message, WM_SYSCOMMAND - JNZ @@ret_false - MOV EDX, dword ptr [EDX].TMsg.wParam - AND DX, $FFF0 - CMP DX, SC_CLOSE - JNZ @@ret_false - PUSH ECX - MOV ECX, [EAX].TControl.fChildren - JECXZ @@ret_false1 - XCHG EAX, ECX - MOV ECX, [EAX].TList.fCount - JECXZ @@ret_false1 - MOV EAX, [EAX].TList.fItems - MOV ECX, dword ptr [EAX] - JECXZ @@ret_false1 - XCHG EAX, ECX - PUSH EAX - CALL TControl.IsMainWindow - TEST EAX, EAX - POP EAX - JZ @@ret_false1 - CALL TControl.Close - POP ECX - XOR EAX, EAX - MOV dword ptr [ECX], EAX - INC EAX - RET - @@ret_false1: - POP ECX - JMP @@ret_false - -@@newapp1: - POP [EAX].TControl.PP.FCreateWndExt - PUSH EAX - CALL @@newapp2 - - // BODY of WndProcApp here: - CMP word ptr [EDX].TMsg.message, WM_SETFOCUS - JNZ @@chk_CLOSE - MOV ECX, [EAX].TControl.DF.fCurrentControl - JECXZ @@ret_false - XCHG EAX, ECX - - PUSH EAX - CALL CallTControlCreateWindow - POP EAX - PUSH [EAX].TControl.fHandle - - CALL SetFocus - MOV AL, 1 - RET - -@@newapp2: - POP EDX - CALL TControl.AttachProc - POP EAX - POP EDX - PUSH EAX - CALL TControl.SetCaption - POP EAX -end; -{$ELSE PAS_VERSION} //Pascal - -procedure CreateAppButton( App: PControl ); -var M: HMenu; -begin - M := GetSystemMenu( App.fHandle, False ); - DeleteMenu( M, SC_MAXIMIZE, MF_BYCOMMAND ); - DeleteMenu( M, SC_MOVE, MF_BYCOMMAND ); - DeleteMenu( M, SC_SIZE, MF_BYCOMMAND ); - EnableMenuItem( M, SC_RESTORE, MF_GRAYED or MF_BYCOMMAND ); -end; - -function NewApplet( const Caption: KOLString ): PControl; -begin - AppButtonUsed := True; - Result := _NewWindowed( nil, 'App', True, - {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Applet'; - {$ENDIF} - {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsApplet ); - {$ELSE} Result.FIsApplet := TRUE; {$ENDIF} - Result.fStyle.Value := WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX or WS_CAPTION; - Result.fExStyle := WS_EX_APPWINDOW; - Result.PP.FCreateWndExt := CreateAppButton; - {$IFDEF ASM_VERSION} - Result.AttachProc( WndProcAppAsm ); - {$ELSE} - Result.AttachProc( WndProcAppPas ); - {$ENDIF} - Result.Caption := Caption; -end; -{$ENDIF PAS_VERSION} -{$ENDIF USE_CONSTRUCTORS} - -{$IFDEF CREATEAPPBUTTON_USED} -procedure CreateAppButton( App: PControl ); -asm - {$IFDEF F_P} - MOV EAX, [App] - {$ENDIF F_P} - PUSH ESI - PUSH 0 - PUSH [EAX].TControl.fHandle - CALL GetSystemMenu - MOV ESI, offset[DeleteMenu] - - XCHG ECX, EAX - MOV EAX, SC_MAXIMIZE - CDQ - - PUSH EDX - PUSH EAX - PUSH ECX - - PUSH EDX - {$IFDEF PARANOIA} DB $2C, $20 {$ELSE} SUB AL, $20 {$ENDIF} // SC_MOVE - PUSH EAX - PUSH ECX - - PUSH EDX - {$IFDEF PARANOIA} DB $2C, $10 {$ELSE} SUB AL, $10 {$ENDIF} // SC_SIZE - PUSH EAX - PUSH ECX - - PUSH 1 // MF_GRAYED or MF_BYCOMMAND - MOV AX, SC_RESTORE - PUSH EAX - PUSH ECX - - CALL EnableMenuItem - CALL ESI - CALL ESI - CALL ESI - POP ESI -end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF}; -{$ENDIF CREATEAPPBUTTON_USED} - -var CtlIdCount: WORD = $8000; - -{$ENDIF WIN_GDI} - -{$IFDEF GDI} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function _NewControl( AParent: PControl; ControlClassName: PKOLChar; - Style: DWORD; Ctl3D: Boolean; Actions: TCommandActionsParam ): PControl; -var Form: PControl; -begin - Result := _NewWindowed( AParent, ControlClassName, Ctl3D, Actions ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl'; - {$ENDIF} - {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsControl ); - {$ELSE} Result.fIsControl := True; {$ENDIF} - Result.fStyle.Value := Style or WS_CLIPSIBLINGS or WS_CLIPCHILDREN; - Result.fVerticalAlign := vaTop; - Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ]; - if Result.fCtl3D_child and 1 <> 0 then - begin - Result.fStyle.Value := Result.fStyle.Value and not WS_BORDER; - Result.fExStyle := Result.fExStyle or WS_EX_CLIENTEDGE; - end; - {$IFDEF USE_FLAGS} - {$ELSE} - Result.fVisible := (Style and WS_VISIBLE) <> 0; - Result.fTabstop := (Style and WS_TABSTOP) <> 0; - {$ENDIF} - if (AParent <> nil) then - begin - with Result.fBoundsRect do - begin - Left := AParent.fMargin + AParent.fClientLeft; - Top := AParent.fMargin + AParent.fClientTop; - Right := Left + 64; - Bottom := Top + 64; - end; - Form := AParent.ParentForm; - if Form <> nil then - begin - Inc( Form.fTabOrder ); - Result.fTabOrder := Form.fTabOrder; - if F2_Tabstop in Result.fStyle.f2_Style then - begin - if Form.DF.FCurrentControl = nil then - Form.DF.FCurrentControl := Result; - end; - end; - Result.fCursor := AParent.fCursor; - end; - Result.fMenu := CtlIdCount; - Inc( CtlIdCount ); - Result.AttachProc( WndProcCtrl ); - {$IFDEF DEBUG_ALTSPC} - DumpWindowed(Result); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION getLabelCaption( L: PControl ): KOLString; -BEGIN - L.fCaption := gtk_label_get_text( Pointer( L.fCaptionHandle ) ); - Result := L.fCaption; -END; - -PROCEDURE setLabelCaption( L: PControl; const Value: KOLString ); -BEGIN - L.fCaption := Value; - gtk_label_set_text( Pointer( L.fCaptionHandle ), PAnsiChar( String( Value ) ) ); -END; - -FUNCTION _NewControl( AParent: PControl; ControlClassName: PAnsiChar; - Style: DWORD; Ctl3D: Boolean; widget: PGtkWidget; need_eventbox: Boolean ): PControl; -VAR Rect: TRect; -BEGIN - Result := _NewWindowed( AParent, ControlClassName, widget, need_eventbox ); - Result.fIsControl := True; - Result.fVerticalAlign := vaTop; - Result.fVisible := (Style and WS_VISIBLE) <> 0; - Result.fTabstop := (Style and WS_TABSTOP) <> 0; - IF (AParent <> nil) THEN - BEGIN - WITH Rect DO - BEGIN - Left := AParent.fMargin + AParent.fClientLeft; - Top := AParent.fMargin + AParent.fClientTop; - END; - Inc( AParent.ParentForm.fTabOrder ); - Result.fTabOrder := AParent.ParentForm.fTabOrder; - {$IFDEF GDI} - Result.fCursor := AParent.fCursor; - {$ENDIF GDI} - //gtk_container_add( GTK_CONTAINER( AParent.fHandle ), Result.fHandle ); - END; - {with Rect do - begin - Right := Left + 64; - Bottom := Top + 64; - end; - Result.fBoundsRect := Result.BoundsRect; - Result.BoundsRect := Rect;} - Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ]; - {$IFDEF GDI} - IF Result.fCtl3D THEN - BEGIN - Result.fStyle := Result.fStyle and not WS_BORDER; - Result.fExStyle := Result.fExStyle or WS_EX_CLIENTEDGE; - END; - IF (Style and WS_TABSTOP) <> 0 THEN - BEGIN - Form := Result.ParentForm; - IF Form <> nil THEN - IF Form.FCurrentControl = nil THEN - Form.FCurrentControl := Result; - END; - Result.fMenu := CtlIdCount; - Inc( CtlIdCount ); - Result.AttachProc( WndProcCtrl ); - {$ENDIF GDI} -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} - -//===================== Button ========================// - -function TControl.SetButtonIcon(aIcon: HIcon): PControl; -var PrevImg: THandle; -begin - Style := Style or BS_ICON; - DF.fButtonIcon := aIcon; - PrevImg := Perform( BM_SETIMAGE, IMAGE_ICON, aIcon ); - if PrevImg <> 0 then - DeleteObject( PrevImg ); - Result := @ Self; -end; - -function TControl.SetButtonBitmap(aBmp: HBitmap): PControl; -var PrevImg: THandle; -begin - Style := Style or BS_BITMAP; - PrevImg := Perform( BM_SETIMAGE, IMAGE_BITMAP, aBmp ); - if PrevImg <> 0 then - DeleteObject( PrevImg ); - Result := @ Self; -end; - -{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} -function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := FALSE; - if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or - (Msg.message = WM_CHAR)) and (Msg.wParam = 13) then - Msg.wParam := 32; -end; -{$ENDIF} - -{$IFNDEF BUTTON_DBLCLICK} -function WndProcBtnDblClkAsClk( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := FALSE; - if Msg.message = WM_LBUTTONDBLCLK then - Msg.message := WM_LBUTTONDOWN; -end; -{$ENDIF} - -function AutoMinimizeApplet(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -begin - if (msg.Message=WM_SYSCOMMAND) and ((msg.wParam and not 15)=SC_MINIMIZE) then begin - AppletMinimize; - Result := True; - end else - Result := False; -end; - -{$IFDEF USE_CONSTRUCTORS} -function NewButton( AParent: PControl; const Caption: KOLString ): PControl; -begin - new( Result, CreateButton( AParent, Caption ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Button'; - {$ENDIF} -end; -{$ELSE USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewButton( AParent: PControl; const Caption: KOLString ): PControl; -begin - Result := _NewControl( AParent, 'BUTTON', - WS_VISIBLE or WS_CHILD or BS_NOTIFY or - BS_PUSHLIKE or WS_TABSTOP, False, - {$IFDEF PACK_COMMANDACTIONS} ButtonActions_Packed - {$ELSE} @ButtonActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Button'; - {$ENDIF} - Result.aAutoSzX := 14; - Result.aAutoSzY := 6; - {$IFDEF BUTTON_DBLCLICK} - Result.ClsStyle := Result.ClsStyle - CS_DBLCLKS; - {$ENDIF} - //Result.fCtl3D := TRUE; - with Result.fBoundsRect do - Bottom := Top + 22; - Result.fTextAlign := taCenter; - Result.Caption := Caption; - {$IFDEF USE_FLAGS} - Result.fFlagsG5 := Result.fFlagsG5 + [G5_IsButton, G5_IgnoreDefault]; - {$ELSE} Result.fIsButton := TRUE; - Result.fIgnoreDefault := TRUE; - {$ENDIF} - {$IFNDEF SMALLEST_CODE} - {$IFNDEF BUTTON_DBLCLICK} - Result.AttachProc( WndProcBtnDblClkAsClk ); - {$ENDIF} - {$ENDIF} - {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} - Result.AttachProc( WndProcBtnReturnClick ); - {$ENDIF} -{$IFDEF GRAPHCTL_XPSTYLES} - Attach_WM_THEMECHANGED( Result, XP_Themes_For_BitBtn ); -{$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} -{$ENDIF WIN_GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -CONST - HorAlignments: ARRAY[ TTextAlign ] of Single = ( {taLeft} 0, {taRight} 1, {taCenter} 0.5 ); - VerAlignments: ARRAY[ TVerticalAlign ] of Single = ( {vaTop} 0, {vaCenter} 0.5, {vaBottom} 1 ); - -PROCEDURE ButtonSetTextAlign( Self_: PControl ); -BEGIN - gtk_button_set_alignment( GTK_BUTTON( Self_.fHandle ), HorAlignments[ Self_.fTextAlign ], - VerAlignments[ Self_.fVerticalAlign ] ); -END; - -FUNCTION NewButton( AParent: PControl; const Caption: KOLString ): PControl; -BEGIN - Result := _NewControl( AParent, 'BUTTON', - WS_VISIBLE or WS_CHILD or BS_NOTIFY or - BS_PUSHLIKE or WS_TABSTOP, False, - gtk_button_new{_with_label}( {PChar( String( Caption ) )} ), FALSE ); - //Result.Height := 22; - gtk_container_set_border_width( GTK_CONTAINER( Result.fHandle ), 0 ); - Result.fCaptionHandle := gtk_label_new( PAnsiChar( String( Caption ) ) ); - gtk_container_add( GTK_CONTAINER( Result.fHandle ), Result.fCaptionHandle ); - //gtk_container_set_border_width( GTK_CONTAINER( Result.fCaptionHandle ), 0 ); - gtk_widget_show( Result.fCaptionHandle ); - Result.fGetCaption := getLabelCaption; - Result.fSetCaption := setLabelCaption; - //Result.fIgnoreDefault := TRUE; - //Result.fCtl3D := TRUE; - //with Result.fBoundsRect do - // Bottom := Top + 22; - Result.fTextAlign := taCenter; - Result.fCaption := Caption; - Result.fIsButton := TRUE; - Result.fSetTextAlign := ButtonSetTextAlign; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -//----------------- BitBtn ----------------------- - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; -var DI: PDrawItemStruct; - Control: PControl; -begin - Result := FALSE; - if Msg.message = WM_DRAWITEM then - begin - DI := Pointer( Msg.lParam ); - {$IFDEF USE_PROP} - Control := Pointer( GetProp( DI.hwndItem, ID_SELF ) ); - {$ELSE} - Control := Pointer( GetWindowLong( DI.hwndItem, GWL_USERDATA ) ); - {$ENDIF} - if Control <> nil then - begin - Rslt := Control.Perform( CN_DRAWITEM, Msg.wParam, Msg.lParam ); - Result := TRUE; - end; - end; -end; -{$ENDIF PAS_VERSION} - -function ExcludeAmpersands( Self_: PControl; const S: KOLString ): KOLString; -var I: Integer; -begin - Result := S; - if not Self_.DF.fBitBtnDrawMnemonic then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - for I := Length( Result ) downto 1 do - begin - if Result[ I ] = '&' then - Delete( Result, I, 1 ); - end; -end; - -procedure BitBtnExtDraw( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect; - const CapText, CapTxtOrig: KOLString; Color: TColor ); -var I, J, W, H: Integer; - Sz: TSize; - Pen, OldPen: HPen; -begin - if not Self_.DF.fBitBtnDrawMnemonic then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - J := 0; - for I := 1 to Length( CapTxtOrig ) do - begin - if CapTxtOrig[ I ] <> '&' then - Inc( J ) - else - begin - GetTextExtentPoint32( DC, PKOLChar( CapText ), J, Sz ); - W := Sz.cx; - Windows.GetTextExtentPoint32( DC, '_', 1, Sz ); // A/W KOL_ANSI - H := Sz.cy - 1; - Windows.GetTextExtentPoint32( DC, @ CapTxtOrig[ I + 1 ], 1, Sz ); - Windows.MoveToEx( DC, X + W, Y + H, nil ); - - Pen := CreatePen( PS_SOLID, 0, Color2RGB( Color ) ); - OldPen := SelectObject( DC, Pen ); - - Windows.LineTo( DC, X + W + Sz.cx, Y + H ); - - SelectObject( DC, OldPen ); - DeleteObject( Pen ); - end; - end; -end; - -procedure TControl.SetBitBtnDrawMnemonic(const Value: Boolean); -begin - DF.fBitBtnDrawMnemonic := Value; - DF.FBitBtnGetCaption := ExcludeAmpersands; - DF.FBitBtnExtDraw := BitBtnExtDraw; - Invalidate; -end; - -function TControl.GetBitBtnImgIdx: Integer; -begin - Result := LoWord( DF.fGlyphCount ); -end; - -procedure TControl.SetBitBtnImgIdx(const Value: Integer); -begin - if not( bboImageList in DF.fBitBtnOptions ) then Exit; {>>>>>>>>>>>>>>>>>>>>>} - DF.fGlyphCount := HiWord( DF.fGlyphCount ) or (Value and $FFFF); - Invalidate; -end; - -function TControl.GetBitBtnImageList: THandle; -begin - Result := 0; - if bboImageList in DF.fBitBtnOptions then - Result := DF.fGlyphBitmap; -end; - -procedure TControl.SetBitBtnImageList(const Value: THandle); -begin - DF.fGlyphBitmap := Value; - if Value <> 0 then - begin - include( DF.fBitBtnOptions, bboImageList ); - ImageList_GetIconSize( Value, DF.fGlyphWidth, DF.fGlyphHeight ); - end else - exclude( DF.fBitBtnOptions, bboImageList ); - Invalidate; -end; - -{$IFDEF ASM_noVERSION} // remove &-s from view //+ TextShift & if Y < 0 then Y := 0; // + glyph + TextShift if not glyphOver - // timer when RepeatInterval set -function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -const szBitmapInfo = sizeof(TBitmapInfo); -asm - CMP word ptr [EDX].TMsg.message, WM_LBUTTONDBLCLK - JNZ @@noWM_LBUTTONDBLCLK - PUSH ECX - PUSH [EDX].TMsg.wParam - PUSH [EDX].TMsg.lParam - PUSH WM_LBUTTONDOWN - PUSH EAX - CALL TControl.Perform - POP ECX - MOV [ECX], EAX - MOV AL, 1 - RET -@@noWM_LBUTTONDBLCLK: - PUSH EBX - CMP [EDX].TMsg.message, CN_DRAWITEM - JNZ @@noCN_DRAWITEM - PUSH EDI - PUSH ESI - XCHG EDI, EAX // EDI = @Self - MOV dword ptr [ECX], 1 - MOV ESI, [EDX].TMsg.lParam // ESI = DIS - XOR EBX, EBX // G = 0 - MOV EAX, [ESI].TDrawItemStruct.itemState - TEST byte ptr [EDI].TControl.fBitBtnOptions, 8 //1 shl Ord(bboFixed) - JNZ @@fixed_in_options - {$IFDEF PARANOIA} DB $A8, ODS_SELECTED {$ELSE} TEST AL, ODS_SELECTED {$ENDIF} - JZ @@not1 - JMP @@1 -@@fixed_in_options: - {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG4, 1 shl G4_Checked - {$ELSE} - TEST byte ptr [EDI].TControl.fChecked, 1 - {$ENDIF} - JZ @@not1 -@@1: INC EBX -@@not1: - {$IFDEF PARANOIA} DB $A8, ODS_DISABLED {$ELSE} TEST AL, ODS_DISABLED {$ENDIF} - JZ @@not2 - MOV BL, 2 -@@not2: TEST EBX, EBX - JNZ @@not3 - {$IFDEF PARANOIA} DB $A8, ODS_FOCUS {$ELSE} TEST AL, ODS_FOCUS {$ENDIF} - JZ @@not3 - MOV BL, 3 -@@not3: {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG3, 1 shl G3_MouseInCtl - {$ELSE} - CMP [EDI].TControl.fMouseInControl, BH - {$ENDIF} - JZ @@not4 - TEST EBX, EBX - JZ @@4 - CMP BL, 3 - JNZ @@not4 -@@4: MOV BL, 4 -@@not4: MOV ECX, [EDI].TControl.fOnBitBtnDraw.TMethod.Code - {$IFDEF NIL_EVENTS} - TEST ECX, ECX - JZ @@noOnBitBtnDraw - {$ENDIF} - MOV EAX, [EDI].TControl.fCanvas - PUSH EAX - TEST EAX, EAX - JZ @@noCanvas - MOV EDX, [ESI].TDrawItemStruct.hDC - CALL TCanvas.SetHandle -@@noCanvas: - MOV EAX, [EDI].TControl.fOnBitBtnDraw.TMethod.Data - MOV EDX, EDI - PUSH EBX - XCHG ECX, EBX - CALL EBX - POP EBX - POP ECX // Canvas - PUSH EAX - JECXZ @@noCanvas2 - XCHG EAX, ECX - XOR EDX, EDX - CALL TCanvas.SetHandle -@@noCanvas2: - POP EAX - TEST AL, AL - JNZ @@exit_draw -@@noOnBitBtnDraw: - TEST byte ptr [EDI].TControl.fBitBtnOptions, 2 //1 shl Ord(bboNoBorder) - JNZ @@noborder - TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS - JZ @@noDefaultBorder - PUSH {BLACK_BRUSH} DKGRAY_BRUSH - CALL GetStockObject - LEA EDX, [ESI].TDrawItemStruct.rcItem - OR ECX, -1 - PUSH ECX - PUSH ECX - PUSH EDX - PUSH EAX - PUSH EDX - PUSH [ESI].TDrawItemStruct.hDC - CALL Windows.FrameRect - CALL InflateRect - XOR ECX, ECX - JMP @@noFlat -@@noDefaultBorder: - {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG3, 1 shl G3_Flat - JZ @@noFlat - TEST [EDI].TControl.fFlagsG3, 1 shl G3_MouseInCtl - JZ @@noborder - {$ELSE} - MOVZX ECX, [EDI].TControl.fFlat - JECXZ @@noFlat - AND CL, [EDI].TControl.fMouseInControl - JZ @@noborder - {$ENDIF} -@@noFlat: - TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_SELECTED - MOV CL, {BDR_SUNKENOUTER or} BDR_SUNKENINNER - JNZ @@border_sunken - MOV CL, {BDR_RAISEDOUTER or} BDR_RAISEDINNER -@@border_sunken: - LEA EDX, [ESI].TDrawItemStruct.rcItem - OR EAX, -1 - PUSH EAX - PUSH EAX - PUSH EDX - PUSH BF_ADJUST or BF_RECT - PUSH ECX - PUSH EDX - PUSH [ESI].TDrawItemStruct.hDC - CALL DrawEdge - CALL InflateRect -@@noborder: - PUSH [ESI].TDrawItemStruct.rcItem.Bottom - PUSH [ESI].TDrawItemStruct.rcItem.Right - PUSH [ESI].TDrawItemStruct.rcItem.Top - PUSH [ESI].TDrawItemStruct.rcItem.Left - MOV EAX, [EDI].TControl.fGlyphWidth - MOV EDX, [EDI].TControl.fGlyphHeight - TEST EAX, EAX - JLE @@noglyph - TEST EDX, EDX - JLE @@noglyph - PUSH EBP - MOV EBP, ESP - - PUSH EDX // ImgH -> [EBP-4] - PUSH EAX // ImgW -> [EBP-8] - PUSH EDX // OutH -> [EBP-12] - PUSH EAX // OutW -> [EBP-16] - MOV EAX, [ESI].TDrawItemStruct.rcItem.Left // X = DIS.rcItem.Left - MOV EDX, [ESI].TDrawItemStruct.rcItem.Top // Y = DIS.rcItem.Top - MOV ECX, [ESI].TDrawItemStruct.rcItem.Bottom - SUB ECX, EDX - PUSH ECX // H -> [EBP-20] - MOV ECX, [ESI].TDrawItemStruct.rcItem.Right - SUB ECX, EAX - PUSH ECX // W -> [EBP-24] - MOVZX ECX, [EDI].TControl.fGlyphLayout - PUSH EBX - INC ECX - LOOP @@noGlyphLeft - MOV EBX, EAX // X - ADD EBX, [EBP-16] // +OutW - MOV [EBP+4].TRect.Left, EBX // TxRect.Left = X+OutW - JMP @@centerY -@@noGlyphLeft: - LOOP @@noGlyphTop - MOV EBX, EDX // Y - ADD EBX, [EBP-12] // +OutH - MOV [EBP+4].TRect.Top, EBX // TxRect.Top = Y+OutH - LOOP @@centerX // always JMP, ECX := -1 -@@noGlyphTop: - LOOP @@noGlyphRight - MOV EAX, [ESI].TDrawItemStruct.rcItem.Right - SUB EAX, [EBP-16] // -OutW -> X - MOV [EBP+4].TRect.Right, EAX -@@centerY: - MOV EBX, [EBP-20] // H - SUB EBX, [EBP-12] // -OutH - JLE @@noGlyphRight - SAR EBX, 1 - ADD EDX, EBX // Y = Y + (H-OutH)/2 -@@noGlyphRight: - LOOP @@noGlyphBottom - MOV EDX, [ESI].TDrawItemStruct.rcItem.Bottom - SUB EDX, [EBP-12] // -OutH -> Y - MOV [EBP+4].TRect.Bottom, EDX - LOOP @@centerX // always JMP, ECX := -1 -@@noGlyphBottom: - LOOP @@noGlyphOver -@@centerX: - MOV EBX, [EBP-24] // W - SUB EBX, [EBP-16] // -OutW - SHR EBX, 1 // /2 - ADD EAX, EBX // +EAX, X = X + (W-OutW)/2 - JECXZ @@centerY -@@noGlyphOver: - MOV ECX, [ESI].TDrawItemStruct.rcItem.Left - CMP EAX, ECX - JGE @@ok1 - XCHG EAX, ECX -@@ok1: CMP EDX, [ESI].TDrawItemStruct.rcItem.Top - {$IFDEF USE_CMOV} - CMOVL EDX, [ESI].TDrawItemStruct.rcItem.Top - {$ELSE} - JGE @@ok2 - MOV EDX, [ESI].TDrawItemStruct.rcItem.Top -@@ok2: {$ENDIF} - - MOV ECX, [ESI].TDrawItemStruct.rcItem.Right - SUB ECX, EAX - CMP [EBP-16], ECX - JLE @@ok3 - MOV [EBP-16], ECX // OutW := rcItem.Right - X; -@@ok3: MOV ECX, [ESI].TDrawItemStruct.rcItem.Bottom - SUB ECX, EDX - CMP ECX, [EBP-12] - JGE @@ok4 - MOV [EBP-12], ECX // OutH := rcItem.Bottom - Y; -@@ok4: - POP EBX // EBX = G - TEST byte ptr [EDI].TControl.fBitBtnOptions, 1 //1 shl Ord(bboImageList) - JZ @@draw_bitmap - MOVZX ECX, word ptr [EDI].TControl.fGlyphCount - CMP word ptr [EDI].TControl.fGlyphCount + 2, BX - JLE @@no_add_glyphIdx - ADD ECX, EBX -@@no_add_glyphIdx: - XOR EBX, EBX - PUSH ILD_TRANSPARENT // Flags = 1 (ILD_TRANSPARENT) - PUSH EBX // Blend = 0 - PUSH -1 // Bk = CLR_NONE - PUSH EBX // 0 - PUSH EBX // 0 - PUSH EDX - PUSH EAX - PUSH [ESI].TDrawItemStruct.hDC - PUSH ECX - PUSH [EDI].TControl.fGlyphBitmap - CMP [EDI].TControl.fTransparent, BL - JNZ @@imgl_transp - MOV EAX, [EDI].TControl.fColor - CALL Color2RGB - MOV [ESP+32], EAX // Bk = Color2RGB(fColor) - MOV [ESP+40], EBX // Flags = 0 -@@imgl_transp: - INC EBX - CMP word ptr [EDI].TControl.fGlyphCount + 2, BX - JNZ @@draw_imagelist - DEC byte ptr [ESP+36+3] // $FF, CLR_DEFAULT = $FF000000 - TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS - JZ @@draw_imagelist - OR byte ptr [ESP+40], ILD_BLEND25 // Flags != 2 -@@draw_imagelist: - CALL ImageList_DrawEx - JMP @@glyph_drawn - -@@draw_bitmap: - PUSH EAX // PlaceHold for DC - PUSH EAX // PlaceHold for OldBmp - PUSH SRCCOPY - PUSH dword ptr [EBP-4] // ImgH - PUSH dword ptr [EBP-8] // ImgW - PUSH 0 - PUSH EAX // PlaceHold for I - PUSH EAX // PlaceHold for DC - PUSH dword ptr [EBP-12] // OutH - PUSH dword ptr [EBP-16] // OutW - PUSH EDX // Y - PUSH EAX // X - PUSH [ESI].TDrawItemStruct.hDC - - PUSH 0 - CALL CreateCompatibleDC - MOV [ESP+48], EAX // save DC - MOV [ESP+20], EAX // place DC - PUSH [EDI].TControl.fGlyphBitmap - PUSH EAX - CALL SelectObject - MOV [ESP+44], EAX // save OldBitmap - XOR EAX, EAX - CMP [EDI].TControl.fGlyphCount, EBX - JLE @@no_incGlyIdx - MOV EAX, [EBP-8] // ImgW - IMUL EBX -@@no_incGlyIdx: - MOV [ESP+24], EAX // place I - CALL StretchBlt - CALL FinishDC - -@@glyph_drawn: - MOV ESP, EBP - POP EBP - -@@noglyph: - TEST byte ptr[EDI].TControl.fBitBtnOptions, 4 //1 shl Ord(bboNoCaption) - JNZ @@noCaption - - POP EAX - PUSH EAX - MOV EDX, [ESP].TRect.Right - CMP EDX, EAX - JLE @@noCaption - MOV EDX, [ESP].TRect.Bottom - CMP EDX, [ESP].TRect.Top - JLE @@noCaption - - XOR EBX, EBX - PUSH EBX // > CapText - MOV EDX, ESP - MOV EAX, EDI - CALL TControl.GetCaption - PUSH EBX // > Bk - PUSH EBX // > Blend - CMP [EDI].TControl.fTransparent, BL - MOV BL, ETO_CLIPPED - JNZ @@drwTxTransparent - CMP [EDI].TControl.fGlyphLayout, glyphOver - JNZ @@drwTxOpaque -@@drwTxTransparent: - PUSH TRANSPARENT - PUSH [ESI].TDrawItemStruct.hDC - CALL SetBkMode - MOV [ESP+4], EAX // Bk := SetBkMode( DIS.hDC, TRANSPARENT ) - JMP @@drwTx1 -@@drwTxOpaque: - MOV BL, ETO_CLIPPED or ETO_OPAQUE - MOV EAX, [EDI].TControl.fColor - CALL Color2RGB - PUSH EAX - PUSH [ESI].TDrawItemStruct.hDC - CALL SetBkColor - POP ECX - PUSH EAX // Blend := SetBkColor(DIS.hDC,fColor) -@@drwTx1: - PUSH 0 // > OldFont - PUSH 0 // > OldTextColor - - PUSH 0 // push - MOV EDX, [ESP+20] // CapText - CALL EDX2PChar - PUSH dword ptr [EDX-4] // push Length(CapText) - PUSH EDX // push PChar(CapText) - LEA EAX, [ESP+32] - PUSH EAX // push @TxRect - PUSH EBX // push Flags - - MOV EBX, [ESI].TDrawItemStruct.hDC - - MOV ECX, [EDI].TControl.fFont - JECXZ @@drwTx_noFont - XCHG EAX, ECX - CALL TGraphicTool.GetHandle - PUSH EAX - PUSH EBX - CALL SelectObject - MOV [ESP+24], EAX // OldFont := SelectObject... -@@drwTx_noFont: - MOV EAX, [EDI].TControl.fTextColor - CALL Color2RGB - PUSH EAX - PUSH EBX - CALL SetTextColor - MOV [ESP+20], EAX // OldTextColor := SetTextColor... - - PUSH EAX - PUSH EAX - PUSH ESP - MOV ECX, [ESP+48] // ECX = CapText - XOR EAX, EAX - JECXZ @@drwTx0 - MOV EAX, [ECX-4] // EAX = Length(CapText) -@@drwTx0: - PUSH EAX - PUSH ECX - PUSH EBX - CALL GetTextExtentPoint32 - POP ECX // ECX = TextSz.cx - POP EDX // EDX = TextSz.cy - MOV EAX, [ESP+40].TRect.Bottom - SUB EAX, [ESP+40].TRect.Top - SUB EAX, EDX - JGE @@yOk - XOR EAX, EAX -@@yOk: SHR EAX, 1 - ADD EAX, [ESP+40].TRect.Top - PUSH EAX // push Y - MOV EDX, [ESP+44].TRect.Right - MOV EAX, [ESP+44].TRect.Left // EAX = TxRect.Left - SUB EDX, EAX // EDX = W - PUSH EAX - CMP [EDI].TControl.fTextAlign, taRight - JL @@chk_X - JE @@alignR - SUB ECX, EDX - SAR ECX, 1 - JMP @@alignC -@@alignR: - ADD EAX, EDX -@@alignC: - SUB EAX, ECX -@@chk_X:POP EDX - CMP EAX, EDX - JGE @@xOk - XCHG EAX, EDX -@@xOk: PUSH EAX // push X - PUSH EBX // push hDC - CALL ExtTextOut - - PUSH EBX - CALL SetTextColor - POP ECX - JECXZ @@noRestoreFont - PUSH ECX - PUSH EBX - CALL SelectObject -@@noRestoreFont: - POP ECX // Blend - JECXZ @@restoreBk - PUSH ECX - PUSH EBX - CALL SetBkColor - POP ECX - JMP @@delCaption -@@restoreBk: - PUSH EBX - CALL SetBkMode -@@delCaption: - CALL RemoveStr - -@@noCaption: - ADD ESP, 16 - -@@exit_draw: - POP ESI - POP EDI - POP EBX - MOV AL, 1 - RET - -@@noCN_DRAWITEM: - CMP word ptr [EDX].TMsg.message, WM_LBUTTONDOWN - JZ @@doDown - CMP word ptr [EDX].TMsg.message, WM_KEYDOWN - JNZ @@noWM_LBUTTONDOWN - CMP [EDX].TMsg.wParam, 32 - JNZ @@noWM_LBUTTONDOWN -@@doDown: - PUSH EDX - XCHG EBX, EAX - - CALL @@fixed_proc - MOV ECX, [EBX].TControl.fRepeatInterval - JECXZ @@exit_LBUTTONDOWN - POP EDX - PUSH EDX - CMP word ptr [EDX].TMsg.message, WM_KEYDOWN - JZ @@not_SetTimer - PUSH 0 - PUSH [EBX].TControl.fRepeatInterval - PUSH 1 - PUSH [EBX].TControl.fHandle - CALL SetTimer -@@exit_LBUTTONDOWN: -@@not_SetTimer: - POP EDX - JMP @@invalidate - -@@noWM_LBUTTONDOWN: - CMP word ptr [EDX].TMsg.message, WM_LBUTTONUP - JE @@doKill1 - CMP word ptr [EDX].TMsg.message, WM_KEYUP - JNE @@noWM_LBUTTONUP - PUSH 1 - PUSH [EBX].TControl.fHandle - CALL KillTimer - -@@noWM_LBUTTONUP: - CMP word ptr [EDX].TMsg.message, WM_TIMER - JNZ @@noWM_TIMER - - XCHG EBX, EAX - PUSH 0 - PUSH 0 - PUSH BM_GETSTATE - PUSH EBX - CALL TControl.Perform - {$IFDEF PARANOIA} DB $A8, 4 {$ELSE} TEST AL, BST_PUSHED {$ENDIF} - JNZ @@pushed - PUSH 1 - PUSH [EBX].TControl.fHandle - CALL KillTimer - CALL ReleaseCapture - JMP @@noWM_TIMER -@@fixed_proc: - TEST byte ptr [EBX].TControl.fBitBtnOptions, 8 // bboFixed - JZ @@not_fixed - {$IFDEF USE_FLAGS} - XOR [EBX].TControl.fFlagsG4, 1 shl G4_Checked - {$ELSE} - XOR [EBX].TControl.fChecked, 1 - {$ENDIF} - MOV ECX, [EBX].TControl.fOnChangeCtl.TMethod.Code - {$IFDEF NIL_EVENTS} - JECXZ @@not_fixed - {$ENDIF} - MOV EAX, [EBX].TControl.fOnChangeCtl.TMethod.Data - MOV EDX, EBX - JMP ECX -@@pushed: - CALL @@fixed_proc - MOV EAX, EBX - CALL TControl.DoClick -@@invalidate: - XCHG EAX, EBX - CALL TControl.Invalidate -@@noWM_TIMER: - XOR EAX, EAX - POP EBX -@@not_fixed: -end; -{$ELSE PAS_VERSION} //Pascal -function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var DIS: PDrawItemStruct; - IsDown, IsDefault, IsDisabled: Boolean; - Flags: Integer; - X, Y, W, H, ImgW, ImgH, OutW, OutH, I, G, Bk, Blend: Integer; - TxRect, FocusRect: TRect; - OldFont: HFont; - OldTextColor: TColor; - CapText, CapTxtOrig: KOLString; - TextSz: TSize; - DC: HDC; - OldBmp: HBitmap; - Handled: Boolean; -begin - Result := False; - if (Msg.message = WM_LBUTTONDBLCLK) then - begin - Rslt := Self_.Perform( WM_LBUTTONDOWN, Msg.wParam, Msg.lParam ); - Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if (Msg.message = CN_DRAWITEM) then - begin - Result := True; - Rslt := 1; - DIS := Pointer( Msg.lParam ); - IsDown := (DIS.itemState and ODS_SELECTED <> 0) or - {$IFDEF USE_FLAGS} (G4_Checked in Self_.fFlagsG4) - {$ELSE} Self_.fChecked {$ENDIF}; - IsDefault := DIS.itemState and ODS_FOCUS <> 0; - IsDisabled := DIS.itemState and ODS_DISABLED <> 0; - G := 0; - if IsDown then G := {$IFDEF BITBTN_DISABLEDGLYPH2} 1 {$ELSE} 2 {$ENDIF}; - if IsDisabled then G := {$IFDEF BITBTN_DISABLEDGLYPH2} 2 {$ELSE} 1 {$ENDIF}; - if (G = 0) and IsDefault then G := 3; - if ((G = 0) or (G = 3)) and Self_.MouseInControl then G := 4; - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnBitBtnDraw ) then - {$ENDIF} - begin - if ( Self_.fCanvas <> nil ) then - Self_.fCanvas.SetHandle( DIS.hDC ); - Handled := Self_.EV.fOnBitBtnDraw( Self_, G ); - if ( Self_.fCanvas <> nil ) then - Self_.fCanvas.SetHandle( 0 ); - if Handled then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if not ( bboNoBorder in Self_.DF.fBitBtnOptions ) then - begin - if IsDefault and not( bboFocusRect in Self_.DF.fBitBtnOptions ) then - begin - Windows.FrameRect( DIS.hDC, DIS.rcItem, GetStockObject( {BLACK_BRUSH} DKGRAY_BRUSH ) ); - InflateRect( DIS.rcItem, -1, -1 ); - end; - if {$IFDEF USE_FLAGS} G3_Flat in Self_.fFlagsG3 - {$ELSE} Self_.fFlat {$ENDIF} then - begin - if IsDown then - Flags := BDR_RAISEDINNER - else - Flags := 0; //EDGE_ETCHED; - DrawEdge( DIS.hDC, DIS.rcItem, Flags, BF_FLAT or BF_RECT ); - //InflateRect( DIS.rcItem, -1, -1 ); - end; - if {$IFDEF USE_FLAGS} not(G3_Flat in Self_.fFlagsG3) - {$ELSE} not Self_.fFlat {$ENDIF} - or {$IFDEF USE_FLAGS} (G3_MouseInCtl in Self_.fFlagsG3) - {$ELSE} Self_.fMouseInControl {$ENDIF} or IsDefault then - begin - if IsDown then - Flags := BDR_SUNKENOUTER or BDR_SUNKENINNER - else - Flags := BDR_RAISEDOUTER or BDR_RAISEDINNER; - DrawEdge( DIS.hDC, DIS.rcItem, Flags, BF_ADJUST or BF_RECT ); - InflateRect( DIS.rcItem, -1, -1 ); - end; - end; - TxRect := DIS.rcItem; - if Self_.DF.fGlyphBitmap <> 0 then - begin - ImgW := Self_.DF.fGlyphWidth; - ImgH := Self_.DF.fGlyphHeight; - if (ImgW > 0) and (ImgH > 0) then - begin - OutW := ImgW; - OutH := ImgH; - W := DIS.rcItem.Right - DIS.rcItem.Left; - H := DIS.rcItem.Bottom - DIS.rcItem.Top; - X := DIS.rcItem.Left; - Y := DIS.rcItem.Top; - if isDown and (Self_.DF.fGlyphLayout <> glyphOver) then - begin - Inc( X, Self_.TextShiftX ); - Inc( Y, Self_.TextShiftY ); - end; - case Self_.DF.fGlyphLayout of - glyphLeft: - begin - Y := Y + (H - OutH) div 2; - TxRect.Left := X + OutW; - end; - glyphTop: - begin - X := X + (W - OutW) div 2; - TxRect.Top := Y + OutH; - end; - glyphRight: - begin - X := DIS.rcItem.Right - OutW; - TxRect.Right := X; - Y := Y + (H - OutH) div 2; - end; - glyphBottom: - begin - Y := DIS.rcItem.Bottom - OutH; - TxRect.Bottom := Y; - X := X + (W - OutW) div 2; - end; - glyphOver: - begin - X := X + (W - OutW) div 2; - Y := Y + (H - OutH) div 2; - end; - end; - if X < DIS.rcItem.Left then - X := DIS.rcItem.Left; - if Y < DIS.rcItem.Top then - Y := DIS.rcItem.Top; - if X + OutW > DIS.rcItem.Right then - OutW := DIS.rcItem.Right - X; - if Y + OutH > DIS.rcItem.Bottom then - OutH := DIS.rcItem.Bottom - Y; - - if bboImageList in Self_.DF.fBitBtnOptions then - begin - I := LoWord( Self_.DF.fGlyphCount ); - if (HiWord( Self_.DF.fGlyphCount ) > G) then - I := I + G; - Flags := 0; // ILD_NORMAL - Blend := 0; - if {$IFDEF USE_FLAGS} not( G2_Transparent in Self_.fFlagsG2 ) - {$ELSE} not Self_.fTransparent {$ENDIF} then - Bk := Color2RGB( Self_.fColor ) - else - begin - Bk := Integer(CLR_NONE); - Flags := ILD_TRANSPARENT; - end; - if HiWord( Self_.DF.fGlyphCount ) = 1 then - begin - Blend := Integer(CLR_DEFAULT); - if IsDefault then - Flags := Flags or ILD_BLEND25; - end; - ImageList_DrawEx( Self_.DF.fGlyphBitmap, I, DIS.hDC, X, Y, 0, 0, - Bk, Blend, Flags ); - end - else - begin - DC := CreateCompatibleDC( 0 ); - OldBmp := SelectObject( DC, Self_.DF.fGlyphBitmap ); - - I := 0; - if Self_.DF.fGlyphCount > G then - I := I + G * ImgW; - StretchBlt( DIS.hDC, X, Y, OutW, OutH, DC, I, 0, ImgW, ImgH, SRCCOPY ); - - SelectObject( DC, OldBmp ); - DeleteDC( DC ); - end; - end; - end; - if not (bboNoCaption in Self_.DF.fBitBtnOptions) then - if (TxRect.Right > TxRect.Left) and (TxRect.Bottom > TxRect.Top) then - begin - CapText := Self_.Caption; - CapTxtOrig := CapText; /////////////////////////// added 19 Nov 2001 - if Assigned( Self_.DF.FBitBtnGetCaption ) then - CapText := Self_.DF.FBitBtnGetCaption( Self_, CapText ); //////////// - Bk := 0; - Blend := 0; - Flags := ETO_CLIPPED; - if {$IFDEF USE_FLAGS} (G2_Transparent in Self_.fFlagsG2) - {$ELSE} Self_.fTransparent {$ENDIF} - or (Self_.DF.fGlyphLayout = glyphOver) then - Bk := SetBkMode( DIS.hDC, TRANSPARENT ) - else - begin - Flags := Flags or ETO_OPAQUE; - Blend := SetBkColor( DIS.hDC, Color2RGB( Self_.fColor ) ); - end; // Returned previous BkMode is either OPAQUE=1 or TRANSPARENT=2 - - OldFont := 0; - if ( Self_.fFont <> nil ) then - OldFont := SelectObject( DIS.hDC, Self_.fFont.Handle ); - OldTextColor := SetTextColor( DIS.hDC, Color2RGB( Self_.fTextColor ) ); - - {$IFDEF UNICODE_CTRLS}Windows.GetTextExtentPoint32W - {$ELSE} Windows.GetTextExtentPoint32A - {$ENDIF}( DIS.hDC, PKOLChar( CapText ), Length( CapText ), - TextSz ); - W := TxRect.Right - TxRect.Left; - H := TxRect.Bottom - TxRect.Top; - Y := TxRect.Top + (H - TextSz.cy) div 2; - case Self_.fTextAlign of - taLeft: X := TxRect.Left; - taCenter: X := TxRect.Left + (W - TextSz.cx) div 2; - else {taRight:} X := TxRect.Right - TextSz.cx; - end; - if isDown then - begin - Inc( X, Self_.TextShiftX ); - Inc( Y, Self_.TextShiftY ); - end; - if Y < 0 then - Y := 0; - if X < TxRect.Left then - X := TxRect.Left; - - {$IFDEF UNICODE_CTRLS} - Windows.ExtTextOutW( DIS.hDC, X, Y, Flags, @TxRect, - PWideChar( CapText ), Length( CapText ), nil ); - {$ELSE} - Windows.ExtTextOutA( DIS.hDC, X, Y, Flags, @TxRect, - PAnsiChar( CapText ), Length( CapText ), nil ); - {$ENDIF} - - if bboFocusRect in Self_.DF.fBitBtnOptions then - if IsDefault then - begin - FocusRect := TxRect; - //InflateRect( FocusRect, 1, 1 ); - Windows.DrawFocusRect( DIS.hDC, FocusRect ); - end; - - //{$IFDEF NIL_EVENTS} - if Assigned( Self_.DF.FBitBtnExtDraw ) then // to provide underlying mnemonic characters - //{$ENDIF} - Self_.DF.FBitBtnExtDraw( Self_, DIS.hDC, X, Y, TxRect, CapText, CapTxtOrig, - OldTextColor ); ///////////////////////////////// - - SetTextColor( DIS.hDC, OldTextColor ); - if OldFont <> 0 then - SelectObject( DIS.hDC, OldFont ); - - if Blend = 0 then - SetBkMode( DIS.hDC, Bk ) - else - SetBkColor( DIS.hDC, Blend ); - end; - end; - if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_KEYDOWN) and (Msg.wParam = 32) then - begin - if bboFixed in Self_.DF.fBitBtnOptions then - begin - {$IFDEF USE_FLAGS} - if G4_Checked in Self_.fFlagsG4 then - exclude( Self_.fFlagsG4, G4_Checked ) - else include( Self_.fFlagsG4, G4_Checked ); - {$ELSE} Self_.fChecked := not Self_.fChecked; {$ENDIF} - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnChangeCtl ) then - {$ENDIF} - Self_.EV.fOnChangeCtl( Self_ ); - end; - if Self_.DF.fRepeatInterval > 0 then - begin - if Msg.message <> WM_KEYDOWN then - SetTimer( Self_.fHandle, 1, 400, nil ); - Self_.Invalidate; - end; - end; - - if Msg.message = WM_LBUTTONUP then - begin - if Self_.DF.fRepeatInterval > 0 then - KillTimer( Self_.fHandle, 1 ); - end; - - if Msg.message = WM_KILLFOCUS then // to repaint when focus lost - Self_.Invalidate; - - if Msg.message = WM_TIMER then - begin - KillTimer( Self_.fHandle, 1 ); - if bboFixed in Self_.DF.fBitBtnOptions then - begin - {$IFDEF USE_FLAGS} - if G4_Checked in Self_.fFlagsG4 then - exclude( Self_.fFlagsG4, G4_Checked ) - else include( Self_.fFlagsG4, G4_Checked ); - {$ELSE} Self_.fChecked := not Self_.fChecked; {$ENDIF} - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnChangeCtl ) then - {$ENDIF} - Self_.EV.fOnChangeCtl( Self_ ); - end; - Self_.DoClick; - SetTimer( Self_.fHandle, 1, Self_.DF.fRepeatInterval, nil ); - Self_.Invalidate; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF USE_CONSTRUCTORS} -function NewBitBtn( AParent: PControl; const Caption: AnsiString; - Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; - GlyphCount: Integer ): PControl; -begin - new( Result, CreateBitBtn( AParent, Caption, Options, Layout, GlyphBitmap, GlyphCount ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:BitBtn'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_noVERSION} // todo: first correct asm version, then remove -{$ELSE PAS_VERSION} //Pascal -function NewBitBtn( AParent: PControl; const Caption: KOLString; - Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; - GlyphCount: Integer ): PControl; -var - B: TBitmapInfo; - W, H: Integer; - f: DWORD; -begin - f := WS_VISIBLE or WS_CHILD or BS_OWNERDRAW or WS_TABSTOP or BS_NOTIFY; - Result := _NewControl( AParent, 'BUTTON', f, False, - {$IFDEF PACK_COMMANDACTIONS} ButtonActions_Packed - {$ELSE} @ButtonActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:BitBtn'; - {$ENDIF} - {$IFDEF USE_FLAGS} - Result.fFlagsG5 := Result.fFlagsG5 + - [G5_IsButton, G5_IsBitBtn, G5_IgnoreDefault]; - {$ELSE} Result.fIsButton := TRUE; - Result.fIsBitBtn := TRUE; - Result.fIgnoreDefault := TRUE; - {$ENDIF} - Result.aAutoSzX := 8; - Result.aAutoSzY := 8; - Result.DF.fBitBtnOptions := Options; - Result.DF.fGlyphLayout := Layout; - Result.DF.fGlyphBitmap := GlyphBitmap; - with Result.fBoundsRect do - begin - Bottom := Top + 22; - W := 0; H := 0; - if GlyphBitmap <> 0 then - begin - if bboImageList in Options then - ImageList_GetIconSize( GlyphBitmap, W, H ) - else - begin - if GetObject( GlyphBitmap, Sizeof(B), @B ) > 0 then - begin - W := B.bmiHeader.biWidth; - H := B.bmiHeader.biHeight; - if GlyphCount = 0 then - GlyphCount := W div H; - if GlyphCount > 1 then - W := W div GlyphCount; - end; - end; - if W > 0 then - begin - if (Caption = '') or (Layout = glyphOver) then - begin - Right := Left + W; - Result.aAutoSzX := 0; - end - else - if Layout in [ glyphLeft, glyphRight ] then - begin - Right := Right + W; - Inc( Result.aAutoSzX, W ); - end; - end; - if H > 0 then - begin - if Layout in [ glyphTop, glyphBottom ] then - begin - Bottom := Bottom + H; - Inc( Result.aAutoSzY, H ); - end - else - begin - Bottom := Top + H; - Result.aAutoSzY := 0; - end; - end; - if not ( bboNoBorder in Options ) then - begin - if W > 0 then - begin - Inc( Right, 4 ); - if Result.aAutoSzX > 0 then - Inc( Result.aAutoSzX, 4 ); - end; - if H > 0 then - begin - Inc( Bottom, 4 ); - if Result.aAutoSzY > 0 then - Inc( Result.aAutoSzY, 4 ); - end; - end; - end; - Result.DF.fGlyphWidth := W; - Result.DF.fGlyphHeight := H; - end; - Result.DF.fGlyphCount := GlyphCount; - if AParent <> nil then - AParent.AttachProc( WndProc_DrawItem ); - Result.AttachProc( WndProcBitBtn ); - Result.fTextAlign := taCenter; - Result.Caption := Caption; - {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} - Result.AttachProc( WndProcBtnReturnClick ); - {$ENDIF} - - {$IFDEF GRAPHCTL_XPSTYLES} - Attach_WM_THEMECHANGED(Result, XP_Themes_For_BitBtn); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Check box ========================// - -{$IFDEF USE_CONSTRUCTORS} -function NewCheckbox( AParent: PControl; const Caption: AnsiString ): PControl; -begin - new( Result, CreateCheckbox( AParent, Caption ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:CheckBox'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl; -begin - Result := NewButton( AParent, Caption ); - with Result.fBoundsRect do - begin - Right := Left + 72; - end; - Result.fStyle.Value := WS_VISIBLE or WS_CHILD or - BS_AUTOCHECKBOX or WS_TABSTOP or BS_NOTIFY; - Result.aAutoSzX := 24; - -{$IFDEF GRAPHCTL_XPSTYLES} - Attach_WM_THEMECHANGED(Result, XP_Themes_For_CheckBox ); -{$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -function NewCheckBox3State( AParent: PControl; const Caption: KOLString ): PControl; -begin - Result := NewCheckbox( AParent, Caption ); - Result.fStyle.Value := Result.fStyle.Value and not BS_AUTOCHECKBOX or BS_AUTO3STATE; -end; - -//===================== Radiobox ========================// - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure ClickRadio( Sender:PObj ); -var Self_:PControl; - {$IFDEF USE_FLAGS} - i: Integer; - C: PControl; - NewState: Boolean; - {$ENDIF} -begin - Self_ := PControl( Sender ); - if Self_.FParent <> nil then - {$IFDEF USE_FLAGS} - begin - for i := 0 to Self_.FParent.ChildCount-1 do - begin - C := Self_.FParent.Children[i]; - if G5_IsButton in C.fFlagsG5 then - if C.fStyle.f0_Style and BS_RADIOBUTTON <> 0 then - begin - NewState := C = Self_; - if NewState <> C.Checked then - C.Checked := NewState; - end; - end; - end; - {$ELSE} - CheckRadioButton( Self_.fParent.fHandle, - Self_.fParent.PropInt[ @RADIO_1ST ], - Self_.fParent.PropInt[ @RADIO_LAST ], - Self_.fMenu ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF USE_CONSTRUCTORS} -function NewRadiobox( AParent: PControl; const Caption: AnsiString ): PControl; -begin - new( Result, CreateRadiobox( AParent, Caption ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Radiobox'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl; -begin - Result := NewCheckbox( AParent, Caption ); - Result.fStyle.Value := WS_VISIBLE or WS_CHILD or - BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP or BS_NOTIFY; - Result.PP.fControlClick := ClickRadio; - if AParent <> nil then - begin - {$IFDEF USE_FLAGS} - if not(G1_HasRadio in AParent.fFlagsG1) then - begin - include( AParent.fFlagsG1, G1_HasRadio ); - Result.SetRadioChecked; - end; - {$ELSE} - AParent.PropInt[ @RADIO_LAST ] := Result.fMenu; - if AParent.PropInt[ @RADIO_1ST ] = 0 then - begin - AParent.PropInt[ @RADIO_1ST ] := Result.fMenu; - Result.SetRadioChecked; - end; - {$ENDIF} - end; -{$IFDEF GRAPHCTL_XPSTYLES} - Attach_WM_THEMECHANGED(Result, XP_Themes_For_RadioBox); -{$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Label ========================// - -{$ENDIF WIN_GDI} -{$IFNDEF USE_CONSTRUCTORS} -{$ENDIF not USE_CONSTRUCTORS} -{$IFDEF USE_CONSTRUCTORS} -function NewLabel( AParent: PControl; const Caption: AnsiString ): PControl; -begin - new( Result, CreateLabel( AParent, Caption ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Label'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF GDI} -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function NewLabel( AParent: PControl; const Caption: KOLString ): PControl; -begin - Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or - SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, - False, {$IFDEF PACK_COMMANDACTIONS} LabelActions_Packed - {$ELSE} @LabelActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Label'; - {$ENDIF} - Result.aAutoSzX := 1; - Result.aAutoSzY := 1; - {$IFDEF USE_FLAGS} - Result.fFlagsG1 := Result.fFlagsG1 + [G1_SizeRedraw, G1_IsStaticControl]; - {$ELSE} Result.fSizeRedraw := True; - Inc( Result.fIsStaticControl ); - {$ENDIF} - with Result.fBoundsRect do - Bottom := Top + 22; //Right := Left + 64 {done in _NewControl}; - Result.Caption := Caption; -{$IFDEF GRAPHCTL_XPSTYLES} - Attach_WM_THEMECHANGED(Result, XP_Themes_For_Label); -{$ENDIF} -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE LabelSetTextAlign( Self_: PControl ); -BEGIN - gtk_misc_set_alignment( GTK_MISC( Self_.fCaptionHandle ), HorAlignments[ Self_.fTextAlign ], - VerAlignments[ Self_.fVerticalAlign ] ); -END; - -FUNCTION NewLabel( AParent: PControl; const Caption: KOLString ): PControl; -BEGIN - Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or - SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, - False, gtk_label_new( PAnsiChar( String( Caption ) ) ), - TRUE ); - Result.fGetCaption := getLabelCaption; - Result.fSetCaption := setLabelCaption; - {$IFDEF USE_FLAGS} include( Result.fFlagsG1, G1_IsStaticControl ); - {$ELSE} Inc( Result.fIsStaticControl ); {$ENDIF} - Result.fSetTextAlign := LabelSetTextAlign; - Result.fTextAlign := taCenter; - Result.TextAlign := taLeft; -END; -{$ENDIF GTK} -{$ENDIF _X_} -{$ENDIF USE_CONSTRUCTORS} - -{$IFDEF WIN_GDI} -//===================== word wrap Label ========================// - -{$IFDEF USE_CONSTRUCTORS} -function NewWordWrapLabel( AParent: PControl; const Caption: AnsiString ): PControl; -begin - new( Result, CreateWordWrapLabel( AParent, Caption ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:WordWrapLabel'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewWordWrapLabel( AParent: PControl; const Caption: KOLString ): PControl; -begin - Result := NewLabel( AParent, Caption ); - {$IFDEF USE_FLAGS} include( Result.fFlagsG1, G1_WordWrap ); - {$ELSE} Result.fWordWrap := TRUE; {$ENDIF} - with Result.fBoundsRect do - begin - Bottom := Top + 44; - end; - Result.fStyle.Value := Result.fStyle.Value and not SS_LEFTNOWORDWRAP; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Label Effect ========================// - -{$IFDEF USE_CONSTRUCTORS} -function NewLabelEffect( AParent: PControl; const Caption: AnsiString; ShadowDeep: Integer ): PControl; -begin - new( Result, CreateLabelEffect( AParent, Caption, ShadowDeep ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:LabelEffect'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewLabelEffect( AParent: PControl; const Caption: KOLString; ShadowDeep: Integer ): PControl; -begin - Result := NewLabel( AParent, '' ); - {$IFDEF USE_FLAGS} exclude( Result.fFlagsG1, G1_IsStaticControl ); - {$ELSE} Dec( Result.fIsStaticControl ); { снова 0 ! } {$ENDIF} - Result.AttachProc( WndProcLabelEffect ); - Result.Caption := Caption; - Result.AttachProc( WndProcDoEraseBkgnd ); - Result.fTextAlign := taCenter; - Result.fTextColor := clWindowText; - Result.DF.fShadowDeep := ShadowDeep; - {$IFDEF USE_FLAGS} include( Result.fFlagsG1, G1_IgnoreWndCaption ); - {$ELSE} Result.fIgnoreWndCaption := True; {$ENDIF} - with Result.fBoundsRect do - begin - Bottom := Top + 40; - end; - Result.DF.fColor2 := clNone; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Paint box ========================// -{$ENDIF WIN_GDI} -{$IFDEF USE_CONSTRUCTORS} -function NewPaintbox( AParent: PControl ): PControl; -begin - new( Result, CreatePaintBox( AParent ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Paintbox'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF GDI} - -{$UNDEF ASM_LOCAL} -{$IFNDEF GRAPHCTL_XPSTYLES} - {$IFDEF ASM_VERSION} - {$DEFINE ASM_LOCAL} - {$ENDIF PAS_VERSION} -{$ENDIF GRAPHCTL_XPSTYLES} - -{$IFDEF ASM_LOCAL} -function NewPaintbox( AParent: PControl ): PControl; -asm - XOR EDX, EDX - CALL NewLabel - ADD [EAX].TControl.fBoundsRect.Bottom, 64-22 -end; -{$ELSE ASM_LOCAL} //Pascal -function NewPaintbox( AParent: PControl ): PControl; -begin -{$IFDEF GRAPHCTL_XPSTYLES} - Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD {or - SS_LEFTNOWORDWRAP or SS_NOPREFIX }or SS_NOTIFY, - False, {$IFDEF PACK_COMMANDACTIONS} LabelActions_Packed - {$ELSE} @LabelActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:PaintBox'; - {$ENDIF} - {$IFDEF USE_FLAGS} - include( Result.fFlagsG1, G1_SizeRedraw ); - if G2_Transparent in Result.fFlagsG2 then - include( Result.fFlagsG2, G2_ClassicTransparent ) - else exclude( Result.fFlagsG2, G2_ClassicTransparent ); - {$ELSE} Result.fSizeRedraw := True; - Result.fClassicTransparent := Result.fTransparent; - {$ENDIF} - Result.fControlClassName := 'obj_PAINT'; -{$ELSE} - Result := NewLabel( AParent, '' ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Paintbox'; - {$ENDIF} - with Result.fBoundsRect do - begin - Bottom := Top + 64; //Right := Left + 64 {done in NewLabel}; - end; -{$ENDIF} -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION NewPaintbox( AParent: PControl ): PControl; -BEGIN - Result := NewLabel( AParent, '' ); - Result.Height := 64; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$ENDIF USE_CONSTRUCTORS} -{$IFDEF WIN_GDI} - -{$IFDEF _D2} -function SetBrushOrgEx(DC: HDC; X, Y: Integer; PrevPt: PPoint): BOOL; stdcall; -external gdi32 name 'SetBrushOrgEx'; -{$ENDIF} - -{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION PAS_VERSION} -function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var DC: HDC; - R: TRect; -begin - Result := FALSE; - if Msg.message = WM_ERASEBKGND then - begin - Self_.CreateChildWindows; - if Self_.Transparent then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DC := Msg.wParam; - SetBkMode( DC, OPAQUE ); - SetBkColor( DC, Color2RGB( Self_.fColor ) ); - SetBrushOrgEx( DC, 0, 0, nil ); - GetClientRect( Self_.fHandle, R ); - Windows.FillRect( DC, R, Global_GetCtlBrushHandle( Self_ ) ); - Rslt := 1; - end; -end; -{$ENDIF PAS_VERSION} - -function WndProcImageShow( Sender: PControl; var Msg: TMsg; - var Rslt: Integer ): Boolean; -var PaintStruct: TPaintStruct; - IL: PImageList; - OldPaintDC: HDC; - {$IFDEF TEST_IL} - B: PBitmap; - {$ENDIF TEST_IL} -begin - Result := FALSE; - if (Msg.message = WM_PAINT) or (Msg.message = WM_PRINT) then - begin - OldPaintDC := Sender.fPaintDC; - Sender.fPaintDC := Msg.wParam; - if Sender.fPaintDC = 0 then - Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct ); - IL := Sender.ImageListNormal; - if IL <> nil then - begin - IL.DrawingStyle := [ dsTransparent ]; - {$IFDEF TEST_IL} - B := NewBitmap( 0, 0 ); - B.Handle := IL.GetBitmap; - B.SaveToFile( GetStartDir + 'test_IL_show.bmp' ); - B.ReleaseHandle; - B.Free; - {$ENDIF TEST_IL} - IL.Draw( Sender.fCurIndex, Sender.fPaintDC, Sender.fClientLeft, Sender.fClientTop ); - Result := TRUE; - end; - if Msg.wParam = 0 then - EndPaint( Sender.fHandle, PaintStruct ); - Sender.fPaintDC := OldPaintDC; - Rslt := 0; {Result := True;} Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; -end; - -function NewImageShow( AParent: PControl; AImgList: PImageList; - ImgIdx: Integer ): PControl; -var W, H: Integer; -begin - Result := NewLabel( AParent, '' ); - Result.ImageListNormal := AImgList; - Result.AttachProc( WndProcImageShow ); - Result.AttachProc( WndProcDoEraseBkgnd ); - W := 32; H := 32; - if AImgList <> nil then - begin - W := AImgList.ImgWidth; - H := AImgList.ImgHeight; - end; - with Result.fBoundsRect do - begin - Right := Left + W; - Bottom := Top + H; - end; - Result.CurIndex := ImgIdx; -end; - -//===================== Scrollbar ========================// -const - KSB_INITIALIZE = WM_USER + 10000; - KSB_KEY = $3232; - -function WndProcScrollBarParent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var - Bar: PControl; - SI: TScrollInfo; - NewPos: Integer; - AllowChange: Boolean; - Cmd: Word; - -begin - Result := False; - case Msg.message of - WM_HSCROLL, WM_VSCROLL: - if (Msg.lParam <> 0) then begin - {$IFDEF USE_PROP} - Bar := Pointer(GetProp(Msg.lParam, ID_SELF)); - {$ELSE} - Bar := Pointer( GetWindowLong( Msg.lParam, GWL_USERDATA ) ); - {$ENDIF} - if (Bar <> nil) then begin - ZeroMemory(@SI, SizeOf(SI)); - SI.cbSize := SizeOf(SI); - SI.fMask := SIF_RANGE or SIF_POS or SIF_TRACKPOS or SIF_PAGE; - Bar.SBGetScrollInfo(SI); - - Cmd := Msg.wParam and $0000FFFF; - case Cmd of - SB_BOTTOM: NewPos := SI.nMax; - SB_TOP: NewPos := SI.nMin; - SB_LINEDOWN: NewPos := SI.nPos + 1; - SB_LINEUP: NewPos := SI.nPos - 1; - SB_PAGEDOWN: NewPos := SI.nPos + Integer(SI.nPage); - SB_PAGEUP: NewPos := SI.nPos - Integer(SI.nPage); - {!ecm} - SB_THUMBPOSITION,SB_THUMBTRACK: NewPos := SI.nTrackPos; - SB_ENDSCROLL: NewPos := SI.nPos; - {/!ecm} - else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - - if (NewPos > SI.nMax - Integer(SI.nPage) + 1) then - NewPos := SI.nMax - Integer(SI.nPage) + 1; - if (NewPos < SI.nMin) then - NewPos := SI.nMin; - - AllowChange := True; - {$IFDEF NIL_EVENTS} - if Assigned(Bar.EV.fOnSBBeforeScroll) then - {$ENDIF} - Bar.EV.fOnSBBeforeScroll(Bar, SI.nPos, NewPos, Cmd, AllowChange); - if AllowChange then - SI.nPos := NewPos - else - SI.nTrackPos := SI.nPos; - Bar.DF.fSBPosition := SI.nPos; - Bar.DF.fSBPosition := Bar.SBSetScrollInfo(SI); - if AllowChange - {$IFDEF NIL_EVENTS} and Assigned(Bar.EV.fOnSBScroll) {$ENDIF} then - Bar.EV.fOnSBScroll(Bar, Cmd); - end; - end; - end; -end; - -function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl; -const SBS_Directions: array[ TScrollerBar ] of DWORD = ( SBS_HORZ or SBS_BOTTOMALIGN, - SBS_VERT or SBS_RIGHTALIGN ); -begin - Result := _NewCommonControl( AParent, 'SCROLLBAR', - WS_VISIBLE or WS_CHILD or SBS_Directions[ BarSide ], - False, {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:ScrollBar'; - {$ENDIF} - {!ecm} Result.GetWindowHandle; {/!ecm} - Result.DetachProc(WndProcCtrl); - Result.fLookTabKeys := [tkTab]; - - //#ecm Result.AttachProc(WndProcScrollBar); - AParent.AttachProc(WndProcScrollBarParent); -end; - -//===================== Scrollbox ========================// -function WndProcScrollBox( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Bar: DWORD; - SI: TScrollInfo; - OldNotifyProc: pointer; -begin - - case Msg.message of - WM_HSCROLL: Bar := SB_HORZ; - WM_VSCROLL: Bar := SB_VERT; - WM_SIZE: begin - {$IFDEF NIL_EVENTS} - if Assigned( Sender.PP.fNotifyChild ) then - {$ENDIF} - Sender.PP.fNotifyChild( Sender, nil ); - Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - else Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - - SI.cbSize := Sizeof( SI ); - SI.fMask := SIF_RANGE or SIF_POS or SIF_PAGE or - {$IFDEF F_P}$10{$ELSE}SIF_TRACKPOS{$ENDIF}; - GetScrollInfo( Sender.fHandle, Bar, SI ); - SI.fMask := SIF_POS; - case LoWord( Msg.wParam ) of - SB_BOTTOM: SI.nPos := SI.nMax; - SB_TOP: SI.nPos := SI.nMin; - SB_LINEDOWN: Inc( SI.nPos, Sender.DF.fScrollLineDist[ Bar ] ); - SB_LINEUP: Dec( SI.nPos, Sender.DF.fScrollLineDist[ Bar ] ); - SB_PAGEDOWN: Inc( SI.nPos, Max( SI.nPage, 1 ) ); - SB_PAGEUP: Dec( SI.nPos, Max( SI.nPage, 1 ) ); - SB_THUMBTRACK:SI.nPos := SI.nTrackPos; - end; - if SI.nPos > SI.nMax { - Integer( SI.nPage ) } then - SI.nPos := SI.nMax { - Integer( SI.nPage ) }; - if SI.nPos < SI.nMin then - SI.nPos := SI.nMin; - SetScrollInfo( Sender.fHandle, Bar, SI, TRUE ); - - {$IFDEF NIL_EVENTS} - if Assigned( Sender.PP.fScrollChildren ) then - {$ENDIF} - begin - OldNotifyProc := @ Sender.PP.fNotifyChild; - Sender.PP.fNotifyChild := @DummyObjProc; - Sender.PP.fScrollChildren( Sender ); - Sender.PP.fNotifyChild := OldNotifyProc; - end; - - SetScrollInfo( Sender.fHandle, Bar, SI, TRUE ); - Result := FALSE; -end; - -function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle; - Bars: TScrollerBars ): PControl; -var SBFlag: Integer; -begin - SBFlag := EdgeStyles[ EdgeStyle ]; - if sbHorizontal in Bars then - SBFlag := SBFlag or WS_HSCROLL; - if sbVertical in Bars then - SBFlag := SBFlag or WS_VSCROLL; - - Result := _NewControl( AParent, 'ScrollBox', WS_VISIBLE or WS_CHILD or - SBFlag, EdgeStyle = esLowered, - {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:ScrollBox'; - {$ENDIF} - Result.AttachProc( WndProcForm ); //!!! - Result.AttachProc( WndProcScrollBox ); - Result.AttachProc( WndProcDoEraseBkgnd ); - {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsControl ); - {$ELSE} Result.fIsControl := TRUE; {$ENDIF} -end; - -function Scrollbar_GetMinPos( sb: PControl ): Integer; -begin - Result := sb.SBMax; -end; -procedure Scrollbar_SetMinPos( sb: PControl; m: Integer ); -begin - sb.SBMin := m; -end; -procedure Scrollbar_SetAll( sb: PControl; min, max, pg, cur: Integer ); -begin - sb.SBMin := min; - sb.SBMax := max; - sb.SBPageSize := pg; - sb.SBPosition := cur; -end; -function Scrollbar_GetMaxPos( sb: PControl ): Integer; -begin - Result := sb.SBMax; -end; -procedure Scrollbar_SetMaxPos( sb: PControl; m: Integer ); -begin - sb.SBMax := m; -end; -function Scrollbar_GetCurPos( sb: PControl ): Integer; -begin - Result := sb.SBPosition; -end; -procedure Scrollbar_SetCurPos( sb: PControl; newp: Integer ); -begin - sb.SBPosition := newp; -end; -procedure Scrollbar_SetPageSz( sb: PControl; psz: Integer ); -begin - sb.SBPageSize := psz; -end; -function Scrollbar_GetPageSz( sb: PControl ): Integer; -begin - Result := sb.SBPageSize; -end; -procedure Scrollbar_SetLineSz( sb: PControl; lnz: Integer ); -begin - // -end; -function Scrollbar_GetLineSz( sb: PControl ): Integer; -begin - Result := 1; -end; - -function WndProcNotifyParentAboutResize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var P: PControl; -begin - if (Msg.message = WM_SIZE) or (Msg.message = WM_MOVE) or (Msg.message = CM_SHOW) then - begin - P := Sender.Parent; - if P <> nil then - {$IFDEF NIL_EVENTS} - if Assigned( P.PP.fNotifyChild ) then - {$ENDIF} - P.PP.fNotifyChild( P, nil ); - end - else - if Msg.message = WM_SHOWWINDOW then - PostMessage( Sender.fHandle, CM_SHOW, 0, 0 ); - Result := FALSE; -end; - -procedure CalcMinMaxChildren( Self_: PControl; var SzR: TRect ); -var I: Integer; - C: PControl; - R: TRect; -begin - Szr := MakeRect( 0, 0, 0, 0 ); - for I := 0 to Self_.fChildren.fCount - 1 do - begin - C := Self_.fChildren.Items[ I ]; - if C.ToBeVisible then - begin - R := C.BoundsRect; - if (SzR.Left = SzR.Right) or (R.Left < SzR.Left) or (R.Right > SzR.Right) then - begin - if SzR.Left = SzR.Right then - begin - SzR.Left := R.Left; - SzR.Right := R.Right; - end - else - begin - if R.Left < SzR.Left then SzR.Left := R.Left; - if R.Right > SzR.Right then SzR.Right := R.Right; - end; - end; - if (SzR.Top = SzR.Bottom) or (R.Top < SzR.Top) or (R.Bottom > SzR.Bottom) then - begin - if SzR.Top = SzR.Bottom then - begin - SzR.Top := R.Top; - SzR.Bottom := R.Bottom; - end - else - begin - if R.Top < SzR.Top then SzR.Top := R.Top; - if R.Bottom > SzR.Bottom then SzR.Bottom := R.Bottom; - end; - end; - end; - end; - Dec( SzR.Left, Self_.Border ); - Inc( SzR.Right, Self_.Border - 1 ); - Dec( SzR.Top, Self_.Border ); - Inc( SzR.Bottom, Self_.Border - 1 ); -end; - -procedure NotifyScrollBox( Self_, Child: PControl ); -var SI: TScrollInfo; - - procedure GetSetScrollInfo( SBar: DWORD; WH, R_RightBottom, SzR_LeftTop, SzR_RightBottom: Integer ); - {$IFDEF SBOX_OLDPOS} var OldPos: Double; {$ENDIF} - begin - {$IFDEF SBOX_OLDPOS} OldPos := 0; {$ENDIF} - if not GetScrollInfo( Self_.fHandle, SBar, SI ) then - begin - SI.nMin := 0; - SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 ); - end - else - begin - {$IFDEF SBOX_OLDPOS} - if SI.nMax > SI.nMin then - begin - OldPos := (SI.nPos - SI.nMin) / (SI.nMax - SI.nMin); - SI.nMin := 0; - SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 ); - if SzR_LeftTop < 0 then - SI.nMax := Max( R_RightBottom - SzR_LeftTop - 1, WH - 1 ); - end - else - begin - SI.nMin := 0; - SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 ); - end; - {$ENDIF} - SI.nMin := 0; {!ecm} - SI.nMax := SzR_RightBottom - SzR_LeftTop; {!ecm} - end; - {$IFDEF SBOX_OLDPOS} - SI.nPos := SI.nMin + Round( (SI.nMax - SI.nMin) * OldPos ); - {$ELSE} - SI.nPos := - SzR_LeftTop; - {$ENDIF} - SI.nPage := R_RightBottom; - SetScrollInfo( Self_.fHandle, SBar, SI, TRUE ); - end; - -var W, H: Integer; - SzR: TRect; - R: TRect; -begin - if ( Child <> nil ) then - begin - Child.AttachProc( WndProcNotifyParentAboutResize ); Exit; {>>>>>>>>>>>>>>} - end; - CalcMinMaxChildren( Self_, SzR ); - W := SzR.Right - SzR.Left; - H := SzR.Bottom - SzR.Top; - - R := Self_.ClientRect; - if (R.Right = 0) or (R.Bottom = 0) then - Exit; // for case when form is minimized {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SI.cbSize := sizeof( SI ); - SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS; - - SI.cbSize := sizeof( SI ); - SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS; - - GetSetScrollInfo( SB_HORZ, W, R.Right, SzR.Left, SzR.Right ); -{+ecm}R := Self_.ClientRect;{/+ecm} - GetSetScrollInfo( SB_VERT, H, R.Bottom, SzR.Top, SzR.Bottom ); -{+ecm} {$IFDEF NIL_EVENTS} - if Assigned( Self_.PP.fScrollChildren ) then - {$ENDIF} - Self_.PP.fScrollChildren(Self_); {/+ecm} -end; - -procedure ScrollChildren( _Self_: PControl ); -var SzR, R: TRect; - I, Xpos, Ypos: Integer; - OldNotifyProc: Pointer; - C: PControl; - DeltaX, DeltaY: Integer; - -begin - - CalcMinMaxChildren( _Self_, SzR ); - Xpos := GetScrollPos( _Self_.fHandle, SB_HORZ ); - Ypos := GetScrollPos( _Self_.fHandle, SB_VERT ); - - DeltaX := -Xpos - SzR.Left; - DeltaY := -Ypos - SzR.Top; - - if (DeltaX <> 0) or (DeltaY <> 0) then - begin - - OldNotifyProc := @ _Self_.PP.fNotifyChild; - _Self_.PP.fNotifyChild := @DummyObjProc; - - for I := 0 to _Self_.fChildren.fCount - 1 do - begin - C := _Self_.fChildren.Items[ I ]; - R := C.BoundsRect; - OffsetRect( R, DeltaX, DeltaY ); - C.BoundsRect := R; - end; - - _Self_.PP.fNotifyChild := OldNotifyProc; - CalcMinMaxChildren( _Self_, R ); - if //(SzR.Left <> R.Left) or (SzR.Top <> R.Top) or - //(Szr.Right <> R.Right) or (SzR.Bottom <> R.Bottom) - ((SzR.Right - SzR.Left) <> (R.Right - R.Left)) or - ((SzR.Bottom - SzR.Top) <> (R.Bottom - R.Top)) - then - {$IFDEF NIL_EVENTS} - if Assigned( _Self_.PP.fNotifyChild ) then - {$ENDIF} - _Self_.PP.fNotifyChild( _Self_, nil ); - - end; - -end; - -function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl; -begin - Result := NewScrollBox( AParent, EdgeStyle, [ ] ); - Result.PP.fNotifyChild := NotifyScrollBox; - Result.PP.fScrollChildren := ScrollChildren; - Result.DF.fScrollLineDist[ 0 ] := 16; - Result.DF.fScrollLineDist[ 1 ] := 16; -end; - -function WndProcOnScroll( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Bar: TScrollerBar; -begin - Bar := sbHorizontal; //0 - if Msg.message = WM_VSCROLL then - Bar := sbVertical - else - if Msg.message <> WM_HSCROLL then - begin - Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnScroll ) then - {$ENDIF} - Sender.EV.fOnScroll( Sender, Bar, LoWord( Msg.wParam ), - HiWord( Msg.wParam ) ); - Result := FALSE; -end; - -procedure TControl.SetOnScroll(const Value: TOnScroll); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .FOnScroll := Value; - AttachProc( @ WndProcOnScroll ); -end; - -//===================== Groupbox ========================// - -{$IFDEF USE_CONSTRUCTORS} -function NewGroupbox( AParent: PControl; const Caption: AnsiString ): PControl; -begin - new( Result, CreateGroupbox( AParent, Caption ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Groupbox'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl; -begin - Result := _NewControl( AParent, 'BUTTON', - WS_CHILD - or WS_CLIPSIBLINGS - or WS_CLIPCHILDREN - or WS_VISIBLE - or BS_GROUPBOX, - FALSE, {$IFDEF PACK_COMMANDACTIONS} ButtonActions_Packed - {$ELSE} @ButtonActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Groupbox'; - {$ENDIF} - Result.fExStyle := Result.fExStyle or WS_EX_CONTROLPARENT; - Result.Caption := Caption; - with Result.fBoundsRect do - begin - Right := Left + 100; - Bottom := Top + 100; - end; - Result.fClientTop := 22; - Result.fClientBottom := 2; - Result.fClientLeft := 2; - Result.fClientRight := 2; - {$IFDEF USE_FLAGS} - exclude( Result.fStyle.f2_Style, F2_Tabstop ); - include( Result.fFlagsG5, G5_IsGroupbox ); - {$ELSE} Result.fTabstop := False; - Result.fIsGroupBox := TRUE; - {$ENDIF} - Result.AttachProc( WndProcDoEraseBkgnd ); -{$IFDEF GRAPHCTL_XPSTYLES} - Attach_WM_THEMECHANGED(Result, XP_Themes_For_GroupBox); -{$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Panel ========================// - -{$IFDEF USE_CONSTRUCTORS} -function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl; -begin - new( Result, CreatePanel( AParent, EdgeStyle ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Panel'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl; -begin - Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or SS_NOTIFY or - SS_LEFTNOWORDWRAP or SS_NOPREFIX, False, - {$IFDEF PACK_COMMANDACTIONS} LabelActions_Packed - {$ELSE} @LabelActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Panel'; - {$ENDIF} - Result.aAutoSzX := 1; - Result.aAutoSzY := 1; - with Result.fBoundsRect do - begin - Right := Left + 100; - Bottom := Top + 100; - end; - Result.fStyle.Value := Result.fStyle.Value or Edgestyles[ EdgeStyle ]; - Result.fExStyle := Result.fExStyle or WS_EX_CONTROLPARENT; - Result.fVerticalAlign := vaTop; -{$IFDEF GRAPHCTL_XPSTYLES} - if AppTheming then - Result.fStyle.Value := Result.fStyle.Value and (not Edgestyles[ EdgeStyle ]); - Result.SetEdgeStyle(EdgeStyle); - Attach_WM_THEMECHANGED(Result, XP_Themes_For_Panel); -{$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Splitter ==============================// - -//{$DEFINE USE_ASM_DODRAG} - - {$IFNDEF USE_ASM_DODRAG} - {$DEFINE USE_PAS_DODRAG} - {$ENDIF} - {$IFNDEF ASM_VERSION} - {$DEFINE USE_PAS_DODRAG} - {$ENDIF} -{$IFDEF USE_PAS_DODRAG} -procedure DoDrag( Self_: PControl; Cancel: Boolean ); -var NewSize1, NewSize2: Integer; - MousePos: TPoint; - R: TRect; - Prev: PControl; - I, M : Integer; -begin - if {$IFDEF USE_FLAGS} G6_Dragging in Self_.fFlagsG6 - {$ELSE} Self_.fDragging {$ENDIF} then - begin - I := Self_.fParent.fChildren.IndexOf( Self_ ); - Prev := Self_; - if I > 0 then - Prev := Self_.FParent.fChildren.Items[ I - 1 ]; - GetCursorPos( MousePos ); - {$IFDEF SPEED_FASTER} - if (MousePos.X = Self_.DF.fSplitLastPos.X) - and (MousePos.Y = Self_.DF.fSplitLastPos.Y) then Exit; {>>>>>>>>>>>>>} - Self_.DF.fSplitLastPos := MousePos; - {$ENDIF SPEED_FASTER} - if Cancel then - MousePos := Self_.DF.fSplitStartPos; - M := 1; - if Self_.FAlign in [ caRight, caBottom ] then - M := -1; - if Self_.FAlign in [ caTop, caBottom ] then - begin - NewSize1 := (MousePos.y - Self_.DF.fSplitStartPos.y)* M - + Self_.DF.fSplitStartSize; - NewSize2 := Self_.fParent.ClientHeight - NewSize1 - - Self_.fBoundsRect.Bottom + Self_.fBoundsRect.Top - - Self_.fParent.fMargin * 4; - if Self_.DF.fSecondControl <> nil then - begin - NewSize2 := Self_.DF.fSecondControl.fBoundsRect.Bottom - - Self_.DF.fSecondControl.fBoundsRect.Top; - if Self_.DF.fSecondControl.FAlign = caClient then - NewSize2 := Self_.DF.fSplitStartPos2.y - - (MousePos.y - Self_.DF.fSplitStartPos.y)* M - - Self_.fParent.fMargin * 4; - end; - end else - begin - NewSize1 := (MousePos.x - Self_.DF.fSplitStartPos.x)* M - + Self_.DF.fSplitStartSize; - NewSize2 := Self_.fParent.ClientWidth - NewSize1 - - Self_.fBoundsRect.Right + Self_.fBoundsRect.Left - - Self_.fParent.fMargin * 4; - if Self_.DF.fSecondControl <> nil then - begin - NewSize2 := Self_.DF.fSecondControl.fBoundsRect.Right - - Self_.DF.fSecondControl.fBoundsRect.Left; - if Self_.DF.fSecondControl.FAlign = caClient then - NewSize2 := Self_.DF.fSplitStartPos2.x - - (MousePos.x - Self_.DF.fSplitStartPos.x)* M - - Self_.fParent.Margin * 4; - end; - end; - if (NewSize1 < Self_.DF.fSplitMinSize1) then - begin - Dec( NewSize2, Self_.DF.fSplitMinSize1 - NewSize1 ); - NewSize1 := Self_.DF.fSplitMinSize1; - end; - if (NewSize2 < Self_.DF.fSplitMinSize2) then - begin - Dec( NewSize1, Self_.DF.fSplitMinSize2 - NewSize2 ); - NewSize2 := Self_.DF.fSplitMinSize2; - end; - if NewSize1 < Self_.DF.fSplitMinSize1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>} - if NewSize2 < Self_.DF.fSplitMinSize2 then Exit; {>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnSplit ) then - {$ENDIF} - if not Self_.EV.fOnSplit( Self_, NewSize1, NewSize2 ) then Exit; {>>} - R := Prev.BoundsRect; - case Self_.FAlign of - caTop: R.Bottom := R.Top + NewSize1; - caBottom: R.Top := R.Bottom - NewSize1; - caRight: R.Left := R.Right - NewSize1; - else R.Right := R.Left + NewSize1; - end; - Prev.BoundsRect := R; - {$IFDEF OLD_ALIGN} - Global_Align( Self_.fParent ); - {$ELSE NEW_ALIGN} - Global_Align( Self_ ); - {$ENDIF} - end; -end; -{$ENDIF} - -const - chkLeft=2; - chkTop=4; - chkRight=8; - chkBott=16; - -{$DEFINE USE!_ASM_DODRAG} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var I: Integer; - Prev: PControl; - - procedure FinDrag; - begin - KillTimer( Self_.fHandle, $7B ); - {$IFDEF USE_FLAGS} exclude( Self_.fFlagsG6, G6_Dragging ); - {$ELSE} Self_.fDragging := False; {$ENDIF} - ReleaseCapture; - end; -begin - case Msg.message of - WM_NCHITTEST: - begin - Rslt := DefWindowProc( Self_.fHandle, Msg.message, Msg.wParam, Msg.lParam ); - if Rslt > 0 then - Rslt := HTCLIENT; - Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_MOUSEMOVE: - begin - Windows.SetCursor( Self_.fCursor ); - DoDrag( Self_, False ); - end; - WM_LBUTTONDOWN: - begin - if Self_.fParent <> nil then - begin - I := Self_.fParent.fChildren.IndexOf( Self_ ); - Prev := Self_; - if I > 0 then - Prev := Self_.FParent.fChildren.Items[ I - 1 ]; - if Self_.fAlign in [ caTop, caBottom ] then - Self_.DF.fSplitStartSize := Prev.Height - else - Self_.DF.fSplitStartSize := Prev.Width; - if Self_.DF.fSecondControl <> nil then - Self_.DF.fSplitStartPos2 := - MakePoint( Self_.DF.fSecondControl.Width, Self_.DF.fSecondControl.Height ); - SetCapture( Self_.fHandle ); - {$IFDEF SPEED_FASTER} - Self_.DF.fSplitLastPos := MakePoint( -1, -1 ); - {$ENDIF} - {$IFDEF USE_FLAGS} Include( Self_.fFlagsG6, G6_Dragging ); - {$ELSE} Self_.fDragging := True; {$ENDIF} - SetTimer( Self_.fHandle, $7B, 100, nil ); - GetCursorPos( Self_.DF.fSplitStartPos ); - end; - end; - WM_LBUTTONUP: - begin - DoDrag( Self_, False ); - FinDrag; - end; - WM_TIMER: - if {$IFDEF USE_FLAGS} (G6_Dragging in Self_.fFlagsG6) - {$ELSE} Self_.fDragging {$ENDIF} - and (GetAsyncKeyState( VK_ESCAPE ) < 0) then - begin - DoDrag( Self_, True ); - FinDrag; - end; - end; - Result := False; -end; -{$ENDIF PAS_VERSION} - -function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl; -begin - Result := NewSplitterEx( AParent, MinSizePrev, MinSizeNext, esLowered ); -end; - -{$IFDEF USE_CONSTRUCTORS} -function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer; - EdgeStyle: TEdgeStyle ): PControl; -begin - new( Result, CreateSplitter( AParent, MinSizePrev, MinSizeNext, EdgeStyle ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:SplitterEx'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer; - EdgeStyle: TEdgeStyle ): PControl; -var PrevCtrl: PControl; - Sz0: Integer; -begin - Result := NewPanel( AParent, EdgeStyle ); - Result.DF.fSplitMinSize1 := MinSizePrev; - Result.DF.fSplitMinSize2 := MinSizeNext; - {$IFDEF USE_FLAGS} include( Result.fFlagsG5, G5_IsSplitter ); - {$ELSE} Result.fIsSplitter := TRUE; {$ENDIF} - Sz0 := 4; - with Result.fBoundsRect do - begin - Right := Left + Sz0; - Bottom := Top + Sz0; - end; - if AParent <> nil then - begin - if AParent.fChildren.fCount > 1 then - begin - PrevCtrl := AParent.fChildren.Items[ AParent.fChildren.fCount - 2 ]; - case PrevCtrl.FAlign of - caLeft, caRight: - begin - Result.fCursor := LoadCursor( 0, IDC_SIZEWE ); - end; - caTop, caBottom: - begin - Result.fCursor := LoadCursor( 0, IDC_SIZENS ); - end; - end; - Result.Align := PrevCtrl.FAlign; - end; - end; - Result.AttachProc( WndProcSplitter ); -{$IFDEF GRAPHCTL_XPSTYLES} - Attach_WM_THEMECHANGED(Result, XP_Themes_For_Splitter); -{$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -{$IFDEF USE_MDI} -//===================== MDI client window control =============// - -procedure DestroyMDIChildren( Form: PControl ); -var MDIClient: PControl; - I: Integer; - Ch: PControl; - MDIChildren: PList; -begin - //MDIClient := Form.MDIClient; - MDIClient := nil; - for I := 0 to Form.ChildCount-1 do - begin - Ch := Form.Children[I]; - if Ch.PropInt[ MDI_CHLDRN ] <> 0 then - begin - MDIClient := Ch; - break; - end; - end; - if MDIClient = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - MDIClient.fAnchors := MDIClient.fAnchors or MDI_DESTROYING; - MDIChildren := Pointer( MDIClient.PropInt[ MDI_CHLDRN ] ); - if MDIChildren <> nil then - for I := MDIChildren.Count - 1 downto 0 do - begin - Ch := MDIChildren.Items[ I ]; - if Ch.fHandle <> 0 then - MDIClient.Perform( WM_MDIDESTROY, Ch.fHandle, 0 ); - end; - MDIChildren.Free; - MDIClient.PropInt[ MDI_CHLDRN ] := 0; - if Form.fMenu <> 0 then - begin - MDIClient.Perform( WM_MDISETMENU, 0, 0 ); - MDIClient.Perform( WM_MDIREFRESHMENU, 0, 0 ); - DrawMenuBar( Form.fHandle ); - Form.fMenuObj.Free; - Form.fMenuObj := nil; - end; - MDIClient.Free; -end; - -function ProcMDIAccel( Applet: PControl; var Msg: TMsg ): Boolean; -var Form: PControl; -begin - Result := FALSE; - if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then - begin - Form := Applet.ActiveControl; - if Form <> nil then - begin - if Form.IsMDIChild then - Form := Form.Parent; - Form := Form.ParentForm; - if (Form <> nil) and (Form.MDIClient <> nil) then - Result := TranslateMDISysAccel( Form.MDIClient.fHandle, - Windows.TMsg(Msg) ); - end; - end; -end; - -function CallDefFrameProc( Wnd: HWnd; Msg: Integer; wParam, lParam: Integer ): Integer; -stdcall; -var Form, MDIClient: PControl; -begin - {$IFDEF USE_PROP} - Form := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} - Form := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) ); - {$ENDIF} - if Form <> nil then - Form := Form.ParentForm; - MDIClient := Form.MDIClient; - if (Form <> nil) and (MDIClient <> nil) then - Result := DefFrameProc( Wnd, MDIClient.fHandle, Msg, wParam, lParam ) - else - Result := DefWindowProc( Wnd, Msg, wParam, lParam ); -end; - -function WndFuncMDIClient( Wnd: HWnd; Msg, wParam, lParam: Integer ): Integer; -stdcall; -var C: PControl; - M: TMsg; -begin - {$IFDEF USE_PROP} - C := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} - C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) ); - {$ENDIF} - if C <> nil then - begin - M.hwnd := Wnd; - M.message := Msg; - M.wParam := wParam; - M.lParam := lParam; - Result := C.WndProc( M ); - end - else - Result := DefWindowProc( Wnd, Msg, wParam, lParam ); -end; - -function ShowMDIClientEdge( MDIClient: PControl ): Boolean; -var ShowEdge: Boolean; - I: Integer; - Ch: PControl; - ExStyle: Integer; - MDIChildren: PList; -begin - Result := FALSE; - ShowEdge := TRUE; - MDIChildren := Pointer( MDIClient.PropInt[ MDI_CHLDRN ] ); - if MDIChildren.Count > 0 then - for I := 0 to MDIChildren.Count-1 do - begin - Ch := MDIChildren.Items[ I ]; - if IsZoomed( Ch.fHandle ) then - begin - ShowEdge := FALSE; - break; - end; - end; - ExStyle := MDIClient.ExStyle; - if ShowEdge then - if ExStyle and WS_EX_CLIENTEDGE = 0 then - ExStyle := ExStyle or WS_EX_CLIENTEDGE - else Exit {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - else if ExStyle and WS_EX_CLIENTEDGE <> 0 then - ExStyle := ExStyle and not WS_EX_CLIENTEDGE - else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - MDIClient.ExStyle := ExStyle; - Result := TRUE; -end; - -function WndProcMDIClient( MDIClient: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := FALSE; - if MDIClient.fAnchors and MDI_DESTROYING = 0 then - case Msg.message of - $3f: - begin - PostMessage( MDIClient.fHandle, CM_MDIClientShowEdge, 0, 0 ); - end; - CM_MDIClientShowEdge: - begin - ShowMDIClientEdge( MDIClient ); - end; - WM_NCHITTEST: // not necessary though - begin - Rslt := DefWindowProc( MDIClient.fHandle, WM_NCHITTEST, Msg.wParam, Msg.lParam ); - if Rslt = HTCLIENT then Rslt := HTTRANSPARENT; - end; - WM_WINDOWPOSCHANGING: - begin - MDIClient.Perform( WM_SETREDRAW, 0, 0 ); - end; - WM_WINDOWPOSCHANGED: - begin - Global_Align( {$IFDEF OLD_ALIGN}MDIClient.Parent{$ELSE}MDIClient{$ENDIF} ); - MDIClient.Invalidate; - MDIClient.Parent.Invalidate; - MDIClient.Perform( WM_SETREDRAW, 1, 0 ); - PostMessage( MDIClient.fHandle, CM_INVALIDATE, 0, 0 ); - end; - CM_INVALIDATE: - begin - MDIClient.InvalidateNC( TRUE ); - MDIClient.InvalidateEx; - end; - WM_DESTROY: - begin - MDIClient.FParent.fMDIClient := nil; - end; - end; -end; - -// function added by Thaddy de Koning to fix MDI behaviour -function WndProcParentNotifyMouseLDown( Sender: PControl; var Msg: TMsg; -var Rslt: Integer ): Boolean; -begin - Result := FALSE; - if (Sender.IsMDIChild) and (Msg.message = WM_PARENTNOTIFY) and - (LOWORD(msg.wparam)=WM_LBUTTONDOWN) then - BringWindowToTop( Sender.Handle ); -end; - -function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl; -var F: PControl; - CCS: TClientCreateStruct; - PrntWin: HWnd; -begin - PrntWin := 0; - if AParent <> nil then - begin - F := AParent.ParentForm; - if F <> nil then - begin - F.Add2AutoFreeEx( TObjectMethod( MakeMethod( F, @ DestroyMDIChildren ) ) ); - F.GetWindowHandle; // must be created before MDI client creation - F.fDefWndProc := @CallDefFrameProc; - end; - PrntWin := AParent.GetWindowHandle; - end; - Applet.PP.fExMsgProc := ProcMDIAccel; - Result := _NewControl( AParent, 'MDICLIENT', - WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or - WS_VISIBLE or WS_TABSTOP or MDIS_ALLCHILDSTYLES, TRUE, - {$IFDEF PACK_COMMANDACTIONS} PAnsiChar(OTHER_ACTIONS) - {$ELSE} nil {$ENDIF} ); - AParent.fMDIClient := Result; - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:MDIClient'; - {$ENDIF} - Result.fExStyle := WS_EX_CLIENTEDGE; - - CCS.hWindowMenu := WindowMenu; - CCS.idFirstChild := $FF00; - Result.fHandle := CreateWindowEx( WS_EX_CLIENTEDGE, 'MDICLIENT', nil, - WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or - WS_VISIBLE or WS_TABSTOP, - 0, 0, 0, 0, PrntWin, 0, hInstance, @ CCS ); - Result.fDefWndProc := Pointer( GetWindowLong( Result.fHandle, GWL_WNDPROC ) ); - SetWindowLong( Result.fHandle, GWL_WNDPROC, Integer( @WndFuncMDIClient ) ); - Result.PropInt[ MDI_CHLDRN ] := Integer( NewList ); - {$IFDEF USE_PROP} - SetProp( Result.fHandle, ID_SELF, Integer( Result ) ); - {$ELSE} - SetWindowLong( Result.fHandle, GWL_USERDATA, Integer( Result ) ); - {$ENDIF} - Result.AttachProc( WndProcMDIClient ); - Result.GetWindowHandle; - - Applet.AttachProc( WndProcParentNotifyMouseLDown ); -end; - -//===================== MDI child window object ==============// -function MDIChildFunc( Wnd: HWnd; Msg: DWord; wParam, lParam: Integer ): Integer; -stdcall; -var C: PControl; - M: TMsg; -begin - {$IFDEF USE_PROP} - C := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} - C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) ); - {$ENDIF} - if C <> nil then - begin - M.hwnd := Wnd; - M.message := Msg; - M.wParam := wParam; - M.lParam := lParam; - Result := C.WndProc( M ); - end - else - Result := DefMDIChildProc( Wnd, Msg, wParam, lParam ); -end; - -function Pass2DefMDIChildProc( Sender_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := FALSE; - if Sender_ = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Sender_.fParent = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if {$IFDEF USE_FLAGS} G2_Destroying in Sender_.fParent.fFlagsG2 - {$ELSE} Sender_.fParent.fDestroying {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>} - if (Msg.message = WM_SYSCOMMAND) or (Msg.message = WM_CHILDACTIVATE) or - (Msg.message = WM_SETFOCUS) or (Msg.message = WM_SIZE) or - (Msg.message = WM_MOVE) or (Msg.message = WM_MENUCHAR) or - (Msg.message = WM_GETMINMAXINFO) {and IsZoomed( Sender_.fHandle ) {and (Msg.hwnd = Sender_.fHandle) { -- doesn't work -- } - or (Msg.message = WM_PAINT) - then - begin - Rslt := DefMDIChildProc( Msg.hwnd, Msg.message, Msg.lParam, Msg.wParam ); - Result := TRUE; - end; -end; - -function WndProcMDIChild( MDIChild: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var ClientWnd: HWnd; - MDIClient: PControl; - MDIForm: PControl; - MDIChildren: PList; -begin - Result := FALSE; - MDIClient := MDIChild.Parent; - if MDIClient = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ClientWnd := MDIClient.fHandle; - if ClientWnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - case Msg.message of - WM_DESTROY: - begin - MDIChildren := Pointer( MDIClient.PropInt[ MDI_CHLDRN ] ); - MDIChildren.Remove( MDIChild ); - MDIForm := MDIClient.ParentForm; - if MDIForm <> nil then - if MDIForm.fHandle <> 0 then - DrawMenuBar( MDIForm.fHandle ); - MDIChild.Free; - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - if MDIChild.fAnchors and MDI_NOT_AVAILABLE <> 0 then - begin - MDIChild.fAnchors := MDIChild.fAnchors and not MDI_NOT_AVAILABLE; - MDIChild.Invalidate; - end; -end; - -procedure CreateMDIChildExt( Sender: PControl ); -var F: PControl; -begin - F := Sender.Parent; - if F <> nil then - F := F.ParentForm; - if F <> nil then - DrawMenuBar( F.fHandle ); -end; - -var mdi_child_id: Integer = $FF00; - -function NewMDIChild( AParent: PControl; const ACaption: KOLString ): PControl; -var MDIClient: PControl; - MDIChildren: PList; - i: Integer; -begin - {$IFDEF KOL_ASSERTIONS} - Assert( (AParent <> nil) and (AParent.ParentForm <> nil) and - (AParent.ParentForm.MDIClient <> nil), 'Error creating MDI child' ); - {$ENDIF KOL_ASSERTIONS} - MDIClient := AParent.ParentForm.MDIClient; - MDIChildren := Pointer( MDIClient.PropInt[ MDI_CHLDRN ] ); - - for i := 0 to MDIChildren.Count-1 do - begin - Result := MDIChildren.Items[i]; - //if Result.DF.fWindowState = wsMaximized then - if IsZoomed( Result.fHandle ) then - begin - MDIClient.Perform( WM_MDIRESTORE, Result.fHandle, 0 ); - end; - end; - - Result := NewForm( MDIClient, ACaption ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:MDIChild'; - {$ENDIF} - {$IFDEF USE_FLAGS} include( Result.fFlagsG3, G3_IsMDIChild ); - {$ELSE} Result.fIsMDIChild := TRUE; {$ENDIF} - Result.fMenu := mdi_child_id; // CtlIdCount; - Inc( mdi_child_id ); - - MDIChildren.Add( Result ); - Result.fExStyle := Result.fExStyle or WS_EX_MDICHILD; - Result.PP.fWndFunc := @ MDIChildFunc; - Result.fDefWndProc := @DefMDIChildProc; - Result.PP.fPass2DefProc := Pass2DefMDIChildProc; - Result.AttachProc( WndProcMDIChild ); - - Result.SubClassName := 'MDI_chld'; - Result.fAnchors := Result.fAnchors or MDI_NOT_AVAILABLE; - Result.PP.fCreateWndExt := CreateMDIChildExt; - Result.fCreateWindowProc := CreateMDIWindow; -end; -{$ENDIF USE_MDI} - -//===================== Gradient panel ========================// - -{$IFDEF USE_CONSTRUCTORS} -function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl; -begin - new( Result, CreateGradientPanel( AParent, Color1, Color2 ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:GradientPanel'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl; -begin - Result := NewLabel( AParent, '' ); - Result.AttachProc( WndProcGradient ); - Result.DF.fColor2 := Color2; - Result.DF.fColor1 := Color1; - with Result.fBoundsRect do - begin - Right := Left + 40; - Bottom := Top + 40; - end; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -{$IFDEF USE_CONSTRUCTORS} -function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor; - Style: TGradientStyle; Layout: TGradientLayout ): PControl; -begin - new( Result, CreateGradientPanelEx( AParent, Color1, Color2, - Style, Layout ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:GradientPanelEx'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor; - Style: TGradientStyle; Layout: TGradientLayout ): PControl; -begin - Result := NewLabel( AParent, '' ); - Result.AttachProc( WndProcGradientEx ); - Result.DF.fColor2 := Color2; - Result.DF.fColor1 := Color1; - Result.DF.fGradientStyle := Style; - Result.DF.fGradientLayout := Layout; - with Result.fBoundsRect do - begin - Right := Left + 40; - Bottom := Top + 40; - end; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Edit box ========================// - -const Editflags: array [ TEditOption ] of Integer = ( - not (ES_AUTOHSCROLL or WS_HSCROLL), - not (es_AutoVScroll or WS_VSCROLL), - es_Lowercase, es_Multiline, - es_NoHideSel, es_OemConvert, es_Password, es_Readonly, - es_UpperCase, es_WantReturn, 0, es_Number ); - -{$IFDEF USE_CONSTRUCTORS} -function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl; -begin - new( Result, CreateEditbox( AParent, Options ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Editbox'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF _D3orHigher} -function WndProcUnicodeChars( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var WStr, WW: KOLWideString; - RepeatCount: Integer; - C: KOLChar; -begin - Result := FALSE; - if (Msg.message = WM_CHAR) - and (Msg.wParam >= 32) - {$IFDEF UNICODE_CHAR_EXTCTL} - and (GetKeyState(VK_CONTROL) >= 0) - and (GetKeyState(VK_ALT) >= 0) - and (GetKeyState(VK_LWIN) >= 0) - and (GetKeyState(VK_RWIN) >= 0) - {$ENDIF} then - begin - Result := TRUE; - - {$IFDEF NIL_EVENTS} - if assigned( Sender.EV.fOnChar ) then - {$ENDIF} - begin - C := KOLChar( Msg.wParam ); - Sender.EV.fOnChar( Sender, C, GetShiftState ); - Msg.wParam := Integer( C ); - end; - - WStr := WideChar(Msg.wParam); - if WStr <> '' then - begin - RepeatCount := Msg.lParam and $FFFF; - if RepeatCount > 1 then - begin - WW := WStr[1]; - for RepeatCount := 2 to RepeatCount do - WStr := WStr + WW; - end; - Sender.ReplaceSelection( KOLString( WStr ), TRUE ); - end; - Rslt := 0; - end; -end; -{$ENDIF _D3orHigher} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl; -var Flags: Integer; -begin - Flags := MakeFlags( @Options, EditFlags ); - if not(eoMultiline in Options) then - Flags := Flags and not(WS_HSCROLL or WS_VSCROLL); - Result := _NewControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP - or WS_BORDER or Flags, True, - {$IFDEF PACK_COMMANDACTIONS} EditActions_Packed - {$ELSE} @EditActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Editbox'; - {$ENDIF} - Result.aAutoSzY := 6; - with Result.fBoundsRect do - begin - Right := Left + 100; - Bottom := Top + 22; - if eoMultiline in Options then - begin - Right := Right + 100; - Bottom := Top + 200; - {$IFDEF USE_FLAGS} include( Result.fFlagsG5, G5_IgnoreDefault ); - {$ELSE} Result.fIgnoreDefault := TRUE; {$ENDIF} - end; - end; - Result.fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ]; - if eoMultiline in Options then - Result.fLookTabKeys := [ tkTab ]; - if eoWantTab in Options then - exclude( Result.fLookTabKeys, tkTab ); - {$IFDEF UNICODE_CTRLS} - {$IFDEF _D3orHigher} - Result.AttachProc( WndProcUnicodeChars ); - {$ENDIF} - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== List box ========================// - -const ListFlags: array[TListOption] of Integer = ( - LBS_DISABLENOScroll, not LBS_ExtendedSel, - LBS_MultiColumn or WS_HSCROLL, - LBS_MultiPLESel, - LBS_NoIntegralHeight, LBS_NoSel, LBS_Sort, LBS_USETabstops, - not LBS_HASSTRINGS, LBS_NODATA, LBS_OWNERDRAWFIXED, - LBS_OWNERDRAWVARIABLE, WS_HSCROLL ); - -{$IFDEF USE_CONSTRUCTORS} -function NewListbox( AParent: PControl; Options: TListOptions ): PControl; -begin - new( Result, CreateListbox( AParent, Options ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Listbox'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function NewListbox( AParent: PControl; Options: TListOptions ): PControl; -var Flags: Integer; -begin - Flags := MakeFlags( @Options, ListFlags ); - Result := _NewControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP - or WS_BORDER or WS_VSCROLL - or LBS_NOTIFY or Flags, True, - {$IFDEF PACK_COMMANDACTIONS} ListActions_Packed - {$ELSE} @ListActions {$ENDIF} ); - {$IFDEF PACK_COMMANDACTIONS} - Result.fCommandActions.aClear := ClearListbox; - {$ENDIF} - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Listbox'; - {$ENDIF} - with Result.fBoundsRect do - begin - Right := Right + 100; - Bottom := Top + 200; - end; - Result.fColor := clWindow; - Result.fLookTabKeys := [ tkTab, tkLeftRight ]; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Combo box ========================// - -{$IFNDEF USE_DROPDOWNCOUNT} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure ComboboxDropDown( Sender: PObj ); -var - CB: PControl; - IC: Integer; -begin - CB := PControl( Sender ); - IC := CB.Count; - if IC > 8 then IC := 8; - if IC < 1 then IC := 1; - - SetWindowPos( CB.Handle, 0, 0, 0, CB.Width, CB.Height * (IC + 1) + 2, - SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_NOREDRAW + - SWP_HIDEWINDOW); - - SetWindowPos( CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE - + SWP_NOZORDER + SWP_NOACTIVATE - + SWP_NOREDRAW + SWP_SHOWWINDOW); - {$IFDEF NIL_EVENTS} - if assigned( CB.EV.fOnDropDown ) then - {$ENDIF} - CB.EV.fOnDropDown( CB ); -end; -{$ENDIF PAS_VERSION} -{$ELSE newcode} -procedure ComboboxDropDown( Sender: PObj ); -var - CB: PControl; - Count: Integer; - DropDownCount: Integer; - ItemHeight: Integer; -begin - CB := PControl(Sender); - Count := CB.Count; - DropDownCount := CB.DropDownCount; // 8; - if (Count > DropDownCount) then - Count := DropDownCount; - if (Count < 1) then - Count := 1; - ItemHeight := CB.Perform(CB_GETITEMHEIGHT, 0, 0); - SetWindowPos( - CB.Handle, 0, 0, 0, CB.Width, ItemHeight * Count + CB.Height + 2, - SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_HIDEWINDOW); - SetWindowPos( - CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER or - SWP_NOACTIVATE or SWP_NOREDRAW or SWP_SHOWWINDOW); - {$IFDEF NIL_EVENTS} - if Assigned(CB.EV.fOnDropDown) then - {$ENDIF} - CB.EV.fOnDropDown(CB); -end; -{$ENDIF USE_DROPDOWNCOUNT} - -function WndFuncCombo( W: HWnd; Msg: Cardinal; wParam, lParam: Integer ) - : Integer; stdcall; -var Combo, Form: PControl; - ParentWnd : HWnd; - MsgStruct: TMsg; - PrevProc:Pointer; //********************************** Added By M.Gerasimov -begin - Combo := nil; - - ParentWnd := GetParent( W ); - if ParentWnd <> 0 then - {$IFDEF USE_PROP} - Combo := Pointer( GetProp( ParentWnd, ID_SELF ) ); - {$ELSE} - Combo := Pointer( GetWindowLong( ParentWnd, GWL_USERDATA ) ); - {$ENDIF} - - if (Combo <> nil) then - begin - MsgStruct.hwnd := Combo.fHandle; - MsgStruct.message := Msg; - MsgStruct.wParam := wParam; - MsgStruct.lParam := lParam; - Form := Combo.ParentForm; - if fGlobalProcKeybd( Combo, MsgStruct, Result ) then Exit; {>>>>>>>>>>>>>} - if W <> Combo.FHandle then - begin - if ( Applet <> nil ) - {$IFDEF NIL_EVENTS} and Assigned( Applet.EV.fOnMessage ) {$ENDIF} then - if Applet.EV.fOnMessage( MsgStruct, Result ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (Applet <> Form) and (Form <> nil) then - {$IFDEF NIL_EVENTS} - if Assigned( Form.EV.fOnMessage ) then - {$ENDIF} - if Form.EV.fOnMessage( MsgStruct, Result ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if (Combo.ToBeVisible) and - ((Msg = WM_KEYDOWN) or (Msg = WM_KEYUP) or (Msg = WM_CHAR)) then - begin - Result := 0; - if (wParam = VK_TAB) then - begin - case Msg of - WM_KEYDOWN: - if {$IFDEF NIL_EVENTS} Assigned( Combo.PP.fGotoControl ) and {$ENDIF} - Combo.PP.fGotoControl( Combo, wParam, FALSE ) then Exit; {>>>>>>} - else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end - else - if (Msg = WM_CHAR) and ((wParam = VK_ESCAPE) or (wParam = VK_RETURN)) then - begin - if Combo.Perform( CB_GETDROPPEDSTATE, 0, 0 ) <> 0 then - begin - Combo.Perform( CB_SHOWDROPDOWN, 0, 0 ); - if wParam = VK_ESCAPE then - Combo.Perform( CB_SETCURSEL, Combo.DF.fCurIdxAtDrop, 0 ); - Combo.PP.fWndProcKeybd( Combo, MsgStruct, Result ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end - {$IFDEF ESC_CLOSE_DIALOGS} - //---------------------------------Babenko Alexey-------------------------- - else - if (wparam = VK_ESCAPE) then - if (combo.ParentForm.ExStyle and WS_EX_DLGMODALFRAME) <> 0 then begin - SendMessage(combo.ParentForm.Handle, WM_CLOSE, 0, 0); - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - {$ENDIF} - end; - {$IFDEF KEY_PREVIEW} - if {$IFDEF USE_FLAGS} not(G4_Pushed in Form.fFlagsG4) - {$ELSE} not Form.fKeyPreviewing {$ENDIF} then - begin - if {$IFDEF USE_FLAGS} G6_KeyPreview in Form.fFlagsG6 - {$ELSE} Form.fKeyPreview {$ENDIF} then - begin - {$IFDEF USE_FLAGS} include( Form.fFlagsG4, G4_Pushed ); - {$ELSE} Form.fKeyPreviewing := TRUE; {$ENDIF} - inc( Form.DF.FKeyPreviewCount ); - //Form.Perform(Msg, wParam, lParam); - Form.PP.fWndProcKeybd( Form, MsgStruct, Result ); - dec( Form.DF.fKeyPreviewCount ); - if MsgStruct.wParam = 0 then - begin - Result := 0; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; - {$ENDIF} - Combo.PP.fWndProcKeybd( Combo, MsgStruct, Result ); - end - else - if Msg = WM_SETFOCUS then - begin - if Form <> nil then Form.DF.fCurrentControl := Combo; - end; - MsgStruct.hwnd := W; -//********************************************************* Added By M.Gerasimov - PrevProc:=Pointer(GetProp( W, ID_PREVPROC )); - if PrevProc <> Nil then - Result := CallWindowProc( PrevProc , W, MsgStruct.message, - MsgStruct.wParam, MsgStruct.lParam ) - else - Result:=0; -//********************************************************* - end - else - Result := DefWindowProc( W, Msg, wParam, lParam ); -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure CreateComboboxWnd( Combo: PControl ); -var W : HWND; - PrevProc: DWORD; -begin - W := GetWindow( Combo.fHandle, GW_CHILD ); - {if W <> 0 then - W := GetWindow( W, GW_HWNDNEXT );} - while W <> 0 do - begin - PrevProc := - SetWindowLong( W, GWL_WNDPROC, Longint( @WndFuncCombo ) ); - SetProp( W, ID_PREVPROC, PrevProc ); // - W := GetWindow( W, GW_HWNDNEXT ); - end; -end; -{$ENDIF PAS_VERSION} - -procedure RemoveChldPrevProc( fHandle: HWnd ); -var Chld: HWnd; -begin - Chld := GetWindow( fHandle, GW_CHILD ); - while Chld <> 0 do - begin - if GetProp( Chld, ID_PREVPROC ) <> 0 then - RemoveProp(Chld, ID_PREVPROC); - Chld := GetWindow( Chld, GW_HWNDNEXT ); - end; -end; - -function WndProcCombo( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -{$IFDEF UNICODE_CTRLS} -var s: KOLString; - w: PWideChar; - L: Integer; -{$ENDIF} -begin - Result := FALSE; - if (Msg.message >= WM_CTLCOLORMSGBOX) and (Msg.message <= WM_CTLCOLORSTATIC) then - begin - Rslt := Sender.Perform( Msg.message + CN_BASE, Msg.wParam, Msg.lParam ); - Result := TRUE; - end - else - if (Msg.message >= CN_CTLCOLORMSGBOX) and (Msg.message <= CN_CTLCOLORSTATIC) then - begin - if {$IFDEF USE_FLAGS} G2_Transparent in Sender.fFlagsG2 - {$ELSE} Sender.fTransparent {$ENDIF} then - case Msg.message of - CN_CTLCOLORLISTBOX: - begin - SetBkMode( Msg.wParam, Windows.OPAQUE ); - SetBkColor(Msg.WParam, Color2RGB( Sender.fColor ) ); - Rslt := Global_GetCtlBrushHandle( Sender ); - Result := TRUE; - end; - end; - end - else - if (Msg.message = CM_COMMAND) and Sender.ToBeVisible then - begin - case HiWord( Msg.wParam ) of - CBN_DROPDOWN: - begin - Sender.DF.fCurIdxAtDrop := Sender.CurIndex; - //Sender.fDropDownProc( Sender ); - ComboboxDropDown( Sender ); - end; - CBN_CLOSEUP: - begin - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnCloseUp ) then - {$ENDIF} - Sender.EV.fOnCloseUp( Sender ); - end; - CBN_SELCHANGE: - begin - PostMessage( Sender.fHandle, CM_COMMAND, CM_CBN_SELCHANGE shl 16, 0 ); - end; - end; - end - else - if Msg.message = WM_DESTROY then - RemoveChldPrevProc( Sender.Handle ) - {$IFDEF UNICODE_CTRLS} - else - if (Msg.message = CB_INSERTSTRING) - or (Msg.message = CB_ADDSTRING) then - begin - if {$IFDEF USE_FLAGS} not(G5_IsButton in Sender.fFlagsG5) - {$ELSE} not Sender.fIsButton {$ENDIF} then - begin - {$IFDEF USE_FLAGS} Include( Sender.fFlagsG5, G5_IsButton ); - {$ELSE} Sender.fIsButton := TRUE; {$ENDIF} - w := Pointer( Msg.lParam ); - L := WStrLen( w ); - SetLength( s, L ); - move( w^, s[1], L * SizeOf(KOLChar) ); - Rslt := SendMessageW( Msg.hwnd, Msg.message, Msg.wParam, - Integer( @s[1] ) ); - Result := TRUE; - {$IFDEF USE_FLAGS} Exclude( Sender.fFlagsG5, G5_IsButton ); - {$ELSE} Sender.fIsButton := FALSE; {$ENDIF} - end; - end; - {$ENDIF} -end; - -const ComboFlags: array[ TComboOption ] of Integer = ( - CBS_DROPDOWNLIST, not CBS_AUTOHScroll, - CBS_DISABLENOSCROLL, CBS_LowerCase, CBS_NoIntegralHeight, - CBS_OemConvert, CBS_Sort, CBS_UpperCase, - CBS_OWNERDRAWFIXED, CBS_OWNERDRAWVARIABLE, CBS_SIMPLE ); - -{$IFDEF USE_CONSTRUCTORS} -function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl; -begin - new( Result, CreateCombobox( AParent, Options ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Combobox'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl; -var Flags: Integer; -begin - {$IFDEF GRAPHCTL_XPSTYLES} - {$IFDEF UNICODE_CTRLS} - InitCommonControls; - {$ENDIF} - {$ENDIF} - Flags := MakeFlags( @Options, ComboFlags ); - if not LongBool( Flags and CBS_SIMPLE ) then - Flags := Flags or CBS_DROPDOWN; - Result := _NewControl( AParent, 'COMBOBOX', - WS_VISIBLE - or WS_CHILD - or WS_VSCROLL - or CBS_HASSTRINGS or WS_TABSTOP - or Flags - ,True, - {$IFDEF PACK_COMMANDACTIONS} ComboActions_Packed - {$ELSE} @ComboActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Combobox'; - {$ENDIF} - {$IFDEF PACK_COMMANDACTIONS} - Result.fCommandActions.aClear := @ClearCombobox; - {$ENDIF} - Result.aAutoSzY := 6; - Result.PP.fCreateWndExt := CreateComboboxWnd; - Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS; - with Result.fBoundsRect do - begin - Right := Left + 100; - Bottom := Top + 22; - end; - Result.fLookTabKeys := [ tkTab ]; - if coReadOnly in Options then - Result.fLookTabKeys := [ tkTab, tkLeftRight ]; - Result.AttachProc( @ WndProcCombo ); - {$IFDEF USE_DROPDOWNCOUNT} - Result.DropDownCount := 8; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -{$IFDEF ASM_TLIST} -function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm - PUSH ESI - CMP word ptr [EDX].TMsg.message, WM_SIZE - JNZ @@exit - - MOV ESI, [EAX].TControl.fChildren - MOV ECX, [ESI].TList.fCount - JECXZ @@exit - MOV ESI, [ESI].TList.fItems -@@loo: PUSH ECX - LODSD - PUSH EAX - PUSH EAX - PUSH CM_SIZE - PUSH EAX - CALL TControl.Perform - POP ECX - LOOP @@loo - -@@exit: XOR EAX, EAX - POP ESI -end; -{$ELSE PAS_VERSION} //Pascal -function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var I: Integer; - C: PControl; -begin - if Msg.message = WM_SIZE then - begin - for I:= 0 to Self_.fChildren.fCount - 1 do - begin - C := Self_.fChildren.Items[ I ]; - C.Perform( CM_SIZE, 0, 0 ); - end; - end; - Result := False; // don't stop further processing -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := False; - case Msg.message of - CM_SIZE: - begin - Self_.Perform( WM_SIZE, 0, 0 ); - Self_.Invalidate; - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure InitCommonControlCommonNotify( Ctrl: PControl ); -var AParent: PControl; -begin - {$IFDEF USE_FLAGS} include( Ctrl.fFlagsG5, G5_IsCommonCtl ); - {$ELSE} Ctrl.fIsCommonControl := True; {$ENDIF} - AParent := Ctrl.Parent; - if AParent <> nil then - begin - Ctrl.AttachProc( WndProcCommonNotify ); - AParent.AttachProc( WndProcNotify ); - end; -end; -{$ENDIF PAS_VERSION} - -procedure InitCommonControlSizeNotify( Ctrl: PControl ); -var AParent: PControl; -begin - AParent := Ctrl.Parent; - if AParent <> nil then - begin - Ctrl.AttachProc( WndProcParentResize ); - AParent.AttachProc( WndProcResize ); - end; -end; - -function _NewCommonControl( AParent: PControl; ClassName: PKOLChar; Style: DWORD; - Ctl3D: Boolean; Actions: TCommandActionsParam ): PControl; -begin - {*************} DoInitCommonControls( ICC_WIN95_CLASSES ); - Result := _NewControl( AParent, ClassName, Style, Ctl3D, Actions ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:CommonControl'; - {$ENDIF} - InitCommonControlCommonNotify( Result ); -end; - -//==================== Progress bar ======================// - -{$IFDEF USE_CONSTRUCTORS} -function NewProgressbar( AParent: PControl ): PControl; -begin - new( Result, CreateProgressbar( AParent ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Progressbar'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewProgressbar( AParent: PControl ): PControl; -begin - Result := _NewCommonControl( AParent, PROGRESS_CLASS, - WS_CHILD or WS_VISIBLE, True, - {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( PROGRESS_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:ProgressBar'; - {$ENDIF} - with Result.fBoundsRect do - begin - Right := Left + 300; - Bottom := Top + 20; - end; - Result.fMenu := 0; - Result.fTextColor := clHighlight; - Result.fCommandActions.aSetBkColor := PBM_SETBKCOLOR; - //Result.fNCDestroyed := TRUE; // do not call DestroyWindow! -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -{$IFDEF USE_CONSTRUCTORS} -function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl; -begin - new( Result, CreateProgressbarEx( AParent, Options ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:ProgressBarEx'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl; -const ProgressBarFlags: array[ TProgressbarOption ] of Integer = - (PBS_VERTICAL, PBS_SMOOTH ); -begin - Result := NewProgressbar( AParent ); - Result.fStyle.Value := Result.fStyle.Value or - DWORD( MakeFlags( @Options, ProgressBarFlags ) ); -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== List view ========================// - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var NMhdr: PNMHdr; - Child: PControl; -begin - Result := False; - if Msg.message = WM_NOTIFY then - begin - NMhdr := Pointer( Msg.lParam ); - {$IFDEF USE_PROP} - Child := Pointer( GetProp( NMhdr.hwndFrom, ID_SELF ) ); - {$ELSE} - Child := Pointer( GetWindowLong( NMhdr.hwndFrom, GWL_USERDATA ) ); - {$ENDIF} - if (Child <> nil) - and (Child <> Self_) //+ by Galkov, Jun-2009 - then - begin - Msg.hwnd := Child.fHandle; - Result := EnumDynHandlers( Child, Msg, Rslt ); - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var NMhdr: PNMHdr; -begin - Result := False; - if Msg.message = WM_NOTIFY then - begin - NMHdr := Pointer( Msg.lParam ); - case NMHdr.code of - NM_RCLICK, - NM_CLICK: {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnClick ) then - {$ENDIF} - begin - {$IFDEF USE_FLAGS} - if NMHdr.code = NM_RCLICK then - include( Self_.fFlagsG6, G6_RightClick ) - else exclude( Self_.fFlagsG6, G6_RightClick ); - {$ELSE} Self_.fRightClick := NMHdr.code=NM_RCLICK; {$ENDIF} - Self_.EV.fOnClick( Self_ ); - end; - NM_KILLFOCUS: {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnLeave ) then - {$ENDIF} - Self_.EV.fOnLeave( Self_ ); - NM_RETURN, - NM_SETFOCUS: {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnEnter ) then - {$ENDIF} - Self_.EV.fOnEnter( Self_ ); - end; - end; -end; -{$ENDIF PAS_VERSION} - -const ListViewStyles: array[ TListViewStyle ] of DWORD = ( LVS_ICON, LVS_SMALLICON, - LVS_LIST, LVS_REPORT, LVS_REPORT or LVS_NOCOLUMNHEADER ); - ListViewFlags: array[ TListViewOption ] of Integer = ( LVS_ALIGNLEFT, LVS_AUTOARRANGE, - $400 {LVS_BUTTON}, LVS_EDITLABELS, LVS_NOLABELWRAP, - LVS_NOSCROLL, LVS_NOSORTHEADER, - not LVS_SHOWSELALWAYS, not LVS_SINGLESEL, LVS_SORTASCENDING, - LVS_SORTDESCENDING, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - LVS_OWNERDATA, LVS_OWNERDRAWFIXED ); - - ListViewExFlags: array[ TListViewOption ] of Integer = ( 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, LVS_EX_GRIDLINES, - LVS_EX_SUBITEMIMAGES, LVS_EX_CHECKBOXES, LVS_EX_TRACKSELECT, - LVS_EX_HEADERDRAGDROP, LVS_EX_FULLROWSELECT, LVS_EX_ONECLICKACTIVATE, - LVS_EX_TWOCLICKACTIVATE, LVS_EX_FLATSB, LVS_EX_REGIONAL, - LVS_EX_INFOTIP, LVS_EX_UNDERLINEHOT, LVS_EX_MULTIWORKAREAS, 0, 0 ); - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure ApplyImageLists2Control( Sender: PControl ); -var IL: PImageList; -begin - if Sender.fCommandActions.aSetImgList = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>} - IL := Sender.ImageListNormal; - if IL <> nil then - Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_NORMAL, IL.Handle ); - IL := Sender.ImageListSmall; - if IL <> nil then - Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_SMALL, IL.Handle ); - IL := Sender.ImageListState; - if IL <> nil then - Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_STATE, IL.Handle ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure ApplyImageLists2ListView( Sender: PControl ); -var Flags: DWORD; -begin - Flags := MakeFlags( @Sender.DF.fLVOptions, ListViewFlags ); - Sender.Style := Sender.Style and not $403F//$4FFC - or Flags or ListViewStyles[ Sender.DF.fLVStyle ]; - Flags := MakeFlags( @Sender.DF.fLVOptions, ListViewExFlags ); - Sender.Perform( LVM_SETEXTENDEDLISTVIEWSTYLE, $3FFF, Flags ); - ApplyImageLists2Control( Sender ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF USE_CONSTRUCTORS} -function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions; - ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl; -begin - new( Result, CreateListView( AParent, Style, Options, ImageListSmall, - ImageListNormal, ImageListState ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:ListView'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions; - ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl; -begin - Result := _NewCommonControl( AParent, WC_LISTVIEW, ListViewStyles[ Style ] or - LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP or WS_CLIPCHILDREN, - True, {$IFDEF PACK_COMMANDACTIONS} ListViewActions_Packed - {$ELSE} @ListViewActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:ListView'; - {$ENDIF} - {$IFDEF PACK_COMMANDACTIONS} - Result.fCommandActions.aClear := @ClearListView; - {$ENDIF} - Result.DF.fLVOptions := Options; - Result.DF.fLVStyle := Style; - Result.fStyle.Value := Result.fStyle.Value and not LVS_TYPESTYLEMASK - or DWORD( MakeFlags( @Options, ListViewFlags ) ); - Result.PP.fCreateWndExt := ApplyImageLists2ListView; - with Result.fBoundsRect do - begin - Right := Left + 200; - Bottom := Top + 150; - end; - Result.ImageListSmall := ImageListSmall; - Result.ImageListNormal := ImageListNormal; - Result.ImageListState := ImageListState; - Result.DF.fLVTextBkColor := clWindow; - Result.fLookTabKeys := [ tkTab ]; - //Result.fMargin := 0; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Tree view ========================// -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var NM: PNMTreeView; - DI: PTVDispInfo; - P: TPoint; - S: KOL_String; -begin - if Msg.message = WM_NOTIFY then - begin - NM := Pointer( Msg.lParam ); - case NM.hdr.code of - NM_RCLICK: - begin - GetCursorPos( P ); - P := Self_.Screen2Client( P ); - Self_.PostMsg( WM_RBUTTONUP, MK_RBUTTON or GetShiftState, - (P.x and $FFFF) or (P.y shl 16) ); - end; - TVN_BEGINDRAG {$IFDEF TV_DRAG_RBUTTON}, TVN_BEGINRDRAG{$ENDIF}: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnTVBeginDrag ) then - {$ENDIF} - Self_.EV.fOnTVBeginDrag( Self_, NM.itemNew.hItem ); - TVN_BEGINLABELEDIT: - begin - if {$IFDEF USE_FLAGS} G6_Dragging in Self_.fFlagsG6 - {$ELSE} Self_.fDragging {$ENDIF} then - begin - Rslt := 1; // do not allow edit while dragging - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - DI := Pointer( NM ); - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnTVBeginEdit ) then - {$ENDIF} - begin - Rslt := Integer( not Self_.EV.fOnTVBeginEdit( Self_, DI.item.hItem ) ); - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - TVN_ENDLABELEDIT: - begin - DI := Pointer( NM ); - if Assigned( Self_.EV.fOnTVEndEdit ) then - begin - S := DI.item.pszText; - if (DI.item.pszText = nil) then - begin - Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Rslt := Integer( - Self_.EV.fOnTVEndEdit( Self_, DI.item.hItem, S ) ); - end - else - Rslt := 1; - Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - TVN_ITEMEXPANDING: - begin - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnTVExpanding ) then - {$ENDIF} - begin - Rslt := Integer( Self_.EV.fOnTVExpanding( Self_, NM.itemNew.hItem, - NM.action = TVE_EXPAND ) ); - //Result := TRUE; //Exit; - end; - end; - TVN_ITEMEXPANDED: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnTVExpanded ) then - {$ENDIF} - Self_.EV.fOnTVExpanded( Self_, NM.itemNew.hItem, NM.action=TVE_EXPAND ); - TVN_SELCHANGING: - begin //------------------ TVN_SELCHANGING by Sergey Shisminzev - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnTVSelChanging ) then - {$ENDIF} - begin - Rslt := Integer( not Self_.EV.fOnTVSelChanging( Self_, NM.itemOld.hItem, NM.itemNew.hItem ) ); - //Result := TRUE; //Exit; - end; - end; //---------------------------------------- - TVN_SELCHANGED: - Self_.DoSelChange; - end; - end; - Result := False; -end; -{$ENDIF PAS_VERSION} - -function ProcTVDeleteItem( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var NM: PNMTreeView; -begin - if Msg.message = WM_NOTIFY then - begin - NM := Pointer( Msg.lParam ); - case NM.hdr.code of - TVN_DELETEITEM: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnTVDelete ) then - {$ENDIF} - Self_.EV.fOnTVDelete( Self_, NM.itemOld.hItem ); - end; - end; - Result := FALSE; -end; - -procedure ClearTreeView( TV: PControl ); -begin - TV.TVDelete( TVI_ROOT ); -end; - -const - TreeViewFlags: array[ TTreeViewOption ] of Integer = ( not TVS_HASLINES, TVS_LINESATROOT, - not TVS_HASBUTTONS, TVS_EDITLABELS, not TVS_SHOWSELALWAYS, - not TVS_DISABLEDRAGDROP, TVS_NOTOOLTIPS, TVS_CHECKBOXES, - TVS_TRACKSELECT, TVS_SINGLEEXPAND, TVS_INFOTIP, - TVS_FULLROWSELECT, TVS_NOSCROLL, TVS_NONEVENHEIGHT ); - -{$IFDEF USE_CONSTRUCTORS} -function NewTreeView( AParent: PControl; Options: TTreeViewOptions; - ImgListNormal, ImgListState: PImageList ): PControl; -begin - new( Result, CreateTreeView( AParent, Options, ImgListNormal, ImgListState ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:TreeView'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewTreeView( AParent: PControl; Options: TTreeViewOptions; - ImgListNormal, ImgListState: PImageList ): PControl; -var Flags: Integer; -begin - Flags := MakeFlags( @Options, TreeViewFlags ); - Result := _NewCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or - WS_CHILD or WS_TABSTOP, True, {$IFDEF PACK_COMMANDACTIONS} TreeViewActions_Packed - {$ELSE} @TreeViewActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:TreeView'; - {$ENDIF} - {$IFDEF PACK_COMMANDACTIONS} - Result.fCommandActions.aClear := @ClearTreeView; - {$ENDIF} - Result.PP.fCreateWndExt := ApplyImageLists2Control; - Result.fColor := clWindow; - Result.AttachProc( WndProcTreeView ); - with Result.fBoundsRect do - begin - Right := Left + 150; - Bottom := Top + 200; - end; - Result.ImageListNormal := ImgListNormal; - Result.ImageListState := ImgListState; - Result.fLookTabKeys := [ tkTab ]; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Tab Control ========================// - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Hdr: PNMHdr; - A: Integer; - R: TRect; - WasActive: Boolean; -{$IFDEF OLD_ALIGN} - Page: PControl; - I: Integer; -begin - case Msg.message of - WM_NOTIFY: - begin - Hdr := Pointer( Msg.lParam ); - case Hdr.code of - TCN_SELCHANGING: - Self_.fCurIndex := Self_.GetCurIndex; - TCN_SELCHANGE: - begin - A := {Self_.????}Self_.GetCurIndex; - WasActive := Self_.fCurIndex = A; - Self_.fCurIndex := A; - for I := 0 to Self_.Count - 1 do - begin - Page := Self_.Pages[ I ]; - Page.Visible := A = I; - if A = I then - Page.BringToFront; - end; - if not WasActive then - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnSelChange ) then - {$ENDIF} - Self_.EV.fOnSelChange( Self_ ); - end; - end; - end; - WM_SIZE: - begin - GetClientRect( Self_.fHandle, R ); - Self_.Perform( TCM_ADJUSTRECT, 0, Integer( @R ) ); - for I := 0 to Self_.Count - 1 do - begin - Page := Self_.Pages[ I ]; - Page.BoundsRect := R; - end; -{$ELSE NEW_ALIGN} -begin - case Msg.message of - WM_NOTIFY: - begin - Hdr := Pointer( Msg.lParam ); - case Hdr.code of - TCN_SELCHANGING: - Self_.fCurIndex := Self_.GetCurIndex; - TCN_SELCHANGE: - begin - A := Self_.GetCurIndex; - WasActive := Self_.fCurIndex = A; - if (not WasActive)and(Self_.fCurIndex>=0) then - Self_.Pages[Self_.fCurIndex].Visible := false; - Self_.fCurIndex := A; - Self_.Pages[Self_.fCurIndex].Visible := true; - Self_.Pages[Self_.fCurIndex].BringToFront; - if not WasActive then - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnSelChange ) then - {$ENDIF} - Self_.EV.fOnSelChange( Self_ ); - end; - end; - end; - WM_SIZE: - begin - GetClientRect( Self_.fHandle, R ); - Self_.fClientRight := R.Right; - Self_.fClientBottom := R.Bottom; - Self_.Perform( TCM_ADJUSTRECT, 0, Integer( @R ) ); - Self_.fClientLeft := R.Left; - Self_.fClientTop := R.Top; - Dec(Self_.fClientRight,R.Right); - Dec(Self_.fClientBottom,R.Bottom); -{$ENDIF} - end; - end; - Result := False; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF GRAPHCTL_XPSTYLES} - {$DEFINE RICHEDIT_XPBORDER} -{$ENDIF} - -{$IFDEF RICHEDIT_XPBORDER} -function WndProc_RichEditXPBorder( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var ExStyle: DWORD; - DrawRect, EmptyRect: TRect; - DC: HDC; - Details: TThemedElementDetails; -begin - Result := FALSE; - if Msg.message = WM_NCPAINT then - begin - ExStyle := GetWindowLong(Self_.Handle, GWL_EXSTYLE); - if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then - begin - GetWindowRect(Self_.Handle, DrawRect); - OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top); - DC := GetWindowDC(Self_.Handle); - //try - EmptyRect := DrawRect; - with DrawRect do - ExcludeClipRect(DC, Left + 2, Top + 2, Right - 2, Bottom - 2); - Details.Element := teEdit; - Details.Part := 1 {EP_EDITTEXT}; - Details.State := Ord(teEditTextNormal) - Ord(teEditTextNormal) + 1; - if not Assigned( DrawThemeBackground ) then - begin - ThemeLibrary := LoadLibrary(themelib); - DrawThemeBackground := GetProcAddress(ThemeLibrary, 'DrawThemeBackground'); - OpenThemeData := GetProcAddress(ThemeLibrary, 'OpenThemeData'); - end; - if Assigned( DrawThemeBackground ) then - begin - Result := TRUE; - Rslt := Self_.CallDefWndProc( Msg ); - with Details do - DrawThemeBackground(OpenThemeData(0, 'edit'), - DC, Part, State, DrawRect, nil); - end; - //finally - ReleaseDC(Self_.Handle, DC); - //end; - end; - end; -end; -{$ENDIF RICHEDIT_XPBORDER} - -const TabControlFlags: array[ TTabControlOption ] of Integer = ( TCS_BUTTONS, - TCS_FIXEDWIDTH, not TCS_FOCUSNEVER, - TCS_FIXEDWIDTH or TCS_FORCEICONLEFT, TCS_FIXEDWIDTH or TCS_FORCELABELLEFT, - TCS_MULTILINE, TCS_MULTISELECT, TCS_RIGHTJUSTIFY, TCS_SCROLLOPPOSITE, - TCS_BOTTOM, TCS_VERTICAL, TCS_FLATBUTTONS, TCS_HOTTRACK, 0, TCS_OWNERDRAWFIXED ); - -{$IFDEF USE_CONSTRUCTORS} -function NewTabControl( AParent: PControl; Tabs: array of String; Options: TTabControlOptions; - ImgList: PImageList; ImgList1stIdx: Integer ): PControl; -begin - new( Result, CreateTabControl( AParent, Tabs, Options, ImgList, ImgList1stIdx ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:TabControl'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function NewTabControl( AParent: PControl; const Tabs: array of PKOLChar; Options: TTabControlOptions; - ImgList: PImageList; ImgList1stIdx: Integer ): PControl; -var I, II : Integer; - Flags: Integer; -begin - Flags := MakeFlags( @Options, TabControlFlags ); - if tcoFocusTabs in Options then - Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN); - Result := _NewCommonControl( AParent, WC_TABCONTROL, - Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE), - True, {$IFDEF PACK_COMMANDACTIONS} TabControlActions_Packed - {$ELSE} @TabControlActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:TabControl'; - {$ENDIF} - if not( tcoBorder in Options ) then - begin - Result.fExStyle := Result.fExStyle and not WS_EX_CLIENTEDGE; - end; - Result.AttachProc( WndProcTabControl ); - with Result.fBoundsRect do - begin - Right := Left + 100; - Bottom := Top + 100; - end; - if ImgList <> nil then - Result.Perform( TCM_SETIMAGELIST, 0, ImgList.Handle ); - II := ImgList1stIdx; - for I := 0 to High( Tabs ) do - begin - Result.TC_Insert( I, Tabs[ I ], II ); - Inc( II ); - end; - Result.fLookTabKeys := [ tkTab ]; -end; -{$ENDIF PAS_VERSION} - -{$IFNDEF OLD_ALIGN} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewTabEmpty( AParent: PControl; Options: TTabControlOptions; - ImgList: PImageList ): PControl; -var Flags: Integer; -begin - Flags := MakeFlags( @Options, TabControlFlags ); - if tcoFocusTabs in Options then - Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN); - Result := _NewCommonControl( AParent, WC_TABCONTROL, - Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE), - True, {$IFDEF PACK_COMMANDACTIONS} TabControlActions_Packed - {$ELSE} @TabControlActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:TabControl(TabEmpty)'; - {$ENDIF} - if not( tcoBorder in Options ) then - Result.fExStyle := Result.fExStyle and not WS_EX_CLIENTEDGE; - Result.AttachProc( WndProcTabControl ); - with Result.fBoundsRect do begin - Right := Left + 100; - Bottom := Top + 100; - end; - if ImgList <> nil then - Result.Perform( TCM_SETIMAGELIST, 0, ImgList.Handle ); - Result.fLookTabKeys := [ tkTab ]; -end; -{$ENDIF PAS_VERSION} -{$ENDIF} - -{$ENDIF USE_CONSTRUCTORS} - -//===================== Tool bar ========================// - -{$IFDEF ASM_TLIST} //TTN_NEEDTEXTW ASM_TLIST! -{$IFDEF _D3orHigher} -{$IFDEF ASM_VERSION} -procedure CopyPChar2WideChars( dest: PWideChar; src: PChar; Len: Integer ); -asm - PUSH ESI - PUSH EDI - XCHG EDI, EAX - MOV ESI, ECX - PUSH 0 - MOV EAX, ESP - CALL System.@LStrFromPChar - MOV EAX, [ESP] - CALL System.@LStrLen - TEST EAX, EAX - JZ @@exit_copy - CMP ESI, EAX - JL @@1_len - XCHG EAX, ESI -@@1_len: - POP EDX - PUSH EDX - PUSH 0 - MOV EAX, ESP - CALL System.@WStrFromLStr - - MOV ECX, ESI - INC ECX - POP ESI - PUSH ESI - REP MOVSW - MOV EAX, ESP - CALL System.@WStrClr - POP EAX -@@exit_copy: - MOV EAX, ESP - CALL System.@LStrClr - POP EAX - POP EDI - POP ESI -end; -{$ELSE PAS_VERSION} -procedure CopyPChar2WideChars( dest: PWideChar; src: PChar; Len: Integer ); -var W: WideString; - s: String; -begin - s := src; - if Len > Length(s) then - Len := Length(s); - W := s; - Move( W[1], dest^, (Len+1) * Sizeof( WideChar ) ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF _D3orHigher} - -function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -asm - PUSH EBX - XOR EBX, EBX - CMP word ptr [EDX].TMsg.message, WM_WINDOWPOSCHANGED - JNE @@chk_CM_COMMAND - MOV dword ptr [ECX], 0 // Rslt := 0 - XCHG EDX, EAX - {$IFDEF EVENTS_DYNAMIC} - MOV EDX, [EDX].TControl.EV - MOV ECX, [EDX].TEvents.fOnResize.TMethod.Code - MOV EAX, [EDX].TEvents.fOnResize.TMethod.Data - {$ELSE} - MOV ECX, [EDX].TControl.EV.fOnResize.TMethod.Code - MOV EAX, [EDX].TControl.EV.fOnResize.TMethod.Data - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@ret_true1 - {$ENDIF} - CALL ECX // Self_.fOnResize -@@ret_true1: - MOV AL, 1 // Result := TRUE - POP EBX - RET -@@chk_CM_COMMAND: ////////////////////////////////////////////////////////////// - CMP word ptr [EDX].TMsg.message, CM_COMMAND - JNE @@chk_WM_NOTIFY - MOVZX ECX, word ptr [EDX].TMsg.wParam - MOV [EAX].TControl.DF.fTBCurItem, ECX - XCHG EBX, EAX - PUSH 0 - PUSH ECX - PUSH TB_COMMANDTOINDEX - PUSH EBX - CALL TControl.Perform - PUSH EAX - PUSH VK_RETURN - CALL GetKeyState - TEST EAX, EAX - POP ECX - MOV [EBX].TControl.fCurIndex, ECX - {$IFDEF USE_FLAGS} - SETL DL - SHL DL, G6_RightClick - AND [EBX].TControl.fFlagsG6, not(1 shl G6_RightClick) - OR [EBX].TControl.fFlagsG6, DL - {$ELSE} - SETL DL - MOV [EBX].TControl.fRightClick, DL - {$ENDIF} -@@ret_false1: - XOR EAX, EAX - POP EBX - RET -@@chk_WM_NOTIFY: /////////////////////////////////////////////////////////////// - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNE @@ret_false1 - MOV EDX, [EDX].TMsg.lParam - MOV ECX, [EDX].TTooltipText.hdr.code - CMP ECX, TTN_NEEDTEXT - JE @@TTN_NEEDTEXT - CMP ECX, TTN_NEEDTEXTW - JNE @@chk_NM_RCLICK - MOV BL, 1 -@@TTN_NEEDTEXT: - PUSH EAX // ###> - PUSH EDX // ***> - MOV EDX, [EDX].TTooltipText.hdr.idFrom - MOV ECX, [EAX].TControl.DF.fTBttCmd - OR EAX, -1 - JECXZ @@idxReady - XCHG EAX, ECX - CALL TList.IndexOf -@@idxReady: // EAX = -1 or index of button tooltip - POP EDX //<*** - LEA EDX, [EDX].TTooltipText.szText - AND word ptr [EDX], 0 - POP ECX //<### - TEST EAX, EAX - JL @@ret_true1 - MOV ECX, [ECX].TControl.DF.fTBttTxt - MOV ECX, [ECX].TStrList.fList - MOV ECX, [ECX].TList.fItems - MOV EAX, [ECX+EAX*4] - XCHG EAX, EDX - XOR ECX, ECX - MOV CL, 79 - {$IFDEF _D3orHigher} - CMP BL, 0 - JZ @@strlcopy - {$IFDEF UNICODE_CTRLS} - CALL WStrLCopy - {$ELSE} - //CALL CopyPChar2WideChars (inlined here) - PUSH ESI - PUSH EDI - XCHG EDI, EAX - MOV ESI, ECX - PUSH 0 - MOV EAX, ESP - CALL System.@LStrFromPChar - MOV EAX, [ESP] - CALL System.@LStrLen - TEST EAX, EAX - JZ @@exit_copy - CMP ESI, EAX - JL @@1_len - XCHG EAX, ESI -@@1_len: - POP EDX - PUSH EDX - PUSH 0 - MOV EAX, ESP - CALL System.@WStrFromLStr - - MOV ECX, ESI - INC ECX - POP ESI - PUSH ESI - REP MOVSW - MOV EAX, ESP - CALL System.@WStrClr - POP EAX -@@exit_copy: - MOV EAX, ESP - CALL System.@LStrClr - POP EAX - POP EDI - POP ESI - {$ENDIF} - JMP @@ret_true1 - {$ENDIF _D3orHigher} -@@strlcopy: - CALL StrLCopy - JMP @@ret_true1 -@@chk_NM_RCLICK: /////////////////////////////////////////////////////////////// - CMP ECX, NM_RCLICK - JNE @@chk_NM_CLICK - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG6, 1 shl G6_RightClick - {$ELSE} - OR [EAX].TControl.fRightClick, 1 - {$ENDIF} - MOV ECX, [EDX].TNMMouse.dwItemSpec - OR [EAX].TControl.fCurIndex, -1 - XCHG EBX, EAX - PUSH 0 - PUSH ECX - PUSH TB_COMMANDTOINDEX - PUSH EBX - CALL TControl.Perform - MOV [EBX].TControl.fCurIndex, EAX - JMP @@ret_false1 -@@chk_NM_CLICK: /////////////////////////////////////////////////////////////// - CMP ECX, NM_CLICK - JNE @@chk_TBN_DROPDOWN - {$IFDEF USE_FLAGS} - AND [EAX].TControl.fFlagsG6, not(1 shl G6_RightClick) - {$ELSE} - MOV [EAX].TControl.fRightClick, 0 - {$ENDIF} - OR [EAX].TControl.DF.fTBCurItem, -1 - OR [EAX].TControl.fCurIndex, -1 - CMP [EDX].TTBNotify.iItem, -1 - SETNZ AL - POP EBX - RET -@@chk_TBN_DROPDOWN: //////////////////////////////////////////////////////////// - CMP ECX, TBN_DROPDOWN - JNE @@ret_false1 - MOV EDX, [EDX].TTBNotify.iItem - MOV [EAX].TControl.DF.fTBCurItem, EDX - PUSH EAX - CALL TControl.TBItem2Index - POP EDX - MOV [EDX].TControl.fCurIndex, EAX - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EDX].TControl.EV - MOV ECX, [EAX].TEvents.fOnDropDown.TMethod.Code - {$ELSE} - MOV ECX, [EDX].TControl.EV.fOnDropDown.TMethod.Code - {$ENDIF} - {$IFDEF NIL_EVENTS} - JECXZ @@ret_z - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnDropDown.TMethod.Data - {$ELSE} - MOV EAX, [EDX].TControl.EV.fOnDropDown.TMethod.Data - {$ENDIF} - CALL ECX -@@ret_z: - XOR EAX, EAX - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -var lpttt: PTooltipText; - idBtn, Idx: Integer; -var Notify: PTBNotify; - Mouse: PNMMouse; -{$IFNDEF _FPC} -{$IFNDEF _D2} -var WStr: KOLWideString; -{$ENDIF _D2} -{$ENDIF _FPC} -begin - Result := False; - if Msg.message = WM_WINDOWPOSCHANGED then - begin - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnResize ) then - {$ENDIF} - Self_.EV.fOnResize( Self_ ); - {$IFNDEF TOOLBAR_FORCE_CHILDALIGN} - //-- removed by MTsv DN (v.290), crash in Win 98: - //-- if WinVer >= wvNT then // todo: check it. - Result := TRUE; // this provides (prevents?) the Align working for child controls of Toolbar ! - // but removing this line makes it impossible to correct the Align property for - // the neighbour controls on form!!! - {$ENDIF} - Rslt := 0; - end - else if Msg.message = CM_COMMAND then - begin - Self_.DF.fTBCurItem := Loword( Msg.wParam ); - Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Loword( Msg.wParam ), 0 ); - {$IFDEF USE_FLAGS} - if GetKeyState( VK_RBUTTON ) < 0 then - include( Self_.fFlagsG6, G6_RightClick ) - else exclude( Self_.fFlagsG6, G6_RightClick ); - {$ELSE} Self_.fRightClick := GetKeyState( VK_RBUTTON ) < 0; {$ENDIF} - end - else if Msg.message = WM_NOTIFY then - begin - lpttt := Pointer( Msg.lParam ); - Notify := Pointer( Msg.lParam ); - case lpttt.hdr.code of - TTN_NEEDTEXT: - begin - Result := True; - idBtn := lpttt.hdr.idFrom; - Idx := -1; - if Self_.DF.fTBttCmd <> nil then - Idx := Self_.DF.fTBttCmd.IndexOf( Pointer( idBtn ) ); - lpttt.szText[ 0 ] := #0; - if Idx >= 0 then - {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF} - ( lpttt.szText, Self_.DF.fTBttTxt.fList.Items[ Idx ], 79 ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - {$IFNDEF _FPC} - {$IFNDEF _D2} - TTN_NEEDTEXTW: // for Windows XP - begin - Result := True; - idBtn := lpttt.hdr.idFrom; - Idx := -1; - if Self_.DF.fTBttCmd <> nil then - Idx := Self_.DF.fTBttCmd.IndexOf( Pointer( idBtn ) ); - ZeroMemory( @lpttt.szText[ 0 ], 160 ); - if Idx >= 0 then - begin - WStr := KOLWideString(Self_.DF.fTBttTxt.Items[ Idx ]); - if WStr <> '' then - Move( Wstr[ 1 ], lpttt.szText, Min( 158, - (Length( WStr ) + 1) * Sizeof(WideChar) ) ); - end; - Exit;{>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - {$ENDIF _D2} - {$ENDIF _FPC} - NM_RCLICK: - begin - Mouse := Pointer( Msg.lParam ); - Self_.DF.fTBCurItem := Mouse.dwItemSpec; - Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Mouse.dwItemSpec, 0 ); - {$IFDEF USE_FLAGS} include( Self_.fFlagsG6, G6_RightClick ); - {$ELSE} Self_.fRightClick := True; {$ENDIF} - end; - NM_CLICK: - begin - Self_.DF.fTBCurItem := -1; // return CurItem = -1 - Self_.fCurIndex := -1; - {$IFDEF USE_FLAGS} - exclude( Self_.fFlagsG6, G6_RightClick ); - {$ELSE} - Self_.fRightClick := False; - {$ENDIF} - Result := Notify.iItem <> -1; // do not handle - will be handled in WM_COMMAND - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - TBN_DROPDOWN: - begin - Self_.DF.fTBCurItem := Notify.iItem; - Self_.fCurIndex := Self_.TBItem2Index( Self_.DF.fTBCurItem ); - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnDropDown ) then - {$ENDIF} - Self_.EV.fOnDropDown( Self_ ); - end; - end; - end; -end; -{$ENDIF PAS_VERSION} - -const ToolbarAligns: array[ TControlAlign ] of DWORD = - ( CCS_NOPARENTALIGN {or CCS_NOMOVEY} {or CCS_NORESIZE} or CCS_NODIVIDER, CCS_TOP or CCS_VERT, CCS_TOP, CCS_BOTTOM or CCS_VERT, CCS_BOTTOM, - CCS_TOP ); - ToolbarOptions: array[ TToolbarOption ] of Integer = ( TBSTYLE_LIST, not TBSTYLE_LIST, - TBSTYLE_FLAT, TBSTYLE_TRANSPARENT, TBSTYLE_WRAPABLE, CCS_NODIVIDER, 0, - TBSTYLE_CUSTOMERASE ); - -{$IFDEF USE_CONSTRUCTORS} -function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions; - Bitmap: HBitmap; Buttons: array of PAnsiChar; - BtnImgIdxArray: array of Integer ) : PControl; -begin - new( Result, CreateToolbar( AParent, Align, Options, Bitmap, Buttons, BtnImgIdxArray ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Toolbar'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions; - Bitmap: HBitmap; const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer ) : PControl; -var Flags: DWORD; -begin - if Options <> [] then - begin - if not( tboTextBottom in Options ) then - include( Options, tboTextRight ); - if tboTextRight in Options then - exclude( Options, tboTextBottom ); - end; - Flags := MakeFlags( @Options, ToolbarOptions ) - //or TBSTYLE_AUTOSIZE - //or CCS_NOPARENTALIGN or CCS_NOMOVEY //or CCS_NORESIZE - or CCS_NODIVIDER or TBSTYLE_TRANSPARENT - ; - DoInitCommonControls( ICC_BAR_CLASSES ); - Result := _NewCommonControl( AParent, TOOLBARCLASSNAME, - (ToolbarAligns[ Align ] or WS_CHILD or WS_VISIBLE or TBSTYLE_TOOLTIPS - or Flags and not (TBSTYLE_FLAT or TBSTYLE_TRANSPARENT)), {!ecm} - tbo3DBorder in Options, - {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( TOOLBAR_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:Toolbar'; - {$ENDIF} - Result.fCommandActions.aClear := ClearToolbar; ///+++ anyway +++/// - Result.fCommandActions.aGetCount := TB_BUTTONCOUNT; - {$IFDEF USE_FLAGS} include( Result.fFlagsG5, G5_IsButton ); - {$ELSE} Result.fIsButton := TRUE; {$ENDIF} - with Result.fBoundsRect do - begin - if Align in [ caNone ] then - begin - Bottom := Top + 26; - Right := Left + 1000; - end - else - begin - Left := 0; Right := 0; - Top := 0; Bottom := 0; - end; - end; - Result.AttachProc( WndProcToolbarCtrl ); - Result.AttachProc( WndProcDoEraseBkgnd ); - Result.Perform(TB_SETEXTENDEDSTYLE, 0, Result.Perform(TB_GETEXTENDEDSTYLE, 0, 0) or - TBSTYLE_EX_DRAWDDARROWS); - - Result.Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 ); - Result.Perform( TB_SETINDENT, Result.fMargin, 0 ); - with Result.fBoundsRect do - begin - if Align in [ caLeft, caRight ] then - Right := Left + 24 - else if not (Align in [caNone]) then - Bottom := Top + 22; - end; - {$IFnDEF TBBUTTONS_DFLT_NOAUTOSIZE} - Result.DF.fDefaultTBBtnStyle := TBSTYLE_AUTOSIZE; - {$ENDIF} - if Bitmap <> 0 then - Result.TBAddBitmap( Bitmap ); - Result.TBAddButtons( Buttons, BtnImgIdxArray ); - Result.Perform( WM_SIZE, 0, 0 ); - Result.Style := Result.Style or Flags; {+ecm} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} - -//================== DateTimePicker =====================// - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} -function WndProcDateTimePickerNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var NMhdr: PNMHdr; - D: TDateTime; - AllowChg: Boolean; - NMDTString: PNMDateTimeString; -begin - Result := False; - if Msg.message = WM_NOTIFY then - begin - NMHdr := Pointer( Msg.lParam ); - CASE NMHdr.code OF - DTN_DROPDOWN:{$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnDropDown ) then - {$ENDIF} - Self_.EV.fOnDropDown( Self_ ); - DTN_CLOSEUP: {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnCloseUp ) then - {$ENDIF} - Self_.EV.fOnCloseUp( Self_ ); - DTN_DATETIMECHANGE: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnChangeCtl ) then - {$ENDIF} - Self_.EV.fOnChangeCtl( Self_ ); - DTN_USERSTRING: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnDTPUserString ) then - {$ENDIF} - begin - NMDTString := Pointer( NMHdr ); - D := Self_.DateTime; - AllowChg := TRUE; - Self_.EV.fOnDTPUserString( Self_, KOLString(NMDTString.pszUserString), D, AllowChg ); - NMDTString.dwFlags := Integer( not AllowChg ); - end; - END; - end; -end; -{$ENDIF PAS_VERSION} - -const - DateTimePickerOptions: array[ TDateTimePickerOption ] of Integer = ( - DTS_TIMEFORMAT, DTS_LONGDATEFORMAT, DTS_UPDOWN, DTS_RIGHTALIGN, - DTS_SHOWNONE, DTS_APPCANPARSE ); - -function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions ) - : PControl; -var Flags: DWORD; -const - CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS or - CS_VREDRAW or CS_HREDRAW; -begin - DoInitCommonControls( ICC_DATE_CLASSES ); - Flags := MakeFlags( @Options, DateTimePickerOptions ); - Result := _NewCommonControl( AParent, DATETIMEPICK_CLASS, - (WS_CHILD or WS_VISIBLE or WS_TABSTOP or Flags {or DTS_APPCANPARSE}), - TRUE, {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:DateTimePicker'; - {$ENDIF} - Result.SetSize( 110, 24 ); - Result.AttachProc( WndProcDateTimePickerNotify ); -end; - -procedure TControl.SetDateTime(Value: TDateTime); -var ST: TSystemTime; - D0: TDateTime; -begin - if not IsNAN( Value ) then - begin - EncodeDate( 1899, 12, 31, D0 ); - if Trunc( Value ) < D0 then - Value := Frac( Value ) + D0; - DateTime2SystemTime( Value, ST ); - end; - Perform( DTM_SETSYSTEMTIME, Integer( IsNAN( Value ) ) , Integer( @ ST ) ); -end; - -function TControl.GetDateTime: TDateTime; -var ST: TSystemTime; -begin - if Perform( DTM_GETSYSTEMTIME, 0, Integer( @ ST ) ) = GDT_VALID then - SystemTime2DateTime( ST, Result ) - else - Result := NAN; -end; - -function TControl.Get_SystemTime: TSystemTime; -begin - //FillChar( Result, Sizeof( Result ), #0 ); - ZeroMemory( @Result, Sizeof( Result ) ); - Perform( DTM_GETSYSTEMTIME, 0, Integer( @ Result ) ); // <> GDT_VALID then -end; - -procedure TControl.Set_SystemTime(const Value: TSystemTime); -begin - Perform( DTM_SETSYSTEMTIME, Integer( Value.wYear = 0 ) , Integer( @ Value ) ); -end; - -function TControl.GetDate: TDateTime; -begin - Result := DateTime; - if not IsNAN( Result ) then - Result := Trunc( DateTime ); -end; - -function TControl.GetTime: TDateTime; -begin - Result := DateTime; - if not IsNAN( Result ) then - Result := Frac( Result ); -end; - -procedure TControl.SetDate(const Value: TDateTime); -begin - if IsNAN( Value ) then - DateTime := Value - else - if not IsNAN( DateTime ) then - DateTime := Trunc( Value ) + Frac( DateTime ) - else - DateTime := Trunc( Value ); -end; - -procedure TControl.SetTime(const Value: TDateTime); -begin - if IsNAN( Value ) then - DateTime := Value - else - if not IsNAN( DateTime ) then - DateTime := Trunc( DateTime ) + Frac( Value ) - else - DateTime := 1.0 + Frac( Value ); -end; - -function TControl.GetDateTimeRange: TDateTimeRange; -var ST_R: array[ 0..1 ] of TSystemTime; -begin - Perform( DTM_GETRANGE, 0, Integer( @ ST_R[ 0 ] ) ); - SystemTime2DateTime( ST_R[ 0 ], Result.FromDate ); - SystemTime2DateTime( ST_R[ 1 ], Result.ToDate ); -end; - -procedure TControl.SetDateTimeRange(Value: TDateTimeRange); -var ST_R: array[ 0..1 ] of TSystemTime; -begin - DateTime2SystemTime( Value.FromDate, ST_R[ 0 ] ); - DateTime2SystemTime( Value.ToDate , ST_R[ 1 ] ); - Perform( DTM_SETRANGE, - Integer( IsNAN( Value.FromDate ) ) or - (Integer( IsNAN( Value.ToDate ) ) shl 1), - Integer( @ ST_R[ 0 ] ) ); -end; - -function TControl.GetDateTimePickerColor( Index: TDateTimePickerColor): TColor; -begin - Result := Perform( DTM_GETMCCOLOR, Integer( Index ), 0 ); -end; - -procedure TControl.SetDateTimePickerColor( - Index: TDateTimePickerColor; Value: TColor); -begin - Perform( DTM_SETMCCOLOR, Integer( Index ), Color2RGB( Value ) ); -end; - -procedure TControl.SetDateTimeFormat(const Value: KOLString); -begin - Perform( DTM_SETFORMAT, 0, Integer( PKOLChar( Value ) ) ); -end; - -function TControl.GetTBAutoSizeButtons: Boolean; -begin - Result := DF.fDefaultTBBtnStyle and TBSTYLE_AUTOSIZE <> 0; -end; - -function TControl.GetTVEditing: Boolean; -begin - Result := Perform( TVM_GETEDITCONTROL, 0, 0 ) <> 0; -end; - -procedure TControl.SetTBAutoSizeButtons(const Value: Boolean); -begin - DF.fDefaultTBBtnStyle := Integer( Value ) shl 4; -end; - -{$IFDEF USE_FLAGS} -function TControl.GetTabStop: Boolean; -begin - Result := F2_Tabstop in fStyle.f2_Style; -end; - -procedure TControl.SetTabStop(const Value: Boolean); -begin - if Value then include( fStyle.f2_Style, F2_Tabstop ) - else exclude( fStyle.f2_Style, F2_Tabstop ); -end; - -function TControl.GetWordWrap: Boolean; -begin - Result := G1_WordWrap in fFlagsG1; -end; - -procedure TControl.SetWordWrap(const Value: Boolean); -begin - if Value then include( fFlagsG1, G1_WordWrap ) - else exclude( fFlagsG1, G1_WordWrap ); -end; - -function TControl.GetCannotDoubleBuf: Boolean; -begin - Result := G1_CanNotDoublebuf in fFlagsG1; -end; - -procedure TControl.SetCannotDoubleBuf(const Value: Boolean); -begin - if Value then include( fFlagsG1, G1_CanNotDoublebuf ) - else exclude( fFlagsG1, G1_CanNotDoublebuf ); -end; - -function TControl.GetDoubleBuffered: Boolean; -begin - Result := G2_DoubleBuffered in fFlagsG2; -end; - -function TControl.GetTransparent: Boolean; -begin - Result := G2_Transparent in fFlagsG2; -end; - -function TControl.GetIsForm: Boolean; -begin - Result := G3_IsForm in fFlagsG3; -end; - -function TControl.GetSizeGrip: Boolean; -begin - Result := G3_SizeGrip in fFlagsG3; -end; - -procedure TControl.SetSizeGrip(const Value: Boolean); -begin - if Value then include( fFlagsG3, G3_SizeGrip ) - else exclude( fFlagsG3, G3_SizeGrip ); -end; - -function TControl.GetIsApplet: Boolean; -begin - Result := G3_IsApplet in fFlagsG3; -end; - -function TControl.GetIsControl: Boolean; -begin - Result := G3_IsControl in fFlagsG3; -end; - -function TControl.GetIsMDIChild: Boolean; -begin - Result := G3_IsMDIChild in fFlagsG3; -end; - -function TControl.GetCreateVisible: Boolean; -begin - Result := G4_CreateVisible in fFlagsG4; -end; - -procedure TControl.SetCreateVisible(const Value: Boolean); -begin - if Value then include( fFlagsG4, G4_CreateVisible ) - else exclude( fFlagsG4, G4_CreateVisible ); -end; - -function TControl.GetIsButton: Boolean; -begin - Result := G5_IsButton in fFlagsG5; -end; - -function TControl.GetFlat: Boolean; -begin - Result := G3_Flat in fFlagsG3; -end; - -function TControl.GetMouseInCtl: Boolean; -begin - Result := G3_MouseInCtl in fFlagsG3; -end; - -function TControl.GetEraseBackground: Boolean; -begin - Result := G5_EraseBkgnd in fFlagsG5; -end; - -procedure TControl.SetEraseBackground(const Value: Boolean); -begin - if Value then include( fFlagsG5, G5_EraseBkgnd ) - else exclude( fFlagsG5, G5_EraseBkgnd ); -end; - -function TControl.Get3ButtonPress: Boolean; -begin - Result := G5_3ButtonPress in fFlagsG5; -end; - -function TControl.GetKeyPreview: Boolean; -begin - Result := G6_KeyPreview in fFlagsG6; -end; - -procedure TControl.SetKeyPreview(const Value: Boolean); -begin - if Value then include( fFlagsG6, G6_KeyPreview ) - else exclude( fFlagsG6, G6_KeyPreview ); -end; - -function TControl.GetIgnoreDefault: Boolean; -begin - Result := G5_IgnoreDefault in fFlagsG5; -end; - -procedure TControl.SetIgnoreDefault(const Value: Boolean); -begin - if Value then include( fFlagsG5, G5_IgnoreDefault ) - else exclude( fFlagsG5, G5_IgnoreDefault ); -end; - -function TControl.GetWindowed: Boolean; -begin - Result := not(G6_GraphicCtl in fFlagsG6); -end; - -procedure TControl.SetWindowed(const Value: Boolean); -begin - if Value then exclude( fFlagsG6, G6_GraphicCtl ) - else include( fFlagsG6, G6_GraphicCtl ); -end; - -function TControl.Get_RightClick: Boolean; -begin - Result := G6_RightClick in fFlagsG6; -end; - -function TControl.Get_Dragging: Boolean; -begin - Result := G6_Dragging in fFlagsG6; -end; - -function TControl.Get_SizeRedraw: Boolean; -begin - Result := G1_SizeRedraw in fFlagsG1; -end; - -procedure TControl.Set_SizeRedraw(const Value: Boolean); -begin - if Value then include( fFlagsG1, G1_SizeRedraw ) - else exclude( fFlagsG1, G1_SizeRedraw ); -end; - -{$ENDIF USE_FLAGS} - -function TControl.GetDroppedDown: Boolean; -begin - Result := DF.fTBDropped - or (Perform( CB_GetDroppedState, 0, 0 ) <> 0); -end; - -//===================== RichEdit ========================// -{$IFNDEF NOT_USE_RICHEDIT} -type PENLink = ^TENLink; - TENLink = packed record - hdr: TNMHDR; - msg: DWORD; - wParam: Integer; - lParam: Integer; - chrg: TCHARRANGE; - end; - TEXTRANGEA = packed record - chrg: TCharRange; - lpstrText: PAnsiChar; - end; - -{$IFDEF not_ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Link: PENLink; - Range: TextRangeA; - Buffer: Array[ 0..1023 ] of AnsiChar; // KOL_ANSI - Buf_W : array[ 0..511 ] of WideChar absolute Buffer; - s: KOLString; -begin - Result := False; - if (Msg.message = WM_NOTIFY) and (PNMHdr( Msg.lParam ).code = EN_LINK) then - begin - Link := Pointer( Msg.lParam ); - Range.chrg := Link.chrg; - Range.lpstrText := @Buffer[ 0 ]; - Buffer[ 0 ] := #0; - Self_.Perform( EM_GETTEXTRANGE, 0, Integer( @Range ) ); - {$IFDEF UNICODE_CTRLS} - s := Buf_W; //todo: check it! - {$ELSE} - {$IFDEF _D3orHigher} - if (Buffer[ 1 ] = #0) and (Range.chrg.cpMax - Range.chrg.cpMin > 1) then - begin - {$WARNINGS OFF} - s := Buf_W; - {$WARNINGS ON} - end - else - {$ENDIF} - s := Buffer; - {$ENDIF} - if Self_.DF.fREUrl <> nil then - FreeMem( Self_.DF.fREUrl ); - if s <> '' then - begin - GetMem( Self_.DF.fREUrl, (Length(s)+1) * Sizeof(KOLChar) ); - Move( s[1], Self_.DF.fREUrl^, (Length(s)+1)*Sizeof(KOLChar) ); - end; - case Link.msg of - WM_MOUSEMOVE: - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnREOverURL ) then - {$ENDIF} - Self_.EV.fOnREOverURL( Self_ ); - WM_LBUTTONDOWN, WM_RBUTTONDOWN: - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnREUrlClick ) then - {$ENDIF} - Self_.EV.fOnREUrlClick( Self_ ); - end; - Rslt := 0; - Result := TRUE; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_noVERSION} -function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -const int_IDC_ARROW = integer( IDC_ARROW ); -asm - CMP word ptr [EDX].TMsg.message, WM_NOTIFY - JNE @@chk_WM_DESTROY - MOV EDX, [EDX].TMsg.lParam - CMP [EDX].TNMHdr.code, EN_SELCHANGE - JNE @@ret_false - CALL TControl.DoSelChange - JMP @@ret_false -@@chk_WM_DESTROY: - CMP word ptr [EDX].TMsg.message, WM_DESTROY - JNZ @@ret_false - LEA EAX, [EAX].TControl.fREUrl - CALL @LStrClr -@@ret_false: - XOR EAX, EAX - RET -end; -{$ELSE PAS_VERSION} //Pascal -function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var NMhdr: PNMHdr; -begin - Result := False; - if Msg.message = WM_NOTIFY then - begin - NMHdr := Pointer( Msg.lParam ); - case NMHdr.code of - EN_SELCHANGE: - begin - Self_.DoSelChange; - if {$IFDEF USE_FLAGS} G2_Transparent in Self_.fFlagsG2 - {$ELSE} Self_.fTransparent {$ENDIF} then - Self_.Invalidate; - end; - end; - end - else - if Msg.message = WM_DESTROY then - begin - if Self_.DF.fREUrl <> nil then - FreeMem( Self_.DF.fREUrl ); - Self_.DF.fREURL := nil; - end; -end; -{$ENDIF PAS_VERSION} - -const RichEditflags: array [ TEditOption ] of Integer = ( - not (es_AutoHScroll or WS_HSCROLL), - not (es_AutoVScroll or WS_VSCROLL), - 0 {es_Lowercase - not supported}, - 0 {es_Multiline - RichEdit always multiline}, - es_NoHideSel, - 0 {es_OemConvert - not suppoted}, - 0 {es_Password - not supported}, - es_Readonly, - 0 {es_UpperCase - not supported}, - es_WantReturn, 0, es_Number ); - -{$IFDEF USE_CONSTRUCTORS} -function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl; -begin - new( Result, CreateRichEdit1( AParent, Options ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:RichEdit'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF noASM_UNICODE} -function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl; -const - RichNamesCount = High( RichEditLibnames ) + 1; -asm - PUSH EDX - - MOV ECX, [FRichEditModule] - INC ECX - LOOP @@loaded - PUSHAD - {$IFNDEF SMALLEST_CODE} - {$IFNDEF SMALLER_CODE} - PUSH SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS - CALL SetErrorMode - PUSH EAX - {$ENDIF} - {$ENDIF} -@@search_richedit: - MOV BX, RichNamesCount + $400 - LEA ESI, [RichEditLibNames] - LEA EDI, [RichEditClasses] - CMP [RichEditIdx], 0 - JZ @@loo - LEA ESI, [ESI+(RichNamesCount-1)*4] - LEA EDI, [EDI+(RichNamesCount-1)*4] - NEG BH -@@loo: - MOV ECX, [EDI] - MOV [RichEditClass], ECX - MOVSX ECX, BH - ADD EDI, ECX - MOV EAX, [ESI] - ADD ESI, ECX - PUSH EAX - CALL LoadLibrary - CMP EAX, HINSTANCE_ERROR - JG @@break - DEC BL - JNZ @@loo - JMP @@fault -@@break: - MOV [FRichEditModule], EAX -@@fault: - {$IFNDEF SMALLEST_CODE} - {$IFNDEF SMALLER_CODE} - CALL SetErrorMode - {$ENDIF} - {$ENDIF} - POPAD -@@loaded: - PUSH EAX - PUSH EDX - MOV EAX, ESP - MOV EDX, offset[RichEditFlags] - XOR ECX, ECX - MOV CL, 10 - CALL MakeFlags - XCHG ECX, EAX - POP EDX - POP EAX - PUSH 1 - {$IFDEF PACK_COMMANDACTIONS} - PUSH [RichEditActions_Packed] - {$ELSE} - PUSH offset[RichEditActions] - {$ENDIF} - MOV EDX, [RichEditClass] - OR ECX, WS_VISIBLE or WS_CHILD or WS_TABSTOP or WS_BORDER or ES_MULTILINE - CALL _NewCommonControl - {$IFDEF USE_FLAGS} - OR [EAX].TControl.fFlagsG5, 1 shl G5_IgnoreDefault - {$ELSE} - INC [EAX].TControl.fIgnoreDefault - {$ENDIF} - POP EDX - TEST DH, 4 // is eoWantTab in Options ? - SETZ DL - MOV [EAX].TControl.fLookTabKeys, DL - PUSH EBX - MOV EBX, EAX - MOV EDX, offset[WndProcRichEditNotify] - CALL TControl.AttachProc - {$IFDEF USE_FLAGS} - OR [EBX].TControl.fFlagsG1, (1 shl G1_CanNotDoublebuf) - AND [EBX].TControl.fFlagsG2, not (1 shl G2_DoubleBuffered) - {$ELSE} - INC [EBX].TControl.fCannotDoubleBuf - MOV [EBX].TControl.fDoubleBuffered, 0 - {$ENDIF USE_FLAGS} - ADD [EBX].TControl.fBoundsRect.Right, 100-64 - ADD [EBX].TControl.fBoundsRect.Bottom, 200-64 - PUSH ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or ENM_PROTECTED or $04000000 - PUSH 0 - PUSH EM_SETEVENTMASK - PUSH EBX - CALL TControl.Perform - MOV EAX, clWindow - MOV [EBX].TControl.fColor, EAX - CALL Color2RGB - PUSH EAX - PUSH 0 - PUSH EM_SETBKGNDCOLOR - PUSH EBX - CALL TControl.Perform - {$IFDEF RICHEDIT_XPBORDER} - MOV EDX, offset[WndProc_RichEditXPBorder] - MOV EAX, EBX - CALL TControl.AttachProc - {$ENDIF RICHEDIT_XPBORDER} - XCHG EAX, EBX - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl; -var Flags, I, d, Last, SaveErrMode: Integer; -label search_richedit; -begin - {$IFDEF INPACKAGE} - Log( '->NewRichEdit1' ); - TRY - {$ENDIF INPACKAGE} - if FRichEditModule = 0 then - begin - search_richedit: - I := RichEditIdx; - Last := High( RichEditLibnames ); - d := 1; - if RichEditIdx > 1 then // 50W, 20A - begin - I := Last; - Last := 0; - d := -1; - end; - SaveErrMode := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS ); - while I <> Last + d do - begin - FRichEditModule := LoadLibrary( RichEditLibnames[ I ] ); - RichEditClass := RichEditClasses[ I ]; - if FRichEditModule > HINSTANCE_ERROR then break; - inc( I, d ); - end; - if FRichEditModule <= HINSTANCE_ERROR then - FRichEditModule := 0; - SetErrorMode( SaveErrMode ); - end; - Flags := MakeFlags( @Options, RichEditFlags ); - {$IFDEF INPACKAGE} - Log( '//// calling _NewCommonControl' ); - {$ENDIF INPACKAGE} - Result := _NewCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD - or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags, - True, {$IFDEF PACK_COMMANDACTIONS} RichEditActions_Packed - {$ELSE} @RichEditActions {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:RichEdit'; - {$ENDIF} - {$IFDEF STATIC_RICHEDIT_DATA}{$ELSE} - Result.DF.fRECharFormatRec := AllocMem( Sizeof( TCharFormat ) + Sizeof( TParaFormat2 ) ); - Result.DF.fREParaFmtRec := Pointer( Integer( @ Result.DF.fRECharFormatRec ) - + Sizeof( TCharFormat ) ); - Result.Add2AutoFreeEx( Result.FreeCharFormatRec ); - {$ENDIF} - {$IFDEF INPACKAGE} - Log( '//// after _NewCommonControl called' ); - {$ENDIF INPACKAGE} - Result.fLookTabKeys := [ tkTab ]; - if eoWantTab in Options then - Result.fLookTabKeys := [ ]; - - Result.AttachProc( WndProcRichEditNotify ); - {$IFDEF USE_FLAGS} - include( Result.fFlagsG1, G1_CanNotDoublebuf ); - exclude( Result.fFlagsG2, G2_DoubleBuffered ); - include( Result.fFlagsG5, G5_IgnoreDefault ); - {$ELSE} Result.fCannotDoubleBuf := True; - Result.fDoubleBuffered := False; - Result.fIgnoreDefault := TRUE; - {$ENDIF} - with Result.fBoundsRect do - begin - Right := Right + 100; - Bottom := Top + 200; - end; - {$IFDEF INPACKAGE} - Log( '//// before Perform' ); - {$ENDIF INPACKAGE} - Result.Perform( EM_SETEVENTMASK, 0, - ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or - ENM_PROTECTED or $04000000 {ENM_LINK} or ENM_KEYEVENTS ); - {$IFDEF INPACKAGE} - Log( '//// after Perform' ); - {$ENDIF INPACKAGE} - Result.fColor := clWindow; - Result.Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(Result.fColor)); - {$IFDEF RICHEDIT_XPBORDER} - Result.AttachProc( WndProc_RichEditXPBorder ); - {$ENDIF} - {$IFDEF INPACKAGE} - LogOK; - FINALLY - Log( '<-NewRichEdit1' ); - END; - {$ENDIF INPACKAGE} -end; -{$ENDIF PAS_VERSION} -{$ENDIF NOT_USE_RICHEDIT} - -{$ENDIF USE_CONSTRUCTORS} - -function OleInitialize(pwReserved: Pointer): HResult; stdcall; - external 'ole32.dll' name 'OleInitialize'; -procedure OleUninitialize; stdcall; - external 'ole32.dll' name 'OleUninitialize'; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function OleInit: Boolean; -begin - if OleInitCount = 0 then - begin - Result := False; - if OleInitialize( nil ) <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Inc( OleInitCount ); - Result := True; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure OleUnInit; -begin - if OleInitCount > 0 then - begin - Dec( OleInitCount ); - if OleInitCount = 0 then - OleUninitialize; - end; -end; -{$ENDIF PAS_VERSION} - -function SysAllocStringLen; - external 'oleaut32.dll' name 'SysAllocStringLen'; -procedure SysFreeString( psz: PWideChar ); stdcall; - external 'oleaut32.dll' name 'SysFreeString'; - -function StringToOleStr(const Source: Ansistring): PWideChar; -var - SourceLen, ResultLen: Integer; - Buffer: array[0..1023] of WideChar; -begin - SourceLen := Length(Source); - if Length(Source) < SizeOf(Buffer) div 2 then - Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0, - PAnsiChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2)) - else - begin - ResultLen := MultiByteToWideChar(0, 0, - Pointer(Source), SourceLen, nil, 0); - Result := SysAllocStringLen(nil, ResultLen); - MultiByteToWideChar(0, 0, Pointer(Source), SourceLen, - Result, ResultLen); - end; -end; - -{$IFNDEF NOT_USE_RICHEDIT} -{$IFDEF USE_CONSTRUCTORS} -function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl; -begin - new( Result, CreateRichEdit( AParent, Options ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:RichEdit'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl; -begin - {$IFDEF INPACKAGE} - Log( '->NewRichEdit' ); - TRY - {$ENDIF INPACKAGE} - if OleInit then - begin - {$IFDEF INPACKAGE} - Log( '//// OleInit OK: call NewRichEdit1' ); - {$ENDIF INPACKAGE} - {$IFDEF UNICODE_CTRLS} - RichEditIdx := 0; - {$ELSE} - RichEditIdx := 0; // Richedit20A / RichEdit - {$ENDIF} - Result := NewRichEdit1( AParent, Options ); - Result.DF.fCharFmtDeltaSz := 24; //sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat ); - // sizeof( TCharFormat2 ) is calculated incorrectly - Result.DF.fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat ); - end - else - begin - {$IFDEF INPACKAGE} - Log( '//// OleInit failed: call NewRichEdit1' ); - {$ENDIF INPACKAGE} - Result := NewRichEdit1( AParent, Options ); - end; - {$IFDEF INPACKAGE} - LogOK; - FINALLY - Log( '<-NewRichEdit' ); - END; - {$ENDIF INPACKAGE} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_CONSTRUCTORS} -{$ENDIF NOT_USE_RICHEDIT} - -//=====================================================================// -{$ENDIF WIN_GDI} - -{ TControl } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.Init; -{$IFNDEF OLD_EVENTS_MODEL} -var i: Integer; -{$ENDIF} -begin - {$IFDEF CALL_INHERITED} - inherited; // nothing here for Delphi 4 and higher - {$ENDIF} - {$IFDEF GDI} - {$IFDEF OLD_EVENTS_MODEL} - {$IFDEF USE_GRAPHCTLS} - PP.fDoInvalidate := InvalidateWindowed; - {$ENDIF} - PP.fOnDynHandlers := WndProcDummy; - PP.fWndProcKeybd := WndProcDummy; - //{-2.95}PP.fWndProcResizeFlicks := WndProcDummy; - PP.fPass2DefProc := WndProcDummy; - PP.fControlClick := DummyObjProc; - PP.fAutoSize := DummyObjProc; - PP.fWndFunc := @ WndFunc; - {$ELSE} - {$IFDEF EVENTS_DYNAMIC} - if not Assigned( EmptyEvents.fOnMessage ) then - for i := 0 to idx_LastEvent do - EmptyEvents.MethodEvents[i].Code := DummyProcTable[InitEventsTable[i] and $F]; - EV := @ EmptyEvents; - for i := 0 to High(PP.Procedures) do - PP.Procedures[i] := DummyProcTable[InitEventsTable[i] shr 4]; - {$ELSE} - for i := 0 to idx_LastEvent do - begin - EV.MethodEvents[i].Code := DummyProcTable[InitEventsTable[i] and $F]; - //EV.MethodEvents[i].Data := @Self; - if i < idx_LastProc - idx_LastEvent then - PP.Procedures[i] := DummyProcTable[InitEventsTable[i] shr 4]; - end; - {$ENDIF} - {$ENDIF NEW_EVENTS_MODEL} - fAlphaBlend := 255; - //---- fCommandActions.aClear := ClearText; //--- moved to _NewWindowed - fColor := clBtnFace; - fTextColor := clWindowText; - {$ENDIF GDI} - fMargin := 2; - {$IFDEF GDI} - //fCtl3D := True; fCtl3Dchild := True; - fCtl3D_child := 3; - {$ENDIF GDI} - fChildren := NewList; - {$IFDEF GDI} - fClsStyle := CS_OWNDC; - fStyle.Value := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or - WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or - WS_BORDER or WS_THICKFRAME; - fExStyle := WS_EX_CONTROLPARENT; - {$ENDIF GDI} - {$IFDEF USE_FLAGS} - {$ELSE} fWindowed := True; - fVisible := True; - fEnabled := True; - {$ENDIF} - fDynHandlers := NewList; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.InitParented( AParent: PControl ); -begin - Init; - if AParent <> nil then - fColor := AParent.fColor; - Parent := AParent; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TControl.InitParented( AParent: PControl; widget: PGtkWidget; - need_eventbox: Boolean ); -BEGIN - Init; - fHandle := widget; - fCaptionHandle := fHandle; - fEventboxHandle := fHandle; - IF need_eventbox THEN - BEGIN - fEventboxHandle := gtk_event_box_new(); - gtk_widget_set_events( fEventboxHandle, GDK_ALL_EVENTS_MASK ); - //gtk_container_add( GTK_CONTAINER( AParent.fHandle ), fEventboxHandle ); - gtk_widget_show( fEventboxHandle ); - gtk_container_add( GTK_CONTAINER( fEventboxHandle ), fHandle ); - END; - g_object_set_data( G_OBJECT( fEventboxHandle ), ID_SELF, @ Self ); - if AParent <> nil then - fColor := AParent.fColor; - Parent := AParent; -END; -{$ENDIF GTK} -{$ENDIF _X_} -{$IFDEF WIN_GDI} - -procedure TControl.InitOrthaned( AParentWnd: HWnd ); -begin - Init; - FParentWnd := AParentWnd; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TControl.Destroy; -var I: Integer; - F: PControl; - Ico: HIcon; -begin - {$IFDEF USE_CUSTOMEXTENSIONS} - {$I CUSTOM_TCONTROL_DESTROY.INC} - {$ENDIF} - {$IFDEF USE_MHTOOLTIP} - {$DEFINE destroy} - /////fHint.Free; - {$UNDEF destroy} - {$ENDIF USE_MHTOOLTIP} - {$IFDEF DEBUG_ANY} - F := nil; - TRY - F := ParentForm; // or Applet - for form ??? - EXCEPT - asm - nop - end; - END; - {$ELSE} - F := ParentForm; // or Applet - for form ??? - {$ENDIF DEBUG_ANY} - if F <> nil then - if F.DF.FCurrentControl = @Self then - F.DF.FCurrentControl := nil; - - if fHandle <> 0 then - ShowWindow( fHandle, SW_HIDE ); - - Final; - {$IFDEF USE_AUTOFREE4CHILDREN} - {$ELSE} - DestroyChildren; - {$ENDIF} - - if {$IFDEF USE_FLAGS} not(G2_Destroying in fFlagsG2) - {$ELSE} not fDestroying {$ENDIF} then - begin - {$IFDEF USE_FLAGS} include( fFlagsG2, G2_Destroying ); - {$ELSE} fDestroying := True; {$ENDIF} - - if {$IFDEF USE_FLAGS} G6_CtlClassNameChg in fFlagsG6 - {$ELSE} fCtlClsNameChg {$ENDIF} then - begin - FreeMem( fControlClassName ); - {$IFDEF USE_FLAGS} exclude( fFlagsG6, G6_CtlClassNameChg ); - {$ELSE} fCtlClsNameChg := FALSE; {$ENDIF} - end; - - {$IFDEF USE_AUTOFREE4CONTROLS} - {$ELSE} - fFont.Free; - fFont := nil; - fBrush.Free; - fBrush := nil; - {$ENDIF} - fCanvas.Free; - fCanvas := nil; - - if fHandle <> 0 then - begin - {$IFNDEF NEW_MENU_ACCELL} - {$IFDEF USE_AUTOFREE4CONTROLS} - {$ELSE} - if fAccelTable <> 0 then - begin - DestroyAcceleratorTable( fAccelTable ); - fAccelTable := 0; - end; - {$ENDIF} - {$ENDIF} - {$IFDEF USE_AUTOFREE4CONTROLS} - {$ELSE} - fMenuObj.Free; - while fImageList <> nil do - fImageList.Free; - {$ENDIF} - I := fHandle; - Ico := DF.fIcon; - if (Ico <> 0) and (Ico <> HIcon(-1)) then - if {$IFDEF USE_FLAGS} not(G1_IconShared in fFlagsG1) - {$ELSE} not fIconShared {$ENDIF} then - DestroyIcon( Ico ); - if IsWindow( I ) then - begin - // RemoveProp( I, ID_SELF ); //************** Remarked By M.Gerasimov - {$IFDEF USE_fNCDestroyed} - if not fNCDestroyed then - {$ENDIF} - begin - {$IFDEF DEBUG_ENDSESSION} - if EndSession_Initiated then - LogFileOutput( GetStartDir + 'es_debug.txt', - 'DESTROYING HWND:' + Int2Str( I ) ); - {$ENDIF} - (* -- moved to WM_NCDESTROY -- VK + Alexey Kirov, 23.02.2012 - {$IFnDEF SMALLER_CODE} - {$IFDEF USE_PROP} - SetProp( I, ID_SELF, 0 ); - {$ELSE} - SetWindowLong( I, GWL_USERDATA, 0 ); - {$ENDIF} - {$ENDIF} - *) - DestroyWindow( I ); - end; - end; - fHandle := 0; - end; - - if fCustomData <> nil then - FreeMem( fCustomData ); - fCustomData := nil; - fCustomObj.Free; - fCustomObj := nil; - - if fTmpBrush <> 0 then - DeleteObject( fTmpBrush ); - fTmpBrush := 0; - - //if FCaption <> nil then FreeMem( FCaption ); - fCaption := ''; - //if fStatusTxt <> nil then - // FreeMem( fStatusTxt ); - - if fParent <> nil then - begin - fParent.fChildren.Remove( @Self ); - {$IFDEF USE_AUTOFREE4CHILDREN} - fParent.RemoveFromAutoFree( @ Self ); - {$ENDIF} - if fParent.DF.fCurrentControl = @Self then - fParent.DF.fCurrentControl := nil; - end; - - fChildren.Free; - {$IFDEF USE_AUTOFREE4CONTROLS} - {$ELSE} - DF.fTBttCmd.Free; - DF.fTBttTxt.Free; - fTmpFont.Free; - {$ENDIF} - fDynHandlers.Free; - inherited; - end; -end; -{$ENDIF PAS_VERSION} - - {$IFDEF USE_MHTOOLTIP} - {$DEFINE code} - function TControl.GetHint: PMHHint; - begin - if fHint = nil then - fHint := NewHint(@Self); - Result := fHint; - end; - {$UNDEF code} - {$ENDIF} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetEnabled( Value: Boolean ); -begin - if GetEnabled = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF USE_FLAGS} - {$ELSE} - fEnabled := Value; - {$ENDIF USE_FLAGS} - if Value then - exclude( fStyle.f3_Style, F3_Disabled ) - else include( fStyle.f3_Style, F3_Disabled ); - if fHandle <> 0 then - begin - {$IFDEF USE_FLAGS} - EnableWindow( fHandle, not(F3_Disabled in fStyle.f3_Style)); - {$ELSE} - EnableWindow( fHandle, fEnabled ); - {$ENDIF} - end; - Invalidate; // necessary for Graphic controls -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_noVERSION} -{$ELSE PAS_VERSION} //Pascal -function TControl.GetParentWindow: HWnd; -begin - Result := GetParentWnd( TRUE ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TControl.GetWindowHandle: HWnd; -begin - {$IFDEF INPACKAGE} - Log( '->TControl.GetWindowHandle' ); - TRY - {$ENDIF INPACKAGE} - if fHandle = 0 then - begin - {$IFDEF CREATE_HIDDEN} - if {$IFDEF USE_FLAGS} not(G4_CreateVisible in fFlagsG4) - {$ELSE} not fCreateVisible {$ENDIF} then - begin - Set_Visible( False ); - CreateWindow; //virtual!!! - {$IFDEF USE_FLAGS} include( fFlagsG4, G4_CreateHidden ); - {$ELSE} fCreateHidden := True; {$ENDIF} - end else - {$ENDIF CREATE_HIDDEN} - CreateWindow; //virtual!!! - end; - Result := fHandle; - {$IFDEF INPACKAGE} - LogOK; - FINALLY - Log( '<-TControl.GetWindowHandle' ); - END; - {$ENDIF INPACKAGE} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF DEBUG_CREATEWINDOW} -procedure Debug_CreateWindow1( _Self: PControl ); -begin - {LogFileOutput( GetStartDir + 'Session.log', 'TControl.CreateWindow, ' + - ' Self = ' + Int2Str( Integer( _Self ) ) + - ' Caption = ' + _Self.fCaption + - ' fChildren = ' + Int2Hex( Integer( _Self.fChildren ), 4 ) + - ' ChildCount = ' + Int2Str( _Self.ChildCount ) );} -end; - -procedure Debug_CreateWindow2( _Self: PControl; const Params: TCreateWndParams ); -begin - LogFileOutput( GetStartDir + 'Session.log', - ' ExStyle=' + Int2Hex( Params.ExStyle, 4 ) + - ' WinClassName=' + Params.WinClassName + - ' Caption=' + Params.Caption + - ' Style=' + Int2Hex( Params.Style, 4 ) + - ' X=' + Int2Str( Params.X ) + - ' Y=' + Int2Str( Params.Y ) + - ' Width=' + Int2Str( Params.Width ) + - ' Height=' + Int2Str( Params.Height ) + - //' WndParent=' + Int2Str( Params.WndParent ) + - ' Parent=' + Int2Hex( DWORD( _Self.Parent ), 6 ) + - ' Menu=' + Int2Str( Params.Menu ) + - ' hInstance=' + Int2Str( Params.WindowClass.hInstance ) + - ' Param=' + Int2Str( Integer( Params.Param ) ) + - ' WindowClass.style:' + Int2Str( Params.WindowClass.style ) + - ' WindowClass.lpfnWndProc:' + Int2Str( DWORD( Pointer( Params.WindowClass.lpfnWndProc ) ) ) + - ' WindowClass.cbClsExtra:' + Int2Str( DWORD( Params.WindowClass.cbClsExtra ) ) + - ' WindowClass.cbWndExtra:' + Int2Str( DWORD( Params.WindowClass.cbWndExtra ) ) + - ' WindowClass.hInstance:' + Int2Str( Params.WindowClass.hInstance ) + - ' WindowClass.hIcon:' + Int2Str( Params.WindowClass.hIcon ) + - ' WindowClass.hCursor:' + Int2Str( Params.WindowClass.hCursor ) + - ' WindowClass.hbrBackground:' + Int2Str( Params.WindowClass.hbrBackground ) + - ' WindowClass.lpszMenuName:' + Params.WindowClass.lpszMenuName + - ' WindowClass.lpszClassName:' + Params.WindowClass.lpszClassName - ); -end; -{$ENDIF DEBUG_CREATEWINDOW} - -//var LockedWindow: HWnd; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TControl.CreateWindow: Boolean; -const - CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS; - CS_ON = 0; //CS_VREDRAW or CS_HREDRAW; -var TempClass: TWndClass; - Params: TCreateWndParams; - ClassRegistered: Boolean; - {$IFDEF _FPC} - SClassName: AnsiString; - {$ENDIF PAS_VERSION} - {$IFDEF UNICODE_CTRLS} - TempOleStr : PWideChar; - {$ENDIF} - {$IFDEF CREATE_HIDDEN} - {$ELSE} - lock: Boolean; - {$ENDIF} -begin - {$IFDEF INPACKAGE} - Log( '->TControl.CreateWindow' ); - TRY - {$ENDIF INPACKAGE} - {$IFDEF DEBUG_CREATEWINDOW} - Debug_CreateWindow1( @ Self ); - {$ENDIF DEBUG_CREATEWINDOW} - Result := False; - if fParent <> nil then - if fParent.GetWindowHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fHandle <> 0 then - begin - {$IFDEF CREATE_HIDDEN} - if {$IFDEF USE_FLAGS} G4_CreateHidden in fFlagsG4 - {$ELSE} fCreateHidden {$ENDIF} then - begin - CreateChildWindows; - Set_Visible( True ); - {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_CreateHidden ); - {$ELSE} fCreateHidden := False; {$ENDIF} - end else - begin - CreateChildWindows; - end; - {$ELSE} - begin - lock := LockedWindow <> 0; - if lock then - begin - LockWindowUpdate( fHandle ); - LockedWindow := fHandle; - end; - CreateChildWindows; - if lock then - begin - LockWindowUpdate( 0 ); - LockedWindow := 0; - end; - end; - {$ENDIF CREATE_HIDDEN} - Result := True; - {$IFDEF INPACKAGE} - LogOK; - {$ENDIF INPACKAGE} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - - {$IFDEF USE_GRAPHCTLS} - if {$IFDEF USE_FLAGS} (G6_GraphicCtl in fFlagsG6) - {$ELSE} not fWindowed {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - - {$IFDEF INPACKAGE} - Log( '/// Filling Params' ); - {$ENDIF INPACKAGE} - - //FillChar( Params, Sizeof( Params ), 0 ); - ZeroMemory( @Params, Sizeof( Params ) ); - Params.WindowClass.hCursor := LoadCursor( 0, IDC_ARROW ); - Params.WindowClass.hInstance := hInstance; - Params.WindowClass.lpfnWndProc := fDefWndProc; - Params.WindowClass.style := fClsStyle; - {$IFDEF _FPC} - SClassName := SubClassName; - StrCopy( Params.WinClsNamBuf, @ SClassName[ 1 ] ); - {$ELSE} - {$IFNDEF UNICODE_CTRLS} - StrCopy( Params.WinClsNamBuf, @ SubClassName[ 1 ] ); - {$ELSE} - TempOleStr := StringToOleStr(AnsiString(SubClassName)); - lstrcpyW(Params.WinClsNamBuf, TempOleStr); // vampir_infernal 15.10.2008 - SysFreeString( TempOleStr ); - {$ENDIF} - {$ENDIF} - Params.Param := nil; - Params.Inst := hInstance; - Params.Menu := fMenu; - Params.WndParent := GetParentWnd( TRUE ); - Params.Height := fBoundsRect.Bottom - fBoundsRect.Top; - if Params.Height = 0 then - Params.Height := CW_UseDefault; - Params.Width := fBoundsRect.Right - fBoundsRect.Left; - if Params.Width = 0 then - Params.Width := CW_UseDefault; - Params.Y := fBoundsRect.Top; - Params.X := fBoundsRect.Left; - if {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3) - {$ELSE} not fIsControl {$ENDIF} - and {$IFDEF USE_FLAGS} not(G2_ChangedPos in fFlagsG2) - {$ELSE} (fChangedPosSz and 3 = 0) {$ENDIF} then - begin - Params.Y := CW_UseDefault; - Params.X := CW_UseDefault; - end; - Params.Style := fStyle.Value; - Params.Caption := PKOLChar( fCaption ); - Params.WinClassName := @ Params.WinClsNamBuf[ 0 ]; - Params.ExStyle := fExStyle; - - {$IFDEF INPACKAGE} - Log( '/// Getting class info' ); - {$ENDIF INPACKAGE} - if fControlClassName <> nil then - begin - GetClassInfo( hInstance,fControlClassName,Params.WindowClass ); - Params.WindowClass.hInstance := Params.Inst; - Params.WindowClass.style := Params.WindowClass.style and - not CS_OFF or CS_ON; - end; - if fDefWndProc = nil then - fDefWndProc := {$ifdef FPC21}@{$endif}Params.WindowClass.lpfnWndProc; - if Params.WndParent = 0 then - if Params.Style and WS_CHILD <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>} - - {$IFNDEF UNICODE_CTRLS} - ClassRegistered := GetClassInfo( Params.WindowClass.hInstance,Params.WinClassName, TempClass ); - {$ELSE} - ClassRegistered := GetClassInfoW( Params.WindowClass.hInstance,Params.WinClassName, TempClass ); - {$ENDIF} - - {$IFDEF INPACKAGE} - Log( '/// Registering window class' ); - {$ENDIF INPACKAGE} - if not ClassRegistered then - begin - Params.WindowClass.lpszClassName := Params.WinClassName; - Params.WindowClass.lpfnWndProc := @ WndFunc; - {$IFNDEF UNICODE_CTRLS} - if RegisterClass( Params.WindowClass ) = 0 then Exit; {>>>>>>>>>>>>>>>>>>>} - {$ELSE} - if RegisterClassW(Params.WindowClass ) = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - end; - - {$IFDEF DEBUG_CREATEWINDOW} - Debug_CreateWindow2( @ Self, Params ); - {$ENDIF} - CreatingWindow := @Self; - {$IFDEF INPACKAGE} - Log( '/// Calling CreateWindowEx' ); - {$ENDIF INPACKAGE} - {$IFDEF USE_MDI} - if Assigned( fCreateWindowProc ) then - fHandle := fCreateWindowProc( - Params.WinClassName, Params.Caption, Params.Style, - Params.X, Params.Y, Params.Width, Params.Height, - Params.WndParent, Params.WindowClass.hInstance, - Integer( Params.Param ) ) - else - {$ENDIF} - begin - {$IFNDEF UNICODE_CTRLS} - fHandle := CreateWindowEx( - Params.ExStyle, Params.WinClassName, - Params.Caption, Params.Style, Params.X, Params.Y, - Params.Width, Params.Height, Params.WndParent, - Params.Menu, Params.WindowClass.hInstance, - Params.Param ); - {$ELSE} - fHandle := CreateWindowExW( - Params.ExStyle{ or WS_EX_RTLREADING}, Params.WinClassName, - Params.Caption, Params.Style, Params.X, Params.Y, - Params.Width, Params.Height, Params.WndParent, - Params.Menu, Params.WindowClass.hInstance, - Params.Param ); - {$ENDIF} - end; - {$IFDEF INPACKAGE} - Log( '/// CreateWindowEx called' ); - {$ENDIF INPACKAGE} - - - {$IFDEF DEBUG_CREATEWINDOW} - if fHandle = 0 then - begin - MessageBox(0, - PKOLChar(SysErrorMessage(GetLastError)), - 'Error creating window',mb_iconhand); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - {$ENDIF} - {$IFDEF INPACKAGE} - Log( '/// SendMessage WM_UPDATEUISTATE' ); - {$ENDIF INPACKAGE} - SendMessage( fHandle, $0128 {WM_UPDATEUISTATE}, - 2 {UIS_CLEAR} or (1 {UISF_HIDEFOCUS} shl 16),0); - {$IFDEF USE_PROP} - if GetProp(FHandle,ID_SELF) = 0 then - begin - CreatingWindow := nil; - SetProp(FHandle, ID_SELF, THandle(@Self)); - end; - {$ELSE} - CreatingWindow := nil; - SetWindowLong( FHandle, GWL_USERDATA, Integer(@Self) ); - {$ENDIF} - //*** - {$IFDEF INPACKAGE} - Log( '/// Perform WM_SETICON' ); - {$ENDIF INPACKAGE} - {$IFDEF SMALLEST_CODE} - {$ELSE} - if {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3) - {$ELSE} not fIsControl {$ENDIF} then - Perform( WM_SETICON, 1 {ICON_BIG}, GetIcon ); - {$ENDIF} - {$IFDEF NIL_EVENTS} - if Assigned( PP.FCreateWndExt ) then - {$ENDIF} - PP.FCreateWndExt( @Self ); - {$IFDEF INPACKAGE} - Log( '/// ApplyFont2Wnd' ); - {$ENDIF INPACKAGE} - - ApplyFont2Wnd_Proc( @Self ); - ApplyFont2Wnd_Proc( @Self ); - - {$IFDEF INPACKAGE} - Log( '/// CreateChildWindows' ); - {$ENDIF INPACKAGE} - - CreateChildWindows; - - {$IFDEF INPACKAGE} - Log( '/// CreateChildWindows called OK' ); - {$ENDIF INPACKAGE} - - Result := True; - {$IFDEF INPACKAGE} - LogOK; - FINALLY - Log( '<-TControl.CreateWindow' ); - END; - {$ENDIF INPACKAGE} -end; -{$ENDIF} -{$ENDIF WIN_GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TControl.VisualizyWindow; -VAR i: Integer; - C: PControl; -BEGIN - IF fHandle = nil THEN Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IF {$IFDEF USE_FLAGS} not(G3_IsApplet in fFlagsG3) - {$ELSE} not fIsApplet {$ENDIF} - AND {$IFDEF USE_FLAGS} (F3_Visible in fStyle.f3_Style) - {$ELSE} FVisible {$ENDIF} then - BEGIN - FOR i := 0 to ChildCount-1 do - BEGIN - C := Children[ i ]; - if {$IFDEF USE_FLAGS} F3_Visible in fStyle.f3_Style - {$ELSE} C.fVisible {$ENDIF} then - C.VisualizyWindow; - END; - gtk_widget_show( fHandle ); - END; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -//- -procedure TControl.CreateSubclass(var Params: TCreateParams; - ControlClassName: PKOLChar); -const - CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS; - CS_ON = 0; //CS_VREDRAW or CS_HREDRAW; -var - SaveInstance: THandle; -begin - if fControlClassName <> nil then - with Params do - begin - SaveInstance := WindowClass.hInstance; - {$IFNDEF UNICODE_CTRLS} - if not GetClassInfo(HInstance, fControlClassName, WindowClass) and - not GetClassInfo(0, fControlClassName, WindowClass) - then - GetClassInfo(WindowClass.hInstance, fControlClassName, WindowClass); - {$ELSE} - if not GetClassInfoW(HInstance, pWideChar(fControlClassName), WindowClass) and - not GetClassInfoW(0, pWidechar(fControlClassName), WindowClass) - then - GetClassInfoW(WindowClass.hInstance, pWideChar(fControlClassName), WindowClass); - {$ENDIF} - WindowClass.hInstance := SaveInstance; - WindowClass.style := WindowClass.style and not CS_OFF or CS_ON; - end; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcMouse(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -var MouseData: TMouseEventData; -begin - Result := False; - if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= $20A {WM_MOUSELAST}) then - with MouseData do - begin - Shift := Msg.wParam; - if GetKeyState( VK_MENU ) < 0 then - Shift := Shift or MK_ALT; - X := LoWord( Msg.lParam ); - Y := HiWord( Msg.lParam ); - //Button := TMouseButton(Msg.wParam); - // not possible: wParam can contain a combination of flags - // MK_CONTROL, MK_LBUTTON, MK_RBUTTON, MK_MBUTTON, MK_SHIFT, MK_XBUTTON1, MK_XBUTTON2 - // So, Shift must be tested. - Button := mbNone; - - StopHandling := FALSE; - Rslt := 0; // needed ? - case Msg.message of - WM_LBUTTONDOWN: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseDown ) then - {$ENDIF} - begin - Button := mbLeft; - Self_.EV.fOnMouseDown( Self_, MouseData ); - end; - WM_RBUTTONDOWN: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseDown ) then - {$ENDIF} - begin - Button := mbRight; - Self_.EV.fOnMouseDown( Self_, MouseData ); - end; - WM_MBUTTONDOWN: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseDown ) then - {$ENDIF} - begin - Button := mbMiddle; - Self_.EV.fOnMouseDown( Self_, MouseData ); - end; - WM_LBUTTONUP: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseUp ) then - {$ENDIF} - begin - Button := mbLeft; - Self_.EV.fOnMouseUp( Self_, MouseData ); - end; - WM_RBUTTONUP: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseUp ) then - {$ENDIF} - begin - Button := mbRight; - Self_.EV.fOnMouseUp( Self_, MouseData ); - end; - WM_MBUTTONUP: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseUp ) then - {$ENDIF} - begin - Button := mbMiddle; - Self_.EV.fOnMouseUp( Self_, MouseData ); - end; - WM_MOUSEMOVE: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseMove ) then - {$ENDIF} - Self_.EV.fOnMouseMove( Self_, MouseData ); - WM_LBUTTONDBLCLK: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseDblClk ) then - {$ENDIF} - begin - Button := mbLeft; - Self_.EV.fOnMouseDblClk( Self_, MouseData ); - end; - WM_RBUTTONDBLCLK: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseDblClk ) then - {$ENDIF} - begin - Button := mbRight; - Self_.EV.fOnMouseDblClk( Self_, MouseData ); - end; - WM_MBUTTONDBLCLK: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseDblClk ) then - {$ENDIF} - begin - Button := mbMiddle; - Self_.EV.fOnMouseDblClk( Self_, MouseData ); - end; - $020A {WM_MOUSEWHEEL}: - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseWheel ) then - {$ENDIF} - Self_.EV.fOnMouseWheel( Self_, MouseData ); - else - Exit; //Result := False; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := StopHandling; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function WndProcKeybd(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -var C : KOLChar; - Key: Integer; -begin - Result := True; - case Msg.message of - WM_KEYDOWN, WM_SYSKEYDOWN: - begin - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnKeyDown ) then - {$ENDIF} - Key := Msg.wParam; - Self_.EV.fOnKeyDown( Self_, Key, GetShiftState ); - Msg.wParam := Key; - end; - WM_KEYUP, WM_SYSKEYUP: - begin - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnKeyUp ) then - {$ENDIF} - Key := Msg.wParam; - Self_.EV.fOnKeyUp( Self_, Key, GetShiftState ); - Msg.wParam := Key; - end; - WM_CHAR, WM_SYSCHAR: - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnChar ) then - {$ENDIF} - begin - C := KOLChar( Msg.wParam ); - Self_.EV.fOnChar( Self_, C, GetShiftState ); - Msg.wParam := Integer( C ); - end; - {$IFDEF SUPPORT_ONDEADCHAR} - WM_DEADCHAR, WM_SYSDEADCHAR: - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnDeadChar ) then - {$ENDIF} - begin - C := KOLChar( Msg.wParam ); - Self_.EV.fOnDeadChar( Self_, C, GetShiftState ); - Msg.wParam := Integer( C ); - end; - {$ENDIF SUPPORT_ONDEADCHAR} - else begin - Result := False; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - if Msg.wParam <> 0 then - Result := False; -end; -{$ENDIF PAS_VERSION} - -function WndProcDummy(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -begin - Result := False; -end; - -const - MM_MCINOTIFY = $3B9; - -function WndProcOnClose( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; -var Accept: Boolean; -begin - Result := FALSE; - if Msg.message = WM_CLOSE then - begin - {$IFDEF NEW_MODAL} - // version of code by Alexander Pravdin - begin - Accept := True; - if Assigned( Sender.EV.fOnClose ) then - begin - Sender.EV.fOnClose( Sender, Accept ); - if AppletRunning then - if Accept then - if Sender.DF.fModal > 0 then - begin - if Sender.DF.fModalResult = 0 then - Sender.DF.fModalResult := Integer($80000000); - Msg.message := 0; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end - else - TMethod( Sender.EV.fOnClose ).Code := - {$IFDEF NIL_EVENTS} nil - {$ELSE} @DummyObjProc {$ENDIF} - else - begin - Rslt := 0; - Sender.DF.fModalResult := 0; - Result := TRUE; - end - else TMethod( Sender.EV.fOnClose ).Code := - {$IFDEF NIL_EVENTS} nil - {$ELSE} @DummyObjProc {$ENDIF}; - end else - begin - if Sender.DF.fModal > 0 then begin - if Sender.DF.fModalResult = 0 then - Sender.DF.fModalResult := Integer($80000000); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - - if Accept then begin - if Sender.IsMainWindow or ( Applet = Sender ) then - begin - PostQuitMessage( 0 ); - AppletTerminated := TRUE; - Rslt := 0; - end - else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - {$ELSE} - begin - Accept := True; - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnClose ) then - {$ENDIF} - begin - Sender.EV.fOnClose( Sender, Accept ); - if (not Accept) and (AppletRunning) then - begin - Rslt := 0; - Result := TRUE; - end else - Sender.EV.fOnClose := nil; - end; - if Accept then - begin - if Sender.IsMainWindow or (Applet = Sender) then - begin - PostQuitMessage( 0 ); - AppletTerminated := TRUE; - Rslt := 0; - end else - Exit; //Default; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - {$ENDIF} - end; -end; - -procedure TControl.SetOnClose(const AOnClose: TOnEventAccept); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnClose := AOnClose; - AttachProc( WndProcOnClose ); -end; - -function WndProcFormOnClick( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := FALSE; - if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_LBUTTONDBLCLK) or - (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_RBUTTONDBLCLK) or - (Msg.message = WM_MBUTTONDOWN) or (Msg.message = WM_MBUTTONDBLCLK) - then - begin - {$IFDEF USE_FLAGS} - if (Msg.message = WM_RBUTTONDOWN) or - (Msg.message = WM_RBUTTONDBLCLK) then - include( Sender.fFlagsG6, G6_RightClick ) - else exclude( Sender.fFlagsG6, G6_RightClick ); - {$ELSE} - Sender.fRightClick := (Msg.message = WM_RBUTTONDOWN) or - (Msg.message = WM_RBUTTONDBLCLK); - {$ENDIF} - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnClick ) then - {$ENDIF} - Sender.EV.fOnClick( Sender ); - end; -end; - -procedure TControl.SetFormOnClick(const AOnClick: TOnEvent); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnClick := AOnClick; - AttachProc( WndProcFormOnClick ); -end; - -{$IFDEF ASM_VERSION}//------------------ - -{$DEFINE ASM_LOCAL} -{$IFDEF NEW_MODAL} - {$UNDEF ASM_LOCAL} -{$ENDIF} -{$IFDEF USE_MDI} - {$UNDEF ASM_LOCAL} -{$ENDIF} - -{$ELSE}//------------------------------- - -{$IFDEF ASM_LOCAL} - {$UNDEF ASM_LOCAL} -{$ENDIF} - -{$ENDIF}//------------------------------ - -{$IFDEF USE_GRAPHCTLS} - {$UNDEF ASM_LOCAL} -{$ENDIF} - -{$IFDEF ASM_LOCAL} -{$ELSE ASM_LOCAL} //Pascal - - {$IFDEF DEBUG_CREATEWINDOW} - var DbgCWCount: Integer = 0; - {$ENDIF DEBUG_CREATEWINDOW} -function TControl.WndProc( var Msg: TMsg ): Integer; -var C : PControl; - F: HWnd; - PassFun: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; - - procedure Default; - begin - Result := CallDefWndProc( Msg ); - end; - -begin - //RefInc; - {$IFDEF INPACKAGE} - Log( '->TControl.WndProc' ); - TRY - {$ENDIF INPACKAGE} - {$IFDEF DEBUG_CREATEWINDOW} - Inc( DbgCWCount ); - if DbgCWCount < 10 then - LogFileOutput( GetStartDir + 'Session.log', 'TControl.WndProc: ' + - ' Msg.hwnd=' + Int2Str( Msg.hwnd ) + - ' Msg.message=' + Int2Hex( Msg.message, 2 ) + - ' Msg.wParam=' + Int2Str( Msg.wParam ) + '=$' + Int2Hex( Msg.wParam, 4 ) + - ' Msg.lParam=' + Int2Str( Msg.lParam ) + '=$' + Int2Hex( Msg.lParam, 4 ) ); - {$ENDIF DEBUG_CREATEWINDOW} - if (Msg.hwnd <> 0) and (fHandle = 0) - {$IFDEF USE_GRAPHCTLS} and - {$IFDEF USE_FLAGS} not(G6_GraphicCtl in fFlagsG6) - {$ELSE} fWindowed {$ENDIF} {$ENDIF} then - fHandle := Msg.hwnd; - - {$IFDEF DEBUG_MCK} mck_Log( '01' ); {$ENDIF} - PassFun := PP.fPass2DefProc; - {$IFDEF DEBUG_MCK} mck_Log( '01' ); {$ENDIF} - if not (AppletRunning and (Applet <> @Self) and ( Applet <> nil ) and - {$IFDEF NIL_EVENTS} Assigned( Applet.EV.fOnMessage ) and {$ENDIF} - Applet.EV.fOnMessage( Msg, Result )) then - begin {$IFDEF DEBUG_MCK} mck_Log( '02' ); {$ENDIF} - if not ({$IFDEF NIL_EVENTS} Assigned( EV.fOnMessage ) and {$ENDIF} - EV.fOnMessage( Msg, Result )) then - begin {$IFDEF DEBUG_MCK} mck_Log( '03' ); {$ENDIF} - if not PP.fOnDynHandlers( @Self, Msg, Result ) then - begin {$IFDEF DEBUG_MCK} mck_Log( '04' ); {$ENDIF} - //{-2.95}//if not PP.fWndProcResizeFlicks( @Self, Msg, Result ) then - begin {$IFDEF DEBUG_MCK} mck_Log( '05' ); {$ENDIF} - case Msg.message of - WM_CLOSE: - begin // handler by default - simple: - if (Applet = @ Self) or IsMainWindow then - begin - PostQuitMessage( 0 ); - AppletTerminated := TRUE; - end; - Default; - end; - (* - {$IFDEF USE_PROP} - WM_NCDESTROY: - begin - RemoveProp( fHandle, ID_SELF ); //********* Added By M.Gerasimov - //RefDec; - end; - {$ENDIF} - *) - WM_NCDESTROY: - {$IFnDEF SMALLER_CODE} - if fHandle = Msg.hwnd then - {$ENDIF} - begin - {$IFnDEF SMALLER_CODE} - {$IFDEF USE_PROP} - RemoveProp( fHandle, ID_SELF ); //********* Added By M.Gerasimov - {$ELSE} - SetWindowLong( fHandle, GWL_USERDATA, 0 ); // VK + Alexey Kirov, 23.02.2012 - {$ENDIF} - {$ENDIF} //------------------------------------------- - Default; - Exit; - end; - WM_DESTROY: - {$IFnDEF SMALLER_CODE} - if fHandle = Msg.hwnd then - {$ENDIF} - begin - {$IFDEF USE_FLAGS} include( fFlagsG2, G2_BeginDestroying ); - {$ELSE} fBeginDestroying := TRUE; {$ENDIF} - Default; - {$IFDEF INPACKAGE} LogOK; {$ENDIF INPACKAGE} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_SIZE: begin - {$IFDEF INPACKAGE} - Log( 'WM_SIZE >>> Default' ); - {$ENDIF INPACKAGE} - Default; - {$IFDEF INPACKAGE} - Log( '//// Default called' ); - {$ENDIF INPACKAGE} - {$IFDEF OLD_ALIGN} - if {$IFDEF USE_FLAGS} not(G3_IsForm in fFlagsG3) - {$ELSE} not fIsForm {$ENDIF} then - Global_Align( fParent ); - {$ENDIF} - {$IFDEF INPACKAGE} - Log( '//// Before Global_Align' ); - {$ENDIF INPACKAGE} - Global_Align( @Self ); - {$IFDEF INPACKAGE} - LogOK; - {$ENDIF INPACKAGE} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_SysCommand: - begin - if ((Msg.wParam and $FFF0) = SC_MINIMIZE) and - IsMainWindow and (@Self <> Applet) then - begin - PostMessage( Applet.Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0 ); - Result := 0; - end - else Default; - end; - WM_SETFOCUS: - begin - if not DoSetFocus then - begin - Result := 0; - end - else - begin - Inc( fClickDisabled ); - Default; - Dec( fClickDisabled ); - {$IFDEF INPACKAGE} - LogOK; - {$ENDIF INPACKAGE} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC: - begin - Result := SendMessage(Msg.LParam, CN_BASE + Msg.message, Msg.WParam, Msg.LParam); - end; - WM_COMMAND: - begin - {$IFDEF USE_PROP} - C := Pointer( GetProp( Msg.lParam, ID_SELF ) ); - {$ELSE} - C := Pointer( GetWindowLong( Msg.lParam, GWL_USERDATA ) ); - {$ENDIF} - if C <> nil then - begin - Result := SendMessage( Msg.lParam, CM_COMMAND, Msg.wParam, Msg.lParam ); - end - else Default; - end; - WM_KEYFIRST..WM_KEYLAST: - begin - F := GetFocus; - if {(F <> fFocusHandle) and} (F <> fHandle) - {$IFDEF USE_GRAPHCTLS} and - {$IFDEF USE_FLAGS} not(G6_GraphicCtl in fFlagsG6) - {$ELSE} fWindowed {$ENDIF} {$ENDIF} - {$IFDEF KEY_PREVIEW} - and {$IFDEF USE_FLAGS} not(G4_Pushed in fFlagsG4) - {$ELSE} not fKeyPreviewing {$ENDIF} - {$ENDIF} - then - begin - Result := 0; - // Jump to PassFun here. Prevents beep in case when WM_KEYDOWN - // called another form and focus is changed, so WM_KEYUP failed - // to handle. - end - else - begin - {$IFDEF KEY_PREVIEW} //ADDITION JUST FOR CORRECT KEYPREVIEWING - {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_Pushed ); - {$ELSE} fKeyPreviewing:=false; {$ENDIF} - {$ENDIF} - if fGlobalProcKeybd( @Self, Msg, Result ) then - begin - {$IFDEF INPACKAGE} - LogOK; - {$ENDIF INPACKAGE} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if PP.fWndProcKeybd( @Self, Msg, Result ) then - begin - {$IFDEF INPACKAGE} - LogOK; - {$ENDIF INPACKAGE} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if ((GetKeystate( VK_CONTROL ) or GetKeyState( VK_MENU )) >= 0) then - begin - //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - if (Msg.message <> WM_CHAR) // v1.02 Tabulate AND " in EditBox fix - //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - then - begin - C := ParentForm; - if (C <> nil) - {$IFDEF NIL_EVENTS} - and Assigned(C.PP.fGotoControl) - {$ENDIF} - and C.PP.fGotoControl( @Self, Msg.wParam, - (Msg.message <> WM_KEYDOWN) and - (Msg.message <> WM_SYSKEYDOWN) ) then - begin - Msg.wParam := 0; - Result := 0; - end - else Default; - end else - //+++++++++++++++++++++++++++++++++++++++++++++// - if Msg.wParam = 9 then // prevent system beep // - begin // - Msg.wParam := 0; // - Result := 0; // - end // - //+++++++++++++++++++++++++++++++++++++++++++++// - else Default; - end - else Default; - end; - end; - else begin - {$IFDEF DEBUG_MCK} mck_Log( 'else' ); {$ENDIF} - Default; - {$IFDEF INPACKAGE} - LogOK; - {$ENDIF INPACKAGE} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; - end; - end; - end; - {$IFDEF DEBUG_MCK} mck_Log( '06' ); {$ENDIF} - if not AppletTerminated - {$IFDEF USE_fNCDestroyed} and not fNCDestroyed {$ENDIF} then - begin {$IFDEF DEBUG_MCK} mck_Log( '07' ); {$ENDIF} - PassFun( @Self, Msg, Result ); //+-+ - {$IFDEF DEBUG_MCK} mck_Log( '08' ); {$ENDIF} - end; - {$IFDEF INPACKAGE} - LogOK; - FINALLY - Log( '<-TControl.WndProc' ); - //RefDec; - END; - {$ELSE} - //RefDec; - {$ENDIF INPACKAGE} -end; -{$ENDIF ASM_LOCAL} - -{$UNDEF ASM_LOCAL} - -{$ENDIF WIN_GDI} -{$IFDEF GDI} -procedure SetMouseEvent( Self_: PControl ); -begin - Self_.AttachProc( WndProcMouse ); -end; -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION mouse_events_handler( Obj: PGtkWidget; VAR Event: TGdkEventAny ): Boolean; - CDECL; -VAR Sender: PControl; - M: TMouseEventData; - PROCEDURE PrepareMouseEvent( const Evt: TGdkEventMotion ); - BEGIN - M.Button := mbNone; - if Evt.state and GDK_BUTTON1_MASK <> 0 then M.Button := mbLeft - else - if Evt.state and GDK_BUTTON2_MASK <> 0 then M.Button := mbRight - else - if Evt.state and GDK_BUTTON3_MASK <> 0 then M.Button := mbMiddle; - M.Shift := 0; - if Evt.state and GDK_SHIFT_MASK <> 0 then M.Shift := MK_SHIFT; - if Evt.state and GDK_CONTROL_MASK <> 0 then M.Shift := M.Shift or MK_CONTROL; - if Evt.state and GDK_LOCK_MASK <> 0 then M.Shift := M.Shift or MK_LOCK; - if Evt.state and GDK_BUTTON1_MASK <> 0 then M.Shift := M.Shift or MK_LBUTTON; - if Evt.state and GDK_BUTTON2_MASK <> 0 then M.Shift := M.Shift or MK_RBUTTON; - if Evt.state and GDK_BUTTON3_MASK <> 0 then M.Shift := M.Shift or MK_MBUTTON; - if Evt.state and GDK_LOCK_MASK <> 0 then M.Shift := M.Shift or MK_LOCK; - M.X := Round( Evt.x ); - M.Y := Round( Evt.y ); - END; -VAR scrl: PGdkEventScroll; - z: SmallInt; -BEGIN - Result := FALSE; - //Sender := Pointer( Event.window ); - Sender := g_object_get_data( G_OBJECT( Obj ), ID_SELF ); - CASE Event._type OF - GDK_MOTION_NOTIFY, - GDK_BUTTON_PRESS, - GDK_2BUTTON_PRESS, - GDK_3BUTTON_PRESS, // тройной клик мыши - считать как двойной? - GDK_BUTTON_RELEASE, - GDK_SCROLL: ; - else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - END; - PrepareMouseEvent( PGdkEventMotion( @ Event )^ ); - CASE Event._type OF - GDK_MOTION_NOTIFY : - BEGIN - IF Assigned( Sender.fOnMouseMove ) THEN - BEGIN - Sender.fOnMouseMove( Sender, M ); - Result := TRUE; - END; - END; - GDK_BUTTON_PRESS : - BEGIN - IF Assigned( Sender.fOnMouseDown ) THEN - BEGIN - Sender.fOnMouseDown( Sender, M ); - Result := TRUE; - END; - END; - GDK_2BUTTON_PRESS, - GDK_3BUTTON_PRESS : - BEGIN - IF Assigned( Sender.fOnMouseDblClk ) THEN - BEGIN - {$IFDEF USE_FLAGS} - IF Event._type = GDK_3BUTTON_PRESS THEN - include( Sender.fFlagsG5, G5_3ButtonPress ) - ELSE exclude( Sender.fFlagsG5, G5_3ButtonPress ); - {$ELSE} - Sender.f3ButtonPress := Event._type = GDK_3BUTTON_PRESS; - {$ENDIF} - Sender.fOnMouseDblClk( Sender, M ); - Result := TRUE; - END; - END; - GDK_BUTTON_RELEASE : - BEGIN - IF Assigned( Sender.fOnMouseUp ) THEN - BEGIN - Sender.fOnMouseUp( Sender, M ); - Result := TRUE; - END; - if Assigned( Sender.fOnClick ) then - Sender.fOnClick( Sender ); - END; - GDK_SCROLL : - BEGIN - IF Assigned( Sender.fOnMouseWheel ) THEN - BEGIN - scrl := @ Event; - IF scrl.direction = GDK_SCROLL_UP THEN - z := 120 - ELSE IF scrl.direction = GDK_SCROLL_DOWN THEN - z := -120 //todo: direction and value? - ELSE - z := 0; - M.Shift := M.Shift or DWord(z shl 16); - Sender.fOnMouseWheel( Sender, M ); - Result := TRUE; - END; - END; - END; -END; - -PROCEDURE SetMouseEvent( Self_: PControl; event_name: PAnsiChar ); -BEGIN - gtk_signal_connect( GTK_OBJECT( Self_.fEventboxHandle ), event_name, - @mouse_events_handler, Self_ ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -function TControl.Get_OnMouseEvent(const Index: Integer): TOnMouse; -begin - Result := TOnMouse( EV.MethodEvents[Index] ); -end; - -procedure TControl.SetOnMouseEvent(const Index: Integer; - const Value: TOnMouse); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .MethodEvents[Index] := TMethod( Value ); - AttachProc( WndProcMouse ); -end; - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetClsStyle( Value: DWord ); -begin - if fClsStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fClsStyle := Value; - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SetClassLong( fHandle, GCL_STYLE, Value ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetStyle( Value: DWord ); -begin - if fStyle.Value = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fStyle.Value := Value; - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SetWindowLong( fHandle, GWL_STYLE, Value ); - - SetWindowPos( fHandle, 0, 0, 0, 0, 0, - SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or - SWP_NOZORDER or SWP_FRAMECHANGED ); - Invalidate; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF GRAPHCTL_XPSTYLES} -function TControl.GetEdgeStyle: TEdgeStyle; -begin - Result := esRaised; - if Style and WS_DLGFRAME = 0 then - begin - if Style and SS_SUNKEN <> 0 then - Result := esLowered - else - Result := esNone; - end; -end; - -procedure TControl.SetEdgeStyle( Value: TEdgeStyle ); -begin - {$IFDEF STORE_EDGESTYLE} - if fedgeStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fedgeStyle := Value; - {$ENDIF} - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - case Value of - esRaised: - begin - Style := Style and (not SS_SUNKEN); - ExStyle := ExStyle and (not WS_EX_STATICEDGE); - ExStyle := ExStyle or WS_EX_WINDOWEDGE; - Style := Style or WS_DLGFRAME; - end; - esLowered: - begin - Style := Style and (not WS_DLGFRAME); - ExStyle := ExStyle or WS_EX_WINDOWEDGE; - ExStyle := ExStyle or WS_EX_STATICEDGE; - Style := Style or SS_SUNKEN; - end; - else - Style := Style and (not SS_SUNKEN) and (not WS_DLGFRAME); - ExStyle := ExStyle and (not WS_EX_STATICEDGE) or WS_EX_WINDOWEDGE; - end; - - Invalidate; -end; -{$ENDIF} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetExStyle( Value: DWord ); -begin - if fExStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fExStyle := Value; - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SetWindowLong( fHandle, GWL_EXSTYLE, Value ); - - SetWindowPos( fHandle, 0, 0, 0, 0, 0, - SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or - SWP_NOZORDER or SWP_FRAMECHANGED ); - Invalidate; -end; -{$ENDIF PAS_VERSION} - -function WndProcSetCursor( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Cur: HCursor; -begin - Result := FALSE; - if Msg.message = WM_SETCURSOR then - begin - if (GetCapture = 0) and - (LOWORD( Msg.lParam ) = HTCLIENT) then - begin - if ScreenCursor <> 0 then //YS - Cur := ScreenCursor //YS - else Cur := Self_.fCursor; //YS - if Cur <> 0 then //YS - begin //YS - Windows.SetCursor( Cur ); //YS - Rslt := 1; //YS - Result := TRUE; - end; - end; - end; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetCursor( Value: HCursor ); -var P: TPoint; -begin - AttachProc( WndProcSetCursor ); - if fCursor = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fCursor := Value; - if (fHandle = 0) or (fCursor = 0) then Exit; //YS {>>>>>>>>>>>>>>>>>>>>>>>>>} - if ScreenCursor <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - GetCursorPos( P ); - P := Screen2Client( P ); - if PointInRect( P, ClientRect ) then - Windows.SetCursor( Value ); -end; -{$ENDIF PAS_VERSION} - -procedure TControl.CursorLoad(Inst: Integer; ResName: PKOLChar); -begin - Cursor := LoadCursor( Inst, ResName ); - //{$IFDEF USE_FLAGS} include( fFlagsG1, G1_CursorShared ); - //{$ELSE} fCursorShared := TRUE; {$ENDIF} -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetIcon( Value: HIcon ); -var OldIco: HIcon; -begin - if DF.fIcon = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DF.fIcon := Value; - if Value = THandle(-1) then - Value := 0; - OldIco := Perform( WM_SETICON, 1 {ICON_BIG}, Value ); - if OldIco <> 0 then - DestroyIcon( OldIco ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetMenu( Value: HMenu ); -begin - if fMenu = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fMenuObj <> nil then - begin - {$IFDEF USE_AUTOFREE4CONTROLS} - RemoveFromAutoFree( fMenuObj ); - {$ENDIF} - fMenuObj.Free; - end; - if fMenu <> 0 then - DestroyMenu( fMenu ); - fMenu := Value; - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Windows.SetMenu( fHandle, Value ); -end; -{$ENDIF PAS_VERSION} - -procedure CallWinHelp( Context: Integer; CtxCtl: PControl ); -var Cmd: Integer; - Form: PControl; - Popup: Boolean; -begin - Cmd := HELP_CONTEXT; - if CtxCtl <> nil then - begin - Form := CtxCtl.ParentForm; - if Form <> nil then - if Assigned( Form.EV.fOnHelp ) then - begin - Popup := FALSE; - Form.EV.fOnHelp( CtxCtl, Context, Popup ); - if Popup then - Cmd := HELP_CONTEXTPOPUP; - if CtxCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end - else - if Context = 0 then - Cmd := HELP_CONTENTS; - WinHelp( Applet.Handle, PKOLChar( Applet.GetHelpPath ), Cmd, Context ); -end; - -var HHCtrl: THandle; - HtmlHelp: procedure( Wnd: HWnd; Path: PKOLChar; Cmd, Data: Integer ); stdcall; - -procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: KOLString; Cmd, Data: Integer ); -begin - if HHCtrl = 0 then - HHCtrl := LoadLibrary( 'HHCTRL.OCX' ); - if HHCtrl = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if not Assigned( HtmlHelp ) then - HtmlHelp := GetProcAddress( HHCtrl, - {$IFDEF UNICODE_CTRLS} 'HtmlHelpW' {$ELSE} 'HtmlHelpA' {$ENDIF} ); - if not Assigned( HtmlHelp ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - HtmlHelp( Wnd, PKOLChar( HelpFilePath ), Cmd, Data ); -end; - -procedure CallHtmlHelp( Context: Integer; CtxCtl: PControl ); -var Cmd: Integer; - Form: PControl; - Popup: Boolean; - Ids: array[ 0..2 ] of DWORD; -begin - - Cmd := $F; // HH_HELP_CONTEXT; - if CtxCtl <> nil then - begin - Form := CtxCtl.ParentForm; - if Form <> nil then - if Assigned( Form.EV.fOnHelp ) then - begin - Popup := FALSE; - Form.EV.fOnHelp( CtxCtl, Context, Popup ); - if Popup then - begin - Cmd := $10; //HH_TP_HELPCONTEXTMENU; - Ids[ 0 ] := CtxCtl.fMenu; - Ids[ 1 ] := Context; - Ids[ 2 ] := 0; - Context := Integer( @ Ids ); - end; - if CtxCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end - else - if Context = 0 then - Cmd := 1; // HH_DISPLAY_TOC; - HtmlHelpCommand( {$IFDEF HTMLHELP_NOTOP} 0 {$ELSE} Applet.Handle {$ENDIF}, - HelpFilePath, Cmd, Context ); -end; - -var - Global_HelpProc: procedure( Context: Integer; CtxCtl: PControl ) = CallWinHelp; - -function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var HI: PHelpInfo; - Ctx: Integer; - Ctl: PControl; -begin - Result := FALSE; - if Msg.message = WM_HELP then - begin - Ctx := 0; - Ctl := nil; - HI := Pointer( Msg.lParam ); - if HI.iContextType = HELPINFO_WINDOW then - begin - {$IFDEF USE_PROP} - Ctl := Pointer( GetProp( HI.hItemHandle, ID_SELF ) ); - {$ELSE} - Ctl := Pointer( GetWindowLong( HI.hItemHandle, GWL_USERDATA ) ); - {$ENDIF} - while Ctl <> nil do - begin - Ctx := Ctl.HelpContext; - if Ctx <> 0 then break; - Ctl := Ctl.Parent; - end; - end - else - Ctx := GetMenuContextHelpID( HI.hItemHandle ); - Applet.CallHelp( Ctx, Ctl ); - Rslt := 1; - Result := TRUE; - end - {$IFDEF AUTO_CONTEXT_HELP} - else - if (Msg.message = WM_CONTEXTMENU) then - begin - {$IFDEF USE_PROP} - Ctl := Pointer( GetProp( Msg.wParam, ID_SELF ) ); - {$ELSE} - Ctl := Pointer( GetWindowLong( Msg.wParam, GWL_USERDATA ) ); - {$ENDIF} - if (Ctl <> nil) and (Ctl.HelpContext <> 0) then - begin - Applet.CallHelp( Ctl.HelpContext, Ctl ); - Rslt := 1; - Result := TRUE; - end; - end - {$ENDIF}; -end; - -procedure TControl.SetHelpContext(Value: Integer); -var F: PControl; -begin - F := ParentForm; - if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - F.AttachProc( WndProcHelp ); - SetWindowContextHelpId( GetWindowHandle, Value ); -end; - -function TControl.AssignHelpContext(Context: Integer): PControl; -begin - SetHelpContext( Context ); - Result := @ Self; -end; - -procedure AssignHtmlHelp( const HtmlHelpPath: KOLString ); -var Lbytes: Integer; -begin - {$IFDEF KOL_ASSERTIONS} - Assert( (HtmlHelpPath <> '') and (Applet <> nil), 'Error parameters' ); - {$ENDIF KOL_ASSERTIONS} - if HelpFilePath <> '' then - FreeMem( HelpFilePath ); - Lbytes := (Length( HtmlHelpPath ) + 1) * Sizeof( KOLChar ); - GetMem( HelpFilePath, Lbytes ); - Move( HtmlHelpPath[ 1 ], HelpFilePath^, Lbytes ); - Global_HelpProc := CallHtmlHelp; - Applet.AttachProc( WndProcHelp ); -end; - -procedure TControl.CallHelp(Context: Integer; CtxCtl: PControl {; CtlID: Integer} ); -begin - Global_HelpProc( Context, CtxCtl {, CtlID} ); -end; - -function TControl.GetHelpPath: KOLString; -begin - Result := KOLString(HelpFilePath); - if Result = '' then - begin - Result := ParamStr( 0 ); - Result := ReplaceFileExt( Result, '.hlp' ); - end; -end; - -procedure TControl.SetHelpPath(const Value: KOLString); -var Lbytes: Integer; -begin - {$IFDEF KOL_ASSERTIONS} - Assert( Value <> '', 'Error parameter' ); - {$ENDIF KOL_ASSERTIONS} - if HelpFilePath <> '' then - FreeMem( HelpFilePath ); - Lbytes := (Length( Value ) + 1)*Sizeof( KOLChar ); - GetMem( HelpFilePath, Lbytes ); - Move( Value[ 1 ], HelpFilePath^, Lbytes ); -end; -{$ENDIF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE} -procedure TControl.DoAutoSize; -begin - {$IFDEF NIL_EVENTS} - if Assigned( PP.fAutoSize ) then - {$ENDIF} - PP.fAutoSize( @Self ); -end; -{$ENDIF} - -{$IFDEF GDI} -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TControl.GetCaption: KOLString; -var Sz: Integer; -begin - if {$IFDEF USE_FLAGS} not(G1_IgnoreWndCaption in fFlagsG1) - {$ELSE} not fIgnoreWndCaption {$ENDIF} - and (FHandle <> 0) then - begin - Sz := GetWindowTextLength( FHandle ); - SetLength( fCaption, Sz ); - if Sz > 0 then - begin - {$IFNDEF UNICODE_CTRLS} - GetWindowText( FHandle, @ fCaption[ 1 ], Sz + 1 ); - {$ELSE} - GetWindowTextW( FHandle, @ fCaption[ 1 ], Sz + 1 ); - {$ENDIF} - end; - end; - Result := FCaption; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TControl.GetCaption: KOLString; -BEGIN - if {$IFDEF USE_FLAGS} not (G1_IgnoreWndCaption in fFlagsG1) - {$ELSE} fIgnoreWndCaption {$ENDIF} then - FCaption := fGetCaption(@Self); - Result := FCaption; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetCaption( const Value: KOLString ); -begin - fCaption := Value; - if fHandle <> 0 then - SendMessage( fHandle, WM_SETTEXT, - 0, Integer( PKOLChar( Value ) ) ); - if {$IFDEF USE_FLAGS} (G1_IsStaticControl in fFlagsG1) - {$ELSE} fIsStaticControl <> 1 {$ENDIF} then - Invalidate; - DoAutoSize; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TControl.SetCaption( CONST Value: KOLString ); -BEGIN - fCaption := Value; - if Assigned( fSetCaption ) THEN - fSetCaption( @Self, Value ); - DoAutoSize; -END; -{$ENDIF GTK} -{$ENDIF _X_} -{$IFDEF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function TControl.GetVisible: Boolean; -begin - //UpdateWndStyles; - {$IFDEF USE_FLAGS} - {if (fHandle <> 0) then - Result := //IsWindowVisible( fHandle ) -- incorrectly is false in OnShow ! - GetWindowLong( fHandle, GWL_STYLE ) and WS_VISIBLE <> 0 - else} - Result := F3_Visible in fStyle.f3_Style; - {$ELSE} - {if (fHandle <> 0) then - fVisible := IsWindowVisible( fHandle ) - else} - fVisible := (FStyle.Value and WS_VISIBLE) <> 0; - Result := fVisible; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal -function TControl.Get_Visible: Boolean; -begin - {$IFDEF USE_FLAGS} - Result := GetVisible; - {$ELSE} - if (fHandle <> 0) and not fIsControl then - fVisible := IsWindowVisible( fHandle ); - Result := fVisible; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // Pascal -procedure TControl.Set_Visible( Value: Boolean ); -{$IFDEF OLD_ALIGN} -var CmdShow: DWORD; -{$ENDIF} -begin - {$IFDEF OLD_ALIGN} - //if Get_Visible <> Value then // commented to allow to set up controls visibility - begin // on invisible form (Vladimir Piven) - if Value then - begin - {$IFDEF USE_FLAGS} include( fStyle.f3_Style, F3_Visible ); - {$ELSE} fStyle.Value := fStyle.Value or WS_VISIBLE; {$ENDIF} - CmdShow := SW_SHOW; - end else - begin - {$IFDEF USE_FLAGS} exclude( fStyle.f3_Style, F3_Visible ); - {$ELSE} fStyle.Value := fStyle.Value and not WS_VISIBLE; {$ENDIF} - CmdShow := SW_HIDE; - end; - {$IFDEF USE_FLAGS}{$ELSE} - fVisible := Value; - {$ENDIF} - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ShowWindow( fHandle, CmdShow ); - Global_Align( fParent ); - if Value then - Global_Align( @Self ); - end; - {$IFDEF CREATE_HIDDEN} - if not Value and (fHandle <> 0) then - {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_CreateHidden ); - {$ELSE} fCreateHidden := FALSE; {$ENDIF} // { +++ } - {$ENDIF CREATE_HIDDEN} -{$ELSE NEW_ALIGN} - fStyle.Value := fStyle.Value and not WS_VISIBLE; - if Value then - fStyle.Value := fStyle.Value or WS_VISIBLE; - {$IFDEF USE_FLAGS} - {$ELSE} - fVisible := Value; - {$ENDIF} - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Value then - begin - Global_Align( @Self ); - ShowWindow( fHandle, SW_SHOW ); - end else - begin - {$IFDEF CREATE_HIDDEN} - {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_CreateHidden ); - {$ELSE} fCreateHidden := FALSE; {$ENDIF} // { +++ } - {$ENDIF CREATE_HIDDEN} - ShowWindow( fHandle, SW_HIDE ); - Global_Align( @Self ); - end; -{$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure TControl.SetVisible( Value: Boolean ); -begin - {$IFDEF USE_FLAGS} include( fFlagsG4, G4_CreateVisible ); - {$ELSE} fCreateVisible := TRUE; {$ENDIF} - Set_Visible( Value ); -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetBoundsRect: TRect; -var W: HWnd; - P: TPoint; -begin - Result := fBoundsRect; - if fHandle <> 0 then - begin - GetWindowRect( fHandle, Result ); - if {$IFDEF USE_FLAGS} ([G3_IsControl, G3_IsMDIChild] * fFlagsG3 <> []) - {$ELSE} fIsControl or fIsMDIChild {$ENDIF} - then - begin - W := ParentWindow; - if W <> 0 then - begin - P.x := 0; P.y := 0; - Windows.ClientToScreen( W, P ); - OffsetRect( Result, -P.x, -P.y ); - end; - end; - {$IFDEF TEST_BOUNDSRECT} - if not CompareMem( @ fBoundsRect, @ Result, Sizeof( TRect ) ) then - {$ENDIF} - fBoundsRect := Result; - end; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TControl.GetBoundsRect: TRect; -VAR R: TRect; - window: PGtkWindow; - requisition: TGtkRequisition; -BEGIN - //if fHandle <> nil then - BEGIN - IF fIsControl THEN - BEGIN - R.Left := fBoundsRect.Left; - R.Top := fBoundsRect.Top; - gtk_widget_get_size_request( fEventboxHandle, @ R.Right, @ R.Bottom ); - gtk_widget_size_request( fHandle, @ requisition ); - IF R.Right < 0 THEN R.Right := requisition.width; - IF R.Bottom < 0 THEN R.Bottom := requisition.height; - END ELSE - BEGIN - window := GTK_WINDOW( fHandle ); - gtk_window_get_position(window, @ R.Left, @ R.Top); - gtk_window_get_size(window, @ R.Right, @ R.Bottom); - END; - inc( R.Right, R.Left ); - inc( R.Bottom, R.Top ); - fBoundsRect := R; - END; - Result := fBoundsRect; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetBoundsRect( const Value: TRect ); -var Rect: TRect; -begin - Rect := GetBoundsRect; - if RectsEqual( Value, Rect ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF USE_FLAGS} - if (Value.Left <> fBoundsRect.Left) or (Value.Top <> fBoundsRect.Top) then - include( fFlagsG2, G2_ChangedPos ); - {$ELSE} - if Value.Left <> fBoundsRect.Left then fChangedPosSz := fChangedPosSz or 1; - if Value.Top <> fBoundsRect.Top then fChangedPosSz := fChangedPosSz or 2; - {$ENDIF} - {$IFDEF USE_GRAPHCTLS} - if {$IFDEF USE_FLAGS} (G6_GraphicCtl in fFlagsG6) - {$ELSE} not fWindowed {$ENDIF} then - Invalidate; - {$ENDIF} - - fBoundsRect := Value; - Rect := Value; - - if fHandle <> 0 then - begin - SetWindowPos( fHandle, 0, Rect.Left, Rect.Top, Rect.Right - Rect.Left, - Rect.Bottom - Rect.Top, SWP_NOZORDER or SWP_NOACTIVATE ); - end; - if {$IFDEF USE_FLAGS} (G1_SizeRedraw in fFlagsG1) - {$ELSE} fSizeRedraw {$ENDIF} then - Invalidate; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TControl.SetBoundsRect( const Value: TRect ); -VAR Rect: TRect; - window: PGtkWindow; -BEGIN - Rect := GetBoundsRect; - if RectsEqual( Value, Rect ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF USE_FLAGS} - if (Value.Left <> fBoundsRect.Left) or (Value.Top <> fBoundsRect.Top) then - include( fFlagsG2, G2_ChangedPos ); - {$ELSE} - if Value.Left <> fBoundsRect.Left then fChangedPosSz := fChangedPosSz or 1; - if Value.Top <> fBoundsRect.Top then fChangedPosSz := fChangedPosSz or 2; - {$ENDIF} - fBoundsRect := Value; - Rect := Value; - - IF fIsControl then - BEGIN - //gtk_widget_set_uposition( fHandle, Rect.Left, Rect.Top ); - IF fParent <> nil then - fParent.fChildSetPos( fParent, @ Self, Rect.Left, Rect.Top ); - IF (Rect.Right > Rect.Left) and (Rect.Bottom > Rect.Top) then - gtk_widget_set_size_request( fEventboxHandle, - Rect.Right - Rect.Left, Rect.Bottom - Rect.Top ); - END ELSE - BEGIN - window := GTK_WINDOW( fHandle ); - gtk_window_move( window, Rect.Left, Rect.Top ); - gtk_window_resize( window, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top ); - END; - //if fSizeRedraw then - // Invalidate; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -const - WindowStateShowCommands: array[TWindowState] of Byte = - (SW_SHOWNOACTIVATE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED); -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetWindowState( Value: TWindowState ); -begin - if WindowState <> Value then - begin - DF.fWindowState := Value; - if fHandle <> 0 then - ShowWindow(fHandle, WindowStateShowCommands[Value]); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.Show; -begin - CreateWindow; - SetVisible( True ); - SetForegroundWindow( Handle ); - DoSetFocus; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.Hide; -begin - SetVisible( False ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.Client2Screen( const P: TPoint ): TPoint; -begin - Result := P; - if fHandle <> 0 then - Windows.ClientToScreen( fHandle, Result ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.Screen2Client( const P: TPoint ): TPoint; -begin - Result := P; - if Handle <> 0 then - Windows.ScreenToClient( Handle, Result ); -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.ClientRect: TRect; -const BorderParams: array[ 0..5 ] of DWORD = - ( SM_CXBORDER, SM_CXFRAME, SM_CXSIZEFRAME, SM_CYBORDER, SM_CYFRAME, SM_CYSIZEFRAME ); -begin - Result := fBoundsRect; - GetWindowHandle; - if (fHandle <> 0) then - GetClientRect( fHandle, Result ); - Inc( Result.Top, fClientTop ); - Dec( Result.Bottom, fClientBottom ); - Inc( Result.Left, fClientLeft ); - Dec( Result.Right, fClientRight ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TControl.ClientRect: TRect; //todo: implement exact, now for PaintBox only -BEGIN - Result := fBoundsRect; - OffsetRect( Result, -Result.Left, -Result.Top ); - Inc( Result.Top, fClientTop ); - Dec( Result.Bottom, fClientBottom ); - Inc( Result.Left, fClientLeft ); - Dec( Result.Right, fClientRight ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure TControl.Invalidate; -begin - {$IFDEF USE_GRAPHCTLS} - PP.fDoInvalidate( @Self ); - {$ELSE} - if fHandle <> 0 then - InvalidateRect( fHandle, nil, TRUE ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TControl.Invalidate; -BEGIN - gtk_widget_queue_draw_area( fHandle, 0, 0, Width, Height ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -{$IFDEF USE_GRAPHCTLS} -procedure InvalidateNonWindowed( Sender: PObj ); -var R: TRect; -begin - R := PControl( Sender ).BoundsRect; - if PControl( Sender ).fParent.fHandle <> 0 then - InvalidateRect( PControl( Sender ).fParent.fHandle, @ R, TRUE ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure InvalidateWindowed( Sender: PObj ); -begin - if PControl( Sender ).fHandle <> 0 then - InvalidateRect( PControl( Sender ).fHandle, nil, TRUE ); -end; -{$ENDIF PAS_VERSION} - -{$ENDIF USE_GRAPHCTLS} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetIcon: HIcon; -begin - Result := DF.fIcon; - if Result = THandle( -1 ) then - begin - Result := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if Result = 0 then - if (Applet <> nil) and (@Self <> Applet) then - begin - Result := Applet.Icon; - if Result <> 0 then - Result := CopyImage( Result, IMAGE_ICON, 0, 0, 0 ); - end - else - begin - {$IFDEF NUMERIC_APPICON} {$DEFINE CUSTOM_APPICON} {$ENDIF} - Result := LoadIcon( hInstance, - {$IFDEF CUSTOM_APPICON} {$IFDEF NUMERIC_APPICON} PKOLChar( {$ENDIF} // avoid A/W casting - {$I CustomAppIconRsrcName_PAS.inc} // create such file with 'your icon rsrc name' or yourIconID - {$IFDEF NUMERIC_APPICON} ) {$ENDIF} - {$ELSE} 'MAINICON' {$ENDIF} ); - end; - DF.fIcon := Result; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.IconLoad(Inst: Integer; ResName: PKOLChar); -begin - Icon := LoadIcon( Inst, ResName ); - {$IFDEF USE_FLAGS} include( fFlagsG1, G1_IconShared ); - {$ELSE} fIconShared := TRUE; {$ENDIF} -end; - -procedure TControl.IconLoadCursor(Inst: Integer; ResName: PKOLChar); -begin - Icon := LoadCursor( Inst, ResName ); - {$IFDEF USE_FLAGS} include( fFlagsG1, G1_IconShared ); - {$ELSE} fIconShared := TRUE; {$ENDIF} -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.CallDefWndProc(var Msg: TMsg): Integer; -begin - {$IFDEF INPACKAGE} - Result := 0; - Log( '->TControl.CallDefWndProc FHandle = ' + Int2Str( FHandle ) + - ', Msg.hwd = ' + Int2Str( Msg.hwnd ) ); - TRY - {$ENDIF INPACKAGE} - if FDefWndProc <> nil then - begin - {$IFDEF INPACKAGE} - Log( '//// CallWindowProc, FDefWndProc = ' + Int2Hex( DWORD( FDefWndProc ), 6 ) ); - TRY - TRY - {$ENDIF INPACKAGE} - Result := CallWindowProc( - FDefWndProc, FHandle, Msg.message, Msg.wParam, Msg.lParam ); - {$IFDEF INPACKAGE} - EXCEPT on E: Exception do - Log( '*** Exception in CallWindowProc, msg = ' + E.Message ); - END; - EXCEPT - Log( '*** Exception handled' ); - END; - {$ENDIF INPACKAGE} - end - else - begin - {$IFDEF INPACKAGE} - Log( '//// DefWindowProc' ); - {$ENDIF INPACKAGE} - Result := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam ); - end; - {$IFDEF INPACKAGE} - LogOK; - FINALLY - Log( '<-TControl.CallDefWndProc' ); - END; - {$ENDIF INPACKAGE} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetWindowState: TWindowState; -begin - Result := DF.fWindowState; - if Handle <> 0 then - begin - if IsIconic( Handle ) then - Result := wsMinimized - else - if IsZoomed( Handle ) then - Result := wsMaximized - else - Result := wsNormal; - //DF.fWindowState := Result; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.DoSetFocus: Boolean; -begin - Result := False; - //if Enabled and ( - // {$IFDEF USE_FLAGS}{$ELSE} fTabstop or {$ENDIF} - // (F2_Tabstop in fStyle.f2_Style)) then - if Enabled then - begin - Inc( fClickDisabled ); - SetFocus( fHandle ); - Dec( fClickDisabled ); - Result := True; - end; -end; -{$ENDIF PAS_VERSION} - -function TControl.HandleAllocated: Boolean; -begin - Result := FHandle <> 0; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetEnabled: Boolean; -begin - if FHandle = 0 then - Result := (Style and WS_DISABLED) = 0 - else Result := IsWindowEnabled( FHandle ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.IsMainWindow: Boolean; -begin - if Applet = nil then - Result := not IsControl - else if not AppButtonUsed then - Result := @ Self = Applet - else - Result := Applet.Children[ 0 ] = @ Self; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TControl.get_ClassName: KOLString; -begin - Result := fControlClassName; - if {$IFDEF USE_FLAGS} not(G6_CtlClassNameChg in fFlagsG6) - {$ELSE} not fCtlClsNameChg {$ENDIF} then - Result := KOLString('obj_') + Result; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.set_ClassName(const Value: KOLString); -begin - if {$IFDEF USE_FLAGS} G6_CtlClassNameChg in fFlagsG6 - {$ELSE} fCtlClsNameChg {$ENDIF} then - FreeMem( fControlClassName ); - GetMem( fControlClassName, (Length( Value ) + 1) * Sizeof( KOLChar ) ); - {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF} - ( fControlClassName, @ Value[ 1 ] ); - {$IFDEF USE_FLAGS} include( fFlagsG6, G6_CtlClassNameChg ); - {$ELSE} fCtlClsNameChg := TRUE; {$ENDIF} -end; - -function WndProcQueryEndSession( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Accept: Boolean; -begin - Result := FALSE; - if Msg.message = WM_QUERYENDSESSION then - begin - {$IFDEF DEBUG_ENDSESSION} - LogFileOutput( GetStartDir + 'end_session.txt', '!' ); - {$ENDIF} - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnQueryEndSession ) then - {$ENDIF} - begin - Accept := TRUE; - Sender.DF.fCloseQueryReason := qShutdown; - if LongBool(Msg.lParam and {ENDSESSION_LOGOFF} DWORD($80000000)) then - Sender.DF.fCloseQueryReason := qLogoff; - Sender.EV.fOnQueryEndSession( Sender, Accept ); - Sender.DF.fCloseQueryReason := qClose; - Rslt := Integer( Accept ); - // Добавить. Нужно для того, чтобы отменилось завершение сеанса, - // если Accept установлен в False и сеанс завершился при Accept = True - // Add (YS). To cancel ending session if Accept=FALSE but allow ending - // session if Accept=TRUE. - Result := True; // {YS}: no further processing - end; - end; -end; - -procedure TControl.SetOnQueryEndSession(const Value: TOnEventAccept); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnQueryEndSession := Value; - AttachProc( WndProcQueryEndSession ); -end; - -function WndProcMinMaxRestore( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := FALSE; - if Msg.message = WM_SYSCOMMAND then - begin - case Msg.wParam and not 15 of - SC_MINIMIZE: {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnMinimize ) then - {$ENDIF} - Sender.EV.fOnMinimize( Sender ); - SC_MAXIMIZE: {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnMaximize ) then - {$ENDIF} - Sender.EV.fOnMaximize( Sender ); - SC_RESTORE: {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnRestore ) then - {$ENDIF} - Sender.EV.fOnRestore( Sender ); - end; - end; -end; - -procedure TControl.SetOnMinMaxRestore(const Index: Integer; - const Value: TOnEvent); -type POnEvent = ^TOnEvent; -{$IFDEF F_P} -var Ptr1: Pointer; -{$ELSE DELPHI} -var Evt: POnEvent; -{$ENDIF F_P/DELPHI} -begin - {$IFDEF F_P} - Ptr1 := Self; - asm - MOV EAX, [Ptr1] - LEA EAX, [EAX].TControl.fOnMinimize - ADD EAX, [Index] - MOV EDX, [Value] - MOV [EAX], EDX - MOV EDX, [Value+4] - MOV [EAX+4], EDX - end [ 'EAX', 'EDX' ]; - {$ELSE DELPHI} - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents; {$ENDIF} - Evt := Pointer( Integer( @ TMethod( EV.fOnMinimize ).Code ) + Index ); - Evt^ := Value; - {$ENDIF} - AttachProc( WndProcMinMaxRestore ); -end; - -procedure TControl.SetOnMinimize(const Value: TOnEvent); -begin - SetOnMinMaxRestore( 0, Value ); -end; - -procedure TControl.SetOnMaximize(const Value: TOnEvent); -begin - SetOnMinMaxRestore( 8, Value ); -end; - -procedure TControl.SetOnRestore(const Value: TOnEvent); -begin - SetOnMinMaxRestore( 16, Value ); -end; - -function TControl.GetOnMinMaxRestore(const Index: Integer): TOnEvent; -begin - CASE Index OF - 0: Result := EV.fOnMinimize; - 8: Result := EV.fOnMaximize; - 16: Result := EV.fOnRestore; - END; -end; - -{$IFDEF INPACKAGE} - {$IFDEF ASM_LOCAL} - {$UNDEF ASM_LOCAL} - {$ENDIF} -{$ELSE} - {$IFDEF ASM_VERSION} - {$DEFINE ASM_LOCAL} - {$ENDIF} -{$ENDIF} - -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -{$IFDEF ASM_LOCAL} -{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetParent( Value: PControl ); -begin - if Value = fParent then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fParent <> nil then - begin - {$IFDEF USE_GRAPHCTLS} - Invalidate; // necessary for graphic controls - {$ENDIF} - {$IFDEF DEBUG_MCK} - if ( fParent.fChildren <> nil ) then - begin - mck_Log( 'remove from old parent children 1st' ); - fParent.fChildren.Remove( @Self ); - mck_Log( 'removed ok' ); - end; - {$ELSE not DEBUG_MCK} - fParent.fChildren.Remove( @Self ); - {$IFDEF NOT_USE_AUTOFREE4CONTROLS} - {$ELSE} - fParent.RemoveFromAutoFree( @Self ); - {$ENDIF} - - {$IFDEF NIL_EVENTS} - if Assigned( fParent.PP.fNotifyChild ) then - {$ENDIF} - fParent.PP.fNotifyChild( fParent, nil ); - {$ENDIF not DEBUG_MCK} - end; - fParent := Value; - if fParent <> nil then - begin - fParent.fChildren.Add( @Self ); - {$IFDEF USE_AUTOFREE4CHILDREN} - fParent.Add2AutoFree( @ Self ); - {$ENDIF} - {$IFNDEF INPACKAGE} //----------------------------------------------------- - if FHandle <> 0 then - Windows.SetParent( FHandle, Value.GetWindowHandle ); - {$ENDIF not INPACKAGE} //-------------------------------------------------- - {$IFDEF NIL_EVENTS} - if Assigned( fParent.PP.fNotifyChild ) then - {$ENDIF} - fParent.PP.fNotifyChild( fParent, @ Self ); - {$IFDEF NIL_EVENTS} - if Assigned( PP.fNotifyChild ) then - {$ENDIF} - PP.fNotifyChild( fParent, @ Self ); - {$IFDEF USE_GRAPHCTLS} - Invalidate; // necessary for graphic controls - {$ENDIF} - end; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TControl.SetParent( Value: PControl ); -BEGIN - IF Value = fParent THEN Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IF fParent <> nil THEN - begin - fParent.fChildren.Remove( @Self ); - - {$IFDEF NOT_USE_AUTOFREE4CONTROLS} - {$ELSE} - fParent.RemoveFromAutoFree( @Self ); - {$ENDIF} - END; - fParent := Value; - IF fParent <> nil THEN - BEGIN - fParent.fChildren.Add( @Self ); - {$IFDEF USE_AUTOFREE4CHILDREN} - fParent.Add2AutoFree( @ Self ); - {$ENDIF} - END; - fParent.fGetClientArea( fParent ); - fParent.fChildPut( fParent, @ Self, fBoundsRect.Left, fBoundsRect.Top ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -function TControl.ChildIndex(Child: PControl): Integer; -begin - Result := fChildren.IndexOf( Child ); -end; - -procedure TControl.MoveChild(Child: PControl; NewIdx: Integer); -var I: Integer; -begin - I := ChildIndex( Child ); - {$IFDEF KOL_ASSERTIONS} - Assert( I>=0, 'TControl.MoveChild: index out of bounds' ); - {$ENDIF KOL_ASSERTIONS} - fChildren.MoveItem( I, NewIdx ); -end; - -{$IFDEF WIN_GDI} -procedure TControl.EnableChildren(Enable, Recursive: Boolean); -var I: Integer; - C: PControl; -begin - for I := 0 to ChildCount-1 do - begin - C := Children[ I ]; - C.Enabled := Enable; - if Recursive then - C.EnableChildren( Enable, TRUE ); - end; -end; - -{$ENDIF WIN_GDI} -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -constructor TControl.CreateParented(AParent: PControl); -begin - InitParented( AParent ); // because InitParented is virtual, but CreateParented -end; // can not be virtual (as an _object_ - not a class - constructor) -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -CONSTRUCTOR TControl.CreateParented(AParent: PControl; widget: PGtkWidget; - need_eventbox: Boolean); -BEGIN - InitParented( AParent, widget, need_eventbox ); - // because InitParented is virtual, but CreateParented -END; // can not be virtual (as an _object_ - not a class - constructor) -{$ENDIF GTK} -{$ENDIF _X_} - -constructor TControl.CreateOrthaned( AParentWnd: HWnd ); -begin - InitOrthaned( AParentWnd ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetLeft: Integer; -begin - Result := BoundsRect.Left; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetLeft( Value: Integer ); -var R: TRect; -begin - R := BoundsRect; - R.Left := Value; - R.Right := Value + Width; - SetBoundsRect( R ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetTop: Integer; -begin - Result := BoundsRect.Top; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetTop( Value: Integer ); -var R: TRect; -begin - R := BoundsRect; - R.Top := Value; - R.Bottom := Value + Height; - SetBoundsRect( R ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetWidth: Integer; -begin - with BoundsRect do - Result := Right - Left; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetWidth( Value: Integer ); -var R: TRect; -begin - R := BoundsRect; - with R do - Right := Left + Value; - SetBoundsRect( R ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetHeight: Integer; -begin - with BoundsRect do - Result := Bottom - Top; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetHeight( Value: Integer ); -var R: TRect; -begin - R := BoundsRect; - with R do - Bottom := Top + Value; - SetBoundsRect( R ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetPosition: TPoint; -begin - Result.x := BoundsRect.Left; - Result.y := BoundsRect.Top; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.Set_Position( Value: TPoint ); -var R: TRect; -begin - R.Top := Value.y; - R.Left := Value.x; - R.Right := R.Left + Width; - R.Bottom := R.Top + Height; - BoundsRect := R; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN_GDI} -function WndProcConstraints( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var MMI: PMinMaxInfo; -begin - Result := FALSE; - if Msg.message = WM_GETMINMAXINFO then - begin - Rslt := Sender.CallDefWndProc( Msg ); - MMI := Pointer( Msg.lParam ); - if Sender.FMaxWidth > 0 then - begin - MMI.ptMaxSize.x := Sender.FMaxWidth; - MMI.ptMaxTrackSize.x := Sender.FMaxWidth; - end; - if Sender.FMaxHeight > 0 then - begin - MMI.ptMaxSize.y := Sender.FMaxHeight; - MMI.ptMaxTrackSize.y := Sender.FMaxHeight; - end; - MMI.ptMinTrackSize := MakePoint( Sender.FMinWidth, Sender.FMinHeight ); - Rslt := 0; - Result := TRUE; - end; -end; - -{$IFDEF USE_MHTOOLTIP} -{$DEFINE implementation_part} -{$I KOLMHToolTip_implem.inc} -{$UNDEF implementation_part} -{$ENDIF} - -procedure TControl.SetConstraint(const Index: Integer; Value: SmallInt); -begin - AttachProc( WndProcConstraints ); - case Index of - 0: FMinWidth := Value; - 1: FMinHeight := Value; - 2: FMaxWidth := Value; - 3: FMaxHeight := Value; - end; -end; - -function TControl.GetConstraint(const Index: Integer): Integer; -begin - CASE Index OF - 0: Result := FMinWidth; - 1: Result := FMinHeight; - 2: Result := FMaxWidth; - else Result := FMaxHeight; - END; -end; - -function TControl.ControlRect: TRect; -var C: PControl; - R: TRect; -begin - Result := BoundsRect; - C := Parent; - if C <> nil then - begin - if {$IFDEF USE_FLAGS} not(G3_IsControl in C.fFlagsG3) - {$ELSE} not C.fIsControl {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>} - - R := C.ControlRect; - OffsetRect( Result, R.Left, R.Top ); - - if C.fChildren <> nil then - if C.FChildren.IndexOf( @Self ) >= 0 then - begin - R := C.ClientRect; - Dec( R.Top, C.fClientTop ); - Dec( R.Left, C.fClientLeft ); - OffsetRect( Result, R.Left, R.Top ); - end; - end; -end; - -function TControl.ControlAtPos( X, Y: Integer; IgnoreDisabled: Boolean ): PControl; -var I: Integer; - C: PControl; - CR, VR: TRect; -begin - Result := nil; - CR := ControlRect; // относительные координаты в системе РОДИТЕЛЬСКОГО КОНТРОЛА - if {$IFDEF USE_FLAGS} not(G6_GraphicCtl in fFlagsG6) - {$ELSE} fWindowed {$ENDIF} then CR := MakeRect( 0, 0, 0, 0 ); - X := X + CR.Left; // - R.Left; - Y := Y + CR.Top; // - R.Top; - for I := ChildCount - 1 downto 0 do - begin - C := Children[ I ]; //Members[ I ]; - if C.Visible then - if (not IgnoreDisabled) or IgnoreDisabled and C.Enabled then - begin - VR := C.ControlRect; - if (X >= VR.Left) and (X < VR.Right) and - (Y >= VR.Top) and (Y < VR.Bottom) then - begin - Result := C; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; -end; -{$ENDIF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect ); -{$IFDEF GDI} var B: HBrush; {$ENDIF GDI} -begin - {$IFDEF GDI} - B := CreateSolidBrush( Color2Rgb( Sender.Color ) ); - Windows.FillRect( DC, Rect^, B ); - DeleteObject( B ); - {$ENDIF GDI} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN_GDI} -procedure TControl.PaintBackground( DC: HDC; Rect: PRect ); -begin - Global_OnPaintBkgnd( @Self, DC, Rect ); -end; -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetCtlColor( Value: TColor ); -begin - {$IFNDEF INPACKAGE} - if GetWindowHandle <> 0 then - {$ELSE} - if fHandle <> 0 then - {$ENDIF} - if fCommandActions.aSetBkColor <> 0 then - Perform( fCommandActions.aSetBkColor, 0, Color2RGB( Value ) ); - if fColor = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fColor := Value; - if fTmpBrush <> 0 then - begin - DeleteObject( fTmpBrush ); - fTmpBrush := 0; - end; - if fBrush <> nil then - fBrush.Color := Value; - Invalidate; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TControl.SetCtlColor( Value: TColor ); -VAR gcolor: TGdkColor; - i: Integer; -BEGIN - if fColor = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fColor := Value; - gcolor := Color2GdkColor( Value ); - FOR i := 0 to 4 do - BEGIN - gtk_widget_modify_bg( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor ); - gtk_widget_modify_base( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor ); - END; - //if Assigned( _Self.fFont ) then - {begin - _Self.fHandle.style.font_desc := - pango_font_description_copy( _Self.fFont.GetPangoFontDesc ); - if oldfontdesc <> nil then - pango_font_description_free( oldfontdesc ); - end;} - - //Invalidate; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetParentWnd( NeedHandle: Boolean ): HWnd; -var C: PControl; -begin - Result := FParentWnd; - C := fParent; // WindowedParent; - if C <> nil then - begin - if NeedHandle then - C.GetWindowHandle; - Result := C.fHandle; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -procedure TControl.CreateChildWindows; -asm - PUSH ESI - MOV ESI, [EAX].TControl.fChildren - MOV ECX, [ESI].TList.fCount - MOV ESI, [ESI].TList.fItems - JECXZ @@exit - -@@loop: PUSH ECX - LODSD - CALL CallTControlCreateWindow - POP ECX - LOOP @@loop - -@@exit: POP ESI -end; -{$ELSE PAS_VERSION} //Pascal -procedure TControl.CreateChildWindows; -var I: Integer; - C: PControl; -begin - {$IFDEF INPACKAGE} - Log( '->TControl.CreateChildWindows' ); - TRY - {$ENDIF INPACKAGE} - for I := 0 to fChildren.Count - 1 do - begin - {$IFDEF INPACKAGE} - Log( Int2Str( I ) ); - {$ENDIF INPACKAGE} - C := fChildren.Items[ I ]; - C.CreateWindow; //virtual!!! - end; - {$IFDEF INPACKAGE} - LogOK; - FINALLY - Log( '<-TControl.CreateChildWindows' ); - END; - {$ENDIF INPACKAGE} -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} -function TControl.GetMembers(Idx: Integer): PControl; -begin - Result := fChildren.Items[ Idx ]; - // Important: .Items but not .fItems - when fChildren.Count=0, nil is returned -end; -{$IFDEF WIN_GDI} - -{$IFDEF ASM_TLIST} -procedure TControl.DestroyChildren; -asm - PUSH ESI - - MOV EAX, [EAX].fChildren - PUSH EAX - MOV ECX, [EAX].TList.fCount - JECXZ @@clear - MOV ESI, [EAX].TList.fItems - LEA ESI, [ESI + ECX*4 - 4] // is order really important ? - -@@loop: STD // - LODSD - CLD // - - PUSH ECX - CALL TObj.RefDec - POP ECX - - LOOP @@loop - -@@clear: - POP EAX - CALL TList.Clear - - POP ESI -end; -{$ELSE PAS_VERSION} //Pascal -procedure TControl.DestroyChildren; -var I: Integer; - W: PControl; -begin - for I := fChildren.fCount - 1 downto 0 do - begin - W := fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - W.Free; - end; - fChildren.Clear; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.ProcessMessage: Boolean; -var Msg: TMsg; - P: Windows.PMsg; -begin - Result := False; - if PeekMessage( Msg, 0, 0, 0, PM_REMOVE ) then - begin - Result := Msg.message <> 0; - if (Msg.message = WM_QUIT) then - begin - AppletTerminated := True; - {$IFDEF PROVIDE_EXITCODE} - ExitCode := Msg.wParam; - {$ENDIF PROVIDE_EXITCODE} - end - else - begin - if not( - {$IFDEF NIL_EVENTS} Assigned( PP.fExMsgProc ) and {$ENDIF} - PP.fExMsgProc( @Self, Msg )) then - begin - P := Pointer( @Msg ); - TranslateMessage( P^ ); - DispatchMessage( Msg ); - {$IFDEF PSEUDO_THREADS} - if Assigned( MainThread ) then - MainThread.NextThread; - {$ENDIF} - end; - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.ProcessMessages; -begin - while ProcessMessage do ; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.ProcessMessagesEx; -begin - PostMessage( GetWindowHandle, CM_PROCESS, 0, 0 ); - ProcessMessages; -end; - -procedure TControl.ProcessPendingMessages; -var Msg: TMsg; -begin - if LOWORD( GetQueueStatus( QS_ALLINPUT ) ) <> 0 then - if PeekMessage( Msg, 0, 0, 0, PM_NOREMOVE {or PM_NOYIELD} ) - or PeekMessage( Msg, HWnd(-1), 0, 0, PM_NOREMOVE {or PM_NOYIELD} ) - then - Applet.ProcessMessages; -end; - -procedure TControl.ProcessPaintMessages; -var Msg: TMsg; -begin - while PeekMessage( Msg, Handle, 15, 15, PM_NOREMOVE ) do - Applet.ProcessMessage; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcForm(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -{$IFDEF ENDSESSION_HALT} -var App: PControl; -{$ENDIF} -begin - Result := True; - case Msg.message of - {$IFDEF ENDSESSION_HALT} - WM_ENDSESSION: - begin - if Msg.wParam <> 0 then - begin - Self_.RefDec; - { Normally, WM_ENDSESSION is sent to a main form, not to Applet. - Since we do not plan further working after handling this message, - we decrease RefCount for the form (in was increased in EnumDynHandlers - to prevent object destroying while its message processing is not - finished). } - App := Applet; - //Rslt := 0; { We will not return any result at all. } - {$IFDEF DEBUG_ENDSESSION} - EndSession_Initiated := TRUE; - LogFileOutput( GetStartDir + 'es_debug.txt', - 'Self_=' + Int2Hex( DWORD( Self_ ), 8 ) + - ' Self_.Handle=' + Int2Str( Self_.FHandle ) ); - {$ENDIF} - AppletTerminated := TRUE; - AppletRunning := FALSE; - Applet := nil; - App.Free; { We provide OnDestroy handlers to be called for any objects here } - Halt; { Stop further executing. } - end else Result := FALSE; - end; - {$ENDIF ENDSESSION_HALT} - WM_SETFOCUS: - begin - {$IFDEF NEW_MODAL} - if Self_.DF.fModalForm <> nil then - SetFocus( Self_.DF.fModalForm.fHandle ) - else if ( Self_.DF.FCurrentControl <> nil ) and - {$IFDEF USE_FLAGS} not( (G3_IsForm in Self_.DF.fCurrentControl.fFlagsG3) - xor(G3_IsApplet in Self_.fFlagsG3) ) - {$ELSE} not(Self_.DF.FCurrentControl.fIsForm xor Self_.fIsApplet) - {$ENDIF} then - {$ELSE not NEW_MODAL} - if Self_.DF.FCurrentControl <> nil then - {$ENDIF} - begin - if Self_.DF.FCurrentControl.CreateWindow then - SetFocus( Self_.DF.FCurrentControl.fHandle ); - end - else - Result := False; - if assigned( Applet ) and (Applet <> Self_) then - Applet.DF.FCurrentControl := Self_; - end; - //WM_NCDESTROY: - // Self_.RefDec; - else Result := False; - end; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean; -var Idx: Integer; -begin - Result := False; - if P.FParent = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Idx := P.FParent.ChildIndex( P ) - 1; - if Idx < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := True; - R := P.FParent.Children[ Idx ].BoundsRect; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.PlaceUnder: PControl; -var R: TRect; -begin - Result := @Self; - if not GetPrevCtrlBoundsRect( @Self, R ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>} - Top := R.Bottom + fParent.fMargin; - Left := R.Left; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.PlaceDown: PControl; -var R: TRect; -begin - Result := @Self; - if not GetPrevCtrlBoundsRect( @Self, R ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>} - Top := R.Bottom + fParent.fMargin; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.PlaceRight: PControl; -var R: TRect; -begin - Result := @Self; - if not GetPrevCtrlBoundsRect( @Self, R ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>} - Top := R.Top; - Left := R.Right + fParent.fMargin; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.SetSize(W, H: Integer): PControl; -var R: TRect; -begin - R := BoundsRect; - if W > 0 then R.Right := R.Left + W; - if H > 0 then R.Bottom := R.Top + H; - SetBoundsRect( R ); - Result := @Self; -end; -{$ENDIF PAS_VERSION} -{$IFDEF WIN_GDI} - -function TControl.SetClientSize(W, H: Integer): PControl; -begin - if W > 0 then ClientWidth := W; - if H > 0 then ClientHeight := H; - Result := @Self; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.AlignLeft(P: PControl): PControl; -begin - Result := @Self; - Left := P.Left; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.AlignTop(P: PControl): PControl; -begin - Result := @Self; - Top := P.Top; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF KEY_PREVIEW} - {$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS} -{$ENDIF} -{$IFDEF ESC_CLOSE_DIALOGS} - {$IFNDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS} - {$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS} - {$ENDIF} -{$ENDIF} - -{$IFDEF ASM_VERSION} // see addition for combobox in pas version -{$ELSE PAS_VERSION} //Pascal -function WndProcCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean; -var F: PControl; - Cmd : DWORD; -begin - Result := FALSE; - with Self_^ do - case Msg.message of - CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC: - begin - SetTextColor(Msg.WParam, Color2RGB(fTextColor)); - if {$IFDEF USE_FLAGS} G2_Transparent in fFlagsG2 - {$ELSE} fTransparent {$ENDIF} then - begin - SetBkMode( Msg.wParam, Windows.TRANSPARENT ); - Rslt := GetStockObject( NULL_BRUSH ); - end else - begin - SetBkMode( Msg.wParam, Windows.OPAQUE ); - SetBkColor(Msg.WParam, Color2RGB( fColor ) ); - Rslt := Global_GetCtlBrushHandle( Self_ ); - end; - Result := TRUE; - end; - CM_COMMAND: - begin - Result := True; - Cmd := HiWord( Msg.wParam ); - if Cmd = fCommandActions.aClick then - begin - if Integer( fClickDisabled ) <= 0 then - begin - Focused := TRUE; - DoClick; - end; - end else - if Cmd = fCommandActions.aEnter then - begin - if Assigned( EV.fOnEnter ) then EV.fOnEnter( Self_ ); - end else - if Cmd = fCommandActions.aLeave then - begin - if Assigned( EV.fOnLeave ) then EV.fOnLeave( Self_ ); - end else - if Integer(Cmd) = fCommandActions.aChange then - begin - if Assigned( EV.fOnChangeCtl ) then EV.fOnChangeCtl( Self_ ); - end else - if Integer(Cmd) = fCommandActions.aSelChange then - begin - DoSelChange; - end - else Result := False; - - if Result then - Rslt := CallDefWndProc( Msg ); - - end; - - WM_SETFOCUS: - begin - Rslt := 0; - Result := TRUE; - F := ParentForm; - if F <> nil then - begin - if (F.DF.fCurrentControl <> nil) and (F.DF.fCurrentControl <> Self_) - {$IFDEF NIL_EVENTS} - and Assigned( F.DF.fCurrentControl.EV.fLeave ) - {$ENDIF} - then - F.DF.fCurrentControl.EV.fLeave( F.DF.fCurrentControl ); - F.DF.fCurrentControl := Self_; - Result := False; // go further handling - end; - end; - {$IFDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS} - WM_KEYDOWN: - begin - {$IFDEF KEY_PREVIEW} - //--------------------------------Truf------------------------------------- - F := ParentForm; - if F <> Self_ then - begin - if {$IFDEF USE_FLAGS} G6_KeyPreview in F.fFlagsG6 - {$ELSE} F.fKeyPreview {$ENDIF} then - begin - {$IFDEF USE_FLAGS} - include( F.fFlagsG4, G4_Pushed ); - {$ELSE} F.fKeyPreviewing := TRUE; {$ENDIF} - inc( F.DF.fKeyPreviewCount ); - F.Perform(WM_KEYDOWN,msg.wParam,msg.lParam); - dec( F.DF.fKeyPreviewCount ); - end; - end; - //--------------------------------Truf------------------------------------- - {$ENDIF KEY_PREVIEW} - {$IFDEF ESC_CLOSE_DIALOGS} - //---------------------------------Babenko Alexey-------------------------- - begin - F := ParentForm; - if (F.fExStyle and WS_EX_DLGMODALFRAME) <> 0 then - if Msg.wParam = 27 then - F.Perform(WM_CLOSE, 0, 0); - end; - //---------------------------------Babenko Alexey-------------------------- - {$ENDIF ESC_CLOSE_DIALOGS} - end; - {$IFDEF KEY_PREVIEW} - WM_KEYUP..WM_SYSDEADCHAR: - begin - F := ParentForm; - if F <> Self_ then - begin - if {$IFDEF USE_FLAGS} G6_KeyPreview in F.fFlagsG6 - {$ELSE} F.fKeyPreview {$ENDIF} then - begin - {$IFDEF USE_FLAGS} - include( F.fFlagsG4, G4_Pushed ); - {$ELSE} F.fKeyPreviewing := TRUE; {$ENDIF} - inc( F.DF.fKeyPreviewCount ); - F.Perform(Msg.message,msg.wParam,msg.lParam); - dec( F.DF.fKeyPreviewCount ); - end; - end; - end; - {$ENDIF KEY_PREVIEW} - {$ENDIF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS} - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF OLD_TRANSPARENT} -function WndProcTransparent( Sender: PControl; var Msg: TMsg; - var Rslt: Integer ): Boolean; -var DC, PDC, BLTDC: HDC; - Save: integer; - OLDp: THANDLE; - L, T: SmallInt; - TP, ParentClient: TPoint; - TR, Margins: TRect; - Wnd: HWND; - tRgn: HRgn; - C: PControl; -begin - Result := FALSE; - {$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED} - if AppletTerminated or not Sender.ToBeVisible then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - case Msg.message of - WM_HSCROLL, WM_VSCROLL: - begin - Sender.Invalidate; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_SETTEXT: - begin - if {$IFDEF USE_FLAGS} not(G1_IsStaticControl in Sender.fFlagsG1) - {$ELSE} Sender.fIsStaticControl = 0 {$ENDIF} then - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Sender.Invalidate; - Rslt := DefWindowProc - ( Sender.fHandle, WM_SETTEXT, Msg.wParam, Msg.lParam ); - Result := TRUE; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_NCPAINT: - begin - if Sender.fTransparent then - Result := TRUE; - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - if Sender.fTransparent and ( - {$IFDEF USE_FLAGS} not(G2_DoubleBuffered in Sender.FParent.fFlagsG2) - {$ELSE} not Sender.fParent.fDoubleBuffered {$ENDIF} ) then - Sender.fTransparent := FALSE; - if {$IFDEF USE_FLAGS} [G2_DoubleBuffered, G2_Transparent] * Sender.fFlagsG2 = [] - {$ELSE} not (Sender.fTransparent or Sender.fDoubleBuffered) {$ENDIF} then - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Sender.fAnchors and SELF_REQ_PAINT <> 0 then exit; {>>>>>>>>>>>>>>>>>>} - - case Msg.message of - WM_ERASEBKGND: - begin - Result := TRUE; - end; - WM_PAINT: - begin - ValidateRect(Sender.fHandle, nil); //???--brandys??? - if (Sender.fTransparent) - and (Sender.fAnchors and PARENT_REQ_PAINT = 0) then - begin - InvalidateRect(Sender.fParent.Handle, nil, FALSE); - Result := TRUE; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - GetClientRect(Msg.hwnd, Margins); - OLDp := 0; - if Sender.fAnchors and PARENT_REQ_PAINT = 0 then - begin - Sender.fDblExcludeRgn := CreateRectRgn(0, 0, Margins.Right, Margins.Bottom); - DC := GetDC(0); - PDC := CreateCompatibleDC( DC ); - OLDp := SelectObject(PDC, - CreateCompatibleBitmap(DC, Margins.Right, Margins.Bottom) ); - ReleaseDC(0, DC); - Sender.fParentCoordX := 0; - Sender.fParentCoordy := 0; - end else begin - PDC := Msg.wParam; - Sender.fDblExcludeRgn := Sender.fParent.fDblExcludeRgn; - end; - - Sender.fAnchors := Sender.fAnchors or SELF_REQ_PAINT; - Sender.fPaintDC := PDC; - if (Sender.fAnchors and PARENT_REQ_PAINT = 0) or - {$IFDEF USE_FLAGS} G2_DoubleBuffered in Sender.fFlagsG2 - {$ELSE} Sender.fDoubleBuffered {$ENDIF} then - Sender.Perform(WM_ERASEBKGND, PDC, 0); - Sender.Perform(WM_PAINT, PDC, 0); - - Wnd := GetWindow( Sender.fHandle, GW_CHILD ); - Wnd := GetWindow( Wnd, GW_HWNDLAST); - while Wnd <> 0 do begin - if IsWindowVisible(Wnd) then begin - {$IFDEF USE_PROP} - C := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} - C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) ); - {$ENDIF} - with C^ do begin - if (C <> nil) and - {$IFDEF USE_FLAGS} ( [G2_DoubleBuffered, G2_Transparent] - * fFlagsG2 <> [] ) - {$ELSE} (fTransparent or fDoubleBuffered) {$ENDIF} then - begin - Save := SaveDC( PDC ); - Include( fAnchors, PARENT_REQ_PAINT ); - L := Sender.fParentCoordX + Left; - T := Sender.fParentCoordY + Top; - SetWindowOrgEx(PDC, -L, -T, nil); - SendMessage(Wnd, WM_PRINT, PDC, PRF_NONCLIENT); - TP.x := 0; TP.Y := 0; - ClientToScreen(fHandle, TP); - GetWindowRect(fHandle, TR); - fParentCoordX := L + TP.X - TR.Left; - fParentCoordY := T + TP.Y - TR.Top; - SetWindowOrgEx(PDC, -fParentCoordX, -fParentCoordY, nil); - GetClientRect(Wnd, TR); - IntersectClipRect(PDC, 0, 0, TR.Right, TR.Bottom); - SendMessage(Wnd, WM_PAINT, PDC, 0); - Exclude( fAnchors, PARENT_REQ_PAINT ); - RestoreDC( PDC, Save ); - end else - begin - GetWindowRect(Wnd, TR); - TP.X := 0; TP.Y := 0; - ClientToScreen(Sender.fHandle, TP); - TP.X := TR.Left - TP.X + Sender.fParentCoordX; - TP.Y := TR.Top - TP.Y + Sender.fParentCoordY; - TR.Left := TR.Right - TR.Left; - TR.Top := TR.Bottom - TR.Top; - - tRgn := CreateRectRgn(TP.X, TP.Y, TP.X+TR.Left, TP.Y+TR.Top); - CombineRgn(Sender.fDblExcludeRgn, Sender.fDblExcludeRgn, tRgn, RGN_DIFF); - DeleteObject(tRgn); - end; - end; - end; - Wnd := GetWindow( Wnd, GW_HWNDPREV ); - end; - Sender.fPaintDC := 0; - Sender.fAnchors := Sender.fAnchors and not SELF_REQ_PAINT; - - if Sender.fAnchors and PARENT_REQ_PAINT = 0 then - begin - BLTDC := GetWindowDC(Sender.fHandle); - GetWindowRect( Sender.fHandle, TR ); - ParentClient.x := 0; ParentClient.y := 0; - ClientToScreen( Sender.fHandle, ParentClient ); - SetWindowOrgEx(BLTDC, TR.Left - ParentClient.x, TR.Top - ParentClient.y, nil); - OffsetRgn(Sender.fDblExcludeRgn, ParentClient.x - TR.Left, ParentClient.y - TR.Top); - ExtSelectClipRgn(BLTDC, Sender.fDblExcludeRgn, RGN_AND); - - BitBlt( BLTDC, 0, 0, Margins.Right, Margins.Bottom, PDC, 0, 0, SRCCOPY ); - ReleaseDC(Sender.fHandle, BLTDC); - DeleteObject(SelectObject( PDC, OLDp )); - DeleteObject(Sender.fDblExcludeRgn); - DeleteDC( PDC ); - end; - - //ValidateRect(Sender.fHandle, nil); //???++brandys???// - Result := TRUE; - end; - end; -end; -{$ELSE NEW_TRANSPARENT} // by Alexander Karpinsky a.k.a. homm -function WndProcTransparent( Sender: PControl; var Msg: TMsg; - var Rslt: Integer ): Boolean; - - function SetRectRgnInderect(tRgn: HRGN; const TR: TRect): BOOL; - begin - Result := SetRectRgn(tRgn, TR.Left, TR.Top, TR.Right, TR.Bottom); - end; - -var - DC, PDC, BLTDC: HDC; - Save: integer; - OLDp: THANDLE; - L, T: SmallInt; - TP: TPoint; - TR, Margins: TRect; - Wnd: HWND; - C: PControl; - ChildRgn: HRGN; - PS: TPaintStruct; - -begin - Result := FALSE; - - {$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED} - if AppletTerminated or not Sender.ToBeVisible then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - - if {$IFDEF USE_FLAGS} (G2_Transparent in Sender.fFlagsG2) - {$ELSE} Sender.fTransparent {$ENDIF} and ( - {$IFDEF USE_FLAGS} not(G2_DoubleBuffered in Sender.FParent.fFlagsG2) - {$ELSE} not Sender.fParent.fDoubleBuffered {$ENDIF} ) then - {$IFDEF USE_FLAGS} exclude( Sender.fFlagsG2, G2_Transparent ); - {$ELSE} Sender.fTransparent := FALSE; {$ENDIF} - if {$IFDEF USE_FLAGS} [G2_DoubleBuffered, G2_Transparent] * Sender.fFlagsG2 = [] - {$ELSE} not (Sender.fTransparent or Sender.fDoubleBuffered) {$ENDIF} then - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - - case Msg.message of - WM_HSCROLL, WM_VSCROLL: - begin - Sender.Invalidate; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_SETTEXT: - begin - if {$IFDEF USE_FLAGS} not(G1_IsStaticControl in Sender.fFlagsG1) - {$ELSE} Sender.fIsStaticControl = 0 {$ENDIF} then exit; {>>>>>>>>>>} - Sender.Invalidate; - Rslt := DefWindowProc ( Sender.fHandle, WM_SETTEXT, Msg.wParam, Msg.lParam ); - Result := TRUE; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_PAINT, - WM_ERASEBKGND:; - WM_NCPAINT: - if {$IFDEF USE_FLAGS} not(G2_Transparent in Sender.fFlagsG2) - {$ELSE} not Sender.fTransparent {$ENDIF} then - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - else exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if Sender.fAnchors and SELF_REQ_PAINT <> 0 then exit; {>>>>>>>>>>>>>>>>>>>>>} - Result := TRUE; - if Assigned(Sender.fParent) - and {$IFDEF USE_FLAGS} not(G3_IsForm in Sender.fFlagsG3) - {$ELSE} (not Sender.fIsForm) {$ENDIF} - and {$IFDEF USE_FLAGS} (G2_DoubleBuffered in Sender.FParent.fFlagsG2) - {$ELSE} Sender.FParent.fDoubleBuffered {$ENDIF} - and (Sender.fAnchors and PARENT_REQ_PAINT = 0) then - begin - TR := Sender.BoundsRect; - InvalidateRect(Sender.fParent.fHandle, @TR, true); - ValidateRect(Sender.fHandle, nil); //???--brandys???+ - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - - if Msg.message = WM_PAINT then begin - OLDp := 0; - if Sender.fAnchors and PARENT_REQ_PAINT = 0 then - begin - Sender.fDblExcludeRgn := CreateRectRgn(0, 0, 0, 0); - if Integer( GetUpdateRgn(Sender.fHandle, Sender.fDblExcludeRgn, TRUE) ) <= NULLREGION then - begin - DeleteObject(Sender.fDblExcludeRgn); - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - - DC := BeginPaint(Sender.fHandle, PS); - PDC := CreateCompatibleDC( DC ); - GetClientRect(Msg.hwnd, Margins); - OLDp := SelectObject(PDC, CreateCompatibleBitmap(DC, Margins.Right, Margins.Bottom) ); - Sender.fParentCoordX := 0; - Sender.fParentCoordy := 0; - end else - begin - PDC := Msg.wParam; - Sender.fDblExcludeRgn := Sender.fParent.fDblExcludeRgn; - end; - - Sender.fAnchors := Sender.fAnchors or SELF_REQ_PAINT; - Sender.fPaintDC := PDC; - if (Sender.fAnchors and PARENT_REQ_PAINT = 0) or - {$IFDEF USE_FLAGS} (G2_DoubleBuffered in Sender.fFlagsG2) - {$ELSE} Sender.fDoubleBuffered {$ENDIF} then - Sender.Perform(WM_ERASEBKGND, PDC, 0); - Sender.Perform(WM_PAINT, PDC, 0); - - - Wnd := GetWindow( Sender.fHandle, GW_CHILD ); - Wnd := GetWindow( Wnd, GW_HWNDLAST); - while Wnd <> 0 do begin - if IsWindowVisible(Wnd) then begin - ChildRgn := CreateRectRgn(0, 0, 0, 0); - if Integer( GetWindowRgn(WND, ChildRgn) ) <= NULLREGION then begin - GetWindowRect(WND, TR); - TP.X := 0; TP.Y := 0; - ClientToScreen(Sender.fHandle, TP); - OffsetRect(TR, -TP.X , -TP.Y); - SetRectRgnInderect(ChildRgn, TR); - end; - OffsetRgn(ChildRgn, Sender.fParentCoordX, Sender.fParentCoordY); - - {$IFDEF USE_PROP} - C := Pointer( GetProp( Wnd, ID_SELF ) ); - {$ELSE} - C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) ); - {$ENDIF} - if CombineRgn(ChildRgn, ChildRgn, Sender.fDblExcludeRgn, RGN_AND) >= SIMPLEREGION then begin - with C^ do begin - if (C <> nil) and - {$IFDEF USE_FLAGS} ( [G2_DoubleBuffered, G2_Transparent] * fFlagsG2 <> [] ) - {$ELSE} (fTransparent or fDoubleBuffered) {$ENDIF} then - begin - Save := SaveDC( PDC ); - fAnchors := fAnchors or PARENT_REQ_PAINT; - - L := Sender.fParentCoordX + Left; - T := Sender.fParentCoordY + Top; - SetWindowOrgEx(PDC, -L, -T, nil); - SendMessage(Wnd, WM_PRINT, PDC, PRF_NONCLIENT); - TP.x := 0; TP.Y := 0; - ClientToScreen(fHandle, TP); - GetWindowRect(fHandle, TR); - fParentCoordX := L + TP.X - TR.Left; - fParentCoordY := T + TP.Y - TR.Top; - SetWindowOrgEx(PDC, -fParentCoordX, -fParentCoordY, nil); - GetClientRect(Wnd, TR); - IntersectClipRect(PDC, 0, 0, TR.Right, TR.Bottom); - SendMessage(Wnd, WM_PAINT, PDC, 0); - fAnchors := fAnchors and not PARENT_REQ_PAINT; - RestoreDC( PDC, Save ); - end else begin - CombineRgn(Sender.fDblExcludeRgn, Sender.fDblExcludeRgn, ChildRgn, RGN_DIFF); - end; - end; - end; // if Save >= SIMPLEREGION then begin - DeleteObject(ChildRgn); - end; - Wnd := GetWindow( Wnd, GW_HWNDPREV ); - end; - Sender.fPaintDC := 0; - Sender.fAnchors := Sender.fAnchors and not SELF_REQ_PAINT; - - if Sender.fAnchors and PARENT_REQ_PAINT = 0 then - begin - BLTDC := GetDCEx(Sender.fHandle, 0, DCX_CACHE or DCX_CLIPSIBLINGS); - ExtSelectClipRgn(BLTDC, Sender.fDblExcludeRgn, RGN_AND); - - BitBlt(BLTDC, 0, 0, Margins.Right, Margins.Bottom, PDC, 0, 0, SRCCOPY ); - - ReleaseDC(Sender.fHandle, BLTDC); - DeleteObject(SelectObject( PDC, OLDp )); - DeleteObject(Sender.fDblExcludeRgn); - DeleteDC( PDC ); - EndPaint(Sender.fHandle, PS); - end; - end; -end; -{$ENDIF} - -{$IFDEF ASM_noVERSION} -function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -const szPaintStruct = sizeof(TPaintStruct); -asm - CMP word ptr [EDX].TMsg.message, WM_PRINT - JE @@print - CMP word ptr [EDX].TMsg.message, WM_PAINT - JNE @@ret_false -@@print: - CMP word ptr [EAX].TControl.fOnPaint.TMethod.Code+2, 0 - JE @@ret_false - PUSH EBX - PUSH ESI - - XCHG EBX, EAX - MOV ESI, EDX - XOR EAX, EAX - PUSH ECX - PUSH EAX - PUSH EAX - PUSH EAX - PUSH EAX - CALL CreateRectRgn - MOV [EBX].TControl.fUpdRgn, EAX - - MOVSX EDX, [EBX].TControl.fEraseUpdRgn - PUSH EDX - PUSH EAX - PUSH [EBX].TControl.fHandle - CALL GetUpdateRgn - - CMP EAX, 1 - JA @@collectUpdRgn - - XOR EAX, EAX - XCHG EAX, [EBX].TControl.fUpdRgn - PUSH EAX - CALL DeleteObject - -@@collectUpdRgn: - MOV ECX, [EBX].TControl.fCollectUpdRgn - JECXZ @@asg_fPaintDC - XCHG EAX, ECX - MOV ECX, [EBX].TControl.fUpdRgn - JECXZ @@asg_fPaintDC - - PUSH RGN_OR - PUSH ECX - PUSH EAX - PUSH EAX - CALL CombineRgn - - DEC EAX - JNZ @@invalidateRgn - - ADD ESP, -16 - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL Windows.GetClientRect - - PUSH [EBX].TControl.fCollectUpdRgn - CALL DeleteObject - CALL CreateRectRgn - MOV [EBX].TControl.fCollectUpdRgn, EAX - -@@invalidateRgn: - MOVSX EDX, [EBX].TControl.fEraseUpdRgn - PUSH EDX - PUSH [EBX].TControl.fCollectUpdRgn - PUSH [EBX].TControl.fHandle - CALL InvalidateRgn - -@@asg_fPaintDC: - MOV ECX, [ESI].TMsg.wParam - INC ECX - LOOP @@storePaintDC - - ADD ESP, -szPaintStruct - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL BeginPaint - XCHG ECX, EAX -@@storePaintDC: - MOV [EBX].TControl.fPaintDC, ECX - XCHG EAX, ECX - - MOV ECX, [EBX].TControl.fCollectUpdRgn - JECXZ @@doOnPaint - - PUSH ECX - PUSH EAX - CALL SelectClipRgn - -@@doOnPaint: - MOV ECX, [EBX].TControl.fPaintDC - MOV EDX, EBX - - MOV EAX, [EBX].TControl.fOnPaint.TMethod.Data - CALL dword ptr [EBX].TControl.fOnPaint.TMethod.Code - - MOV ECX, [EBX].TControl.fCanvas - JECXZ @@e_paint - - XCHG EAX, ECX - XOR EDX, EDX - CALL TCanvas.SetHandle - -@@e_paint: - MOV ECX, [ESI].TMsg.wParam - INC ECX - LOOP @@zero_fPaintDC - - PUSH ESP - PUSH [EBX].TControl.fHandle - CALL EndPaint - ADD ESP, szPaintStruct - -@@zero_fPaintDC: - XOR ECX, ECX - MOV [EBX].TControl.fPaintDC, ECX - - POP EAX - MOV [EAX], ECX - - XCHG ECX, [EBX].TControl.fUpdRgn - JECXZ @@exit_True - - PUSH ECX - CALL DeleteObject - -@@exit_True: - POP ESI - POP EBX - MOV AL, 1 - RET - -@@ret_false: - XOR EAX, EAX -end; -{$ELSE PAS_VERSION} //Pascal -function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var PaintStruct: TPaintStruct; - Cplxity: Integer; - OldPaintDC: HDC; -begin - with Self_^ do - case Msg.message of - //WM_PRINT, - WM_PAINT: if assigned( EV.fOnPaint ) then - begin - fUpdRgn := CreateRectRgn( 0, 0, 0, 0 ); - Cplxity := Integer( GetUpdateRgn( fHandle, fUpdRgn, - {$IFDEF USE_FLAGS} G5_EraseBkgnd in fFlagsG5 - {$ELSE} fEraseUpdRgn {$ENDIF} ) ); - if (Cplxity = NULLREGION) or (Cplxity = ERROR) then - begin - DeleteObject( fUpdRgn ); - fUpdRgn := 0; - end; - - OldPaintDC := fPaintDC; - fPaintDC := Msg.wParam; - if fPaintDC = 0 then - fPaintDC := BeginPaint( fHandle, PaintStruct ); - - EV.fOnPaint( Self_, fPaintDC ); - - if assigned( Self_.fCanvas ) then - Self_.fCanvas.SetHandle( 0 ); - - if Msg.wParam = 0 then - EndPaint( fHandle, PaintStruct ); - fPaintDC := OldPaintDC; - - Rslt := 0; - - Result := True; - if fUpdRgn <> 0 then - DeleteObject( fUpdRgn ); - fUpdRgn := 0; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := FALSE; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} -{$IFDEF GDI} -procedure TControl.SetOnPaint( const Value: TOnPaint ); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnPaint := Value; - AttachProc( WndProcPaint ); -end; -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION expose_widget( Widget: PGtkWidget; Event: PGdkEventExpose; - Sender: PControl ): Boolean; cdecl; -BEGIN - IF not Assigned( Sender.fOnPaint ) THEN Result := FALSE - ELSE - BEGIN - Sender.Canvas.SaveState; - Sender.fOnPaint( Sender, Sender.Canvas.Handle ); - Sender.Canvas.RestoreState; - Result := TRUE; - END; -END; - -PROCEDURE TControl.SetOnPaint( const Value: TOnPaint ); -BEGIN - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnPaint := Value; - {$IFNDEF SMALLER_CODE} // it is actually not necessary to disconnect, event - // still will be fired but fOnPaint is not assigned - // so FALSE will be returned to GTK. - IF NOT Assigned( Value ) THEN - gtk_signal_disconnect( fHandle, fExposeEvent ) - ELSE - {$ENDIF} - fExposeEvent := gtk_signal_connect( GTK_OBJECT( fHandle ), 'expose_event', - @ expose_widget, @ Self ); -END; -{$ENDIF GTK} -{$ENDIF _X_} -{$IFDEF WIN_GDI} - -function WndProcEraseBkgnd( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var PaintStruct: TPaintStruct; - OldPaintDC: HDC; -begin - Result := FALSE; - if Msg.message = WM_ERASEBKGND then - begin - if Assigned( Sender.OnEraseBkgnd ) then - begin - OldPaintDC := Sender.fPaintDC; - Sender.fPaintDC := Msg.wParam; - if Sender.fPaintDC = 0 then - Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct ); - Sender.OnEraseBkgnd( Sender, Msg.wParam ); - if Msg.wParam = 0 then - EndPaint( Sender.fHandle, PaintStruct ); - if Assigned( Sender.fCanvas ) then - Sender.fCanvas.SetHandle( 0 ); - Sender.fPaintDC := OldPaintDC; - Rslt := 0; - Result := TRUE; - end - else - Rslt := 0; - end; -end; - -procedure TControl.SetOnEraseBkgnd(const Value: TOnPaint); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnEraseBkgnd := Value; - AttachProc( WndProcEraseBkgnd ); -end; - -procedure DummyPaintClear( Self_: PControl; Sender: PControl; DC: HDC ); -begin - Sender.Canvas.FillRect( Sender.ClientRect ); -end; - -{$IFDEF NEW_GRADIENT} -function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var PaintStruct: TPaintStruct; - Bmp: PBitmap; - CR: TRect; - I: Integer; - R, G, B: Integer; - R1, G1, B1: Integer; - C: TColor; - W, H, WH: Integer; - OldPaintDC: HDC; - Pattern: PBitmap; - pdc: HDC; - pw: integer; - -begin - case Msg.message of - WM_PAINT, WM_PRINTCLIENT: - begin - result := false; - CR := Self_.ClientRect; - case Self_.DF.fGradientStyle of - gsHorizontal: begin - W := CR.Right; - H := 1; - WH := W; - pw := 32; - end; - gsVertical: begin - W := 1; - H := CR.Bottom; - WH := H; - pw := 32 - end; - gsTopToBottom, - gsBottomToTop: begin - W := CR.Bottom + CR.Right; - H := 1; - WH := W; - pw := 1 + (CR.Bottom div 16); - if pw > 6 then - pw := 6; - end; - else exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // <-- impartant if user change GradientStyle to not supported by this object - end; - OldPaintDC := Self_.fPaintDC; - Self_.fPaintDC := Msg.wParam; - if Self_.fPaintDC = 0 then - Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct ); - Bmp := NewDIBBitmap( W, H, pf24bit ); - C := Color2RGB( Self_.DF.fColor1 ); - R := C shr 16; - G := (C shr 8) and $FF; - B := C and $FF; - C := Color2RGB( Self_.DF.fColor2 ); - R1 := C shr 16; - G1 := (C shr 8) and $FF; - B1 := C and $FF; - for I := 0 to WH-1 do begin - C := (( R + (R1 - R) * I div WH ) shl 16) or - (( G + (G1 - G) * I div WH ) shl 8) or - ( B + (B1 - B) * I div WH ); - if Self_.DF.fGradientStyle = gsVertical then - Bmp.DIBPixels[ 0, I ] := C - else - Bmp.DIBPixels[ I, 0 ] := C; - end; - if Self_.DF.fGradientStyle = gsVertical then - Pattern := NewBitMap(pw, H) - else - Pattern := NewBitMap(W, pw); - pdc := Pattern.Canvas.Handle; - SetStretchBltMode( pdc, HALFTONE); - SetBrushOrgEx( pdc, 0, 0, nil ); - StretchBlt( pdc, 0, 0, Pattern.Width, Pattern.Height, Bmp.Canvas.Handle, - 0, 0, W, H, SRCCOPY ); - - case Self_.DF.fGradientStyle of - gsHorizontal: for i := 0 to (CR.Bottom div pw) do - Pattern.Draw(Self_.fPaintDC, 0, i*pw); - gsVertical: for i := 0 to (CR.Right div pw) do - Pattern.Draw(Self_.fPaintDC, i*pw, 0); - gsTopToBottom: for i := 0 to ((CR.Bottom + pw -1) div pw)-1 do - Pattern.Draw(Self_.fPaintDC, -i*pw, i*pw); - gsBottomToTop: for i := 0 to ((CR.Bottom + pw -1) div pw)-1 do - Pattern.Draw(Self_.fPaintDC, -CR.Bottom + i*pw, i*pw); - end; - Bmp.Free; - Pattern.Free; - - if TMethod( Self_.EV.fOnPaint2 ).Code = @ DummyPaintClear then - {$IFDEF MAKE_METHOD} - Self_.EV.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyObjProc ) ); - {$ELSE} - TMethod( Self_.EV.fOnPaint2 ).Code := @DummyObjProc; - {$ENDIF} - if Assigned( Self_.EV.fOnPaint ) then - Self_.EV.fOnPaint( Self_, Self_.fPaintDC ); - - if Msg.wParam = 0 then - EndPaint( Self_.fHandle, PaintStruct ); - Self_.fPaintDC := OldPaintDC; - Rslt := 0; - Result := True; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := False; -end; -{$ELSE OLD_GRADIENT} -function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var PaintStruct: TPaintStruct; - Bmp: PBitmap; - CR: TRect; - I, R, G, B, R1, G1, B1, W, H, WH: Integer; - C: TColor; - W9x: Boolean; - Br: HBrush; - OldPaintDC: HDC; -begin - case Msg.message of - WM_PAINT, WM_PRINTCLIENT: - begin - OldPaintDC := Self_.fPaintDC; - Self_.fPaintDC := Msg.wParam; - if Self_.fPaintDC = 0 then - Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct ); - CR := Self_.ClientRect; - W9x := WinVer < wvNT; - W := 1; - H := CR.Bottom; - WH := H; - Bmp := nil; - if Self_.DF.fGradientStyle = gsHorizontal then - begin - W := CR.Right; - H := 1; - WH := W; - end; - if not W9x then - Bmp := NewDIBBitmap( W, H, pf32bit ); - C := Color2RGB( Self_.DF.fColor1 ); - R := C shr 16; - G := (C shr 8) and $FF; - B := C and $FF; - C := Color2RGB( Self_.DF.fColor2 ); - R1 := C shr 16; - G1 := (C shr 8) and $FF; - B1 := C and $FF; - for I := 0 to WH-1 do - begin - C := ((( R + (R1 - R) * I div WH ) and $FF) shl 16) or - ((( G + (G1 - G) * I div WH ) and $FF) shl 8) or - ( B + (B1 - B) * I div WH ) and $FF; - if W9x then - begin - if Self_.DF.fGradientStyle <> gsHorizontal then - CR.Bottom := CR.Top + 1 - else - CR.Right := CR.Left + 1; - Br := CreateSolidBrush( C ); - Windows.FillRect( Self_.fPaintDC, CR, Br ); - DeleteObject( Br ); - if Self_.DF.fGradientStyle <> gsHorizontal then - Inc( CR.Top ) - else - Inc( CR.Left ); - end - else - begin - if Self_.DF.fGradientStyle <> gsHorizontal then - Bmp.DIBPixels[ 0, I ] := C - else - Bmp.DIBPixels[ I, 0 ] := C; - end; - end; - if not W9x then - begin - SetStretchBltMode( Self_.fPaintDC, HALFTONE ); - SetBrushOrgEx( Self_.fPaintDC, 0, 0, nil ); - StretchBlt( Self_.fPaintDC, 0, 0, CR.Right, CR.Bottom, Bmp.Canvas.Handle, - 0, 0, W, H, SRCCOPY ); - Bmp.Free; - end; - - if TMethod( Self_.EV.fOnPaint2 ).Code = @ DummyPaintClear then - {$IFDEF MAKE_METHOD} - Self_.EV.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyObjProc ) ); - {$ELSE} - TMethod( Self_.EV.fOnPaint2 ).Code := @DummyObjProc; - {$ENDIF} - if Assigned( Self_.EV.fOnPaint ) then - Self_.EV.fOnPaint( Self_, Self_.fPaintDC ); - - if Msg.wParam = 0 then - EndPaint( Self_.fHandle, PaintStruct ); - Self_.fPaintDC := OldPaintDC; - Rslt := 0; - Result := True; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := False; -end; -{$ENDIF OLD_GRADIENT} - -function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; - function Ceil( X: Double ): Integer; - begin - Result := Round( X ) {+ 1}; - //if X > 0 then dec( Result ) else inc( Result ); - end; -const - SQRT2 = 1.4142135623730950488016887242097; -var - RC, R0: TRect; - C, C2: TColor; - R1, G1, B1: Integer; - R2, G2, B2: Integer; - DX1, DX2, DY1, DY2, DR, DG, DB, K: Double; - PaintStruct: TPaintStruct; - I: Integer; - Br: HBrush; - Rgn: HRgn; - Poly: array[ 0..3 ] of TPoint; - OldPaintDC: HDC; - fX1, fX2, fY1, fY2: Double; - - procedure OffsetF( DX, DY: Double ); - begin - fX1 := fX1 + DX; - fX2 := fX2 + DX; - fY1 := fY1 + DY; - fY2 := fY2 + DY; - end; -begin - Result := FALSE; - if (Msg.message <> WM_PAINT) and (Msg.message <> WM_PRINTCLIENT) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Self_.DF.fGradientStyle in [ gsHorizontal, gsVertical ] then - begin - Result := WndProcGradient( Self_, Msg, Rslt ); - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - C := Color2RGB( Self_.DF.fColor2 ); - R2 := C and $FF; - G2 := (C shr 8) and $FF; - B2 := (C shr 16) and $FF; - C := Color2RGB( Self_.DF.fColor1 ); - R1 := C and $FF; - G1 := (C shr 8) and $FF; - B1 := (C shr 16) and $FF; - DR := (R2 - R1) / 256; - DG := (G2 - G1) / 256; - DB := (B2 - B1) / 256; - OldPaintDC := Self_.fPaintDC; - Self_.fPaintDC := Msg.wParam; - if Self_.fPaintDC = 0 then - Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct ); - RC := Self_.ClientRect; - fX1 := 0; - fY1 := 0; - case Self_.DF.fGradientStyle of - gsRombic: - begin - fX2 := RC.Right / 128; - fY2 := RC.Bottom / 128; - end; - gsElliptic: - begin - fX2 := RC.Right / 256 * SQRT2; - fY2 := RC.Bottom / 256 * SQRT2; - end; - else - begin - fX2 := RC.Right / 256; - fY2 := RC.Bottom / 256; - end; - end; - case Self_.DF.fGradientStyle of - gsRectangle, gsRombic, gsElliptic: - begin - case Self_.DF.fGradientLayout of - glCenter, glTop, glBottom: - OffsetF( (RC.Right - fX2) / 2, 0 ); - glTopRight, glBottomRight, glRight: - OffsetF( RC.Right - fX2 / 2, 0 ); - glTopLeft, glBottomLeft, glLeft: - OffsetF( -fX2 / 2, 0 ); - end; - case Self_.DF.fGradientLayout of - glCenter, glLeft, glRight: - OffsetF( 0, (RC.Bottom - fY2) / 2 ); - glBottom, glBottomLeft, glBottomRight: - OffsetF( 0, RC.Bottom - fY2 / 2 ); - glTop, glTopLeft, glTopRight: - OffsetF( 0, -fY2 / 2 ) - end; - end; - end; - DX1 := -fX1 / 255; //(-RF.Left) / 255; - DY1 := -fY1 / 255; // (-RF.Top) / 255; - DX2 := (RC.Right - fX2) / 255; //(RC.Right - RF.Right) / 255; - DY2 := (RC.Bottom - fY2) / 255; - case Self_.DF.fGradientStyle of - gsRombic, gsElliptic: - begin - if DX2 < -DX1 then DX2 := -DX1; - if DY2 < -DY1 then DY2 := -DY1; - K := 2; - if Self_.DF.fGradientStyle = gsElliptic then K := SQRT2; - DX2 := DX2 * K; - DY2 := DY2 * K; - DX1 := -DX2; - DY1 := -DY2; - end; - end; - C2 := C; - for I := 0 to 255 do - begin - if (I < 255) then - begin - C2 := TColor( (( Ceil( B1 + DB * (I+1) ) and $FF) shl 16) or - (( Ceil( G1 + DG * (I+1) ) and $FF) shl 8) or - Ceil( R1 + DR * (I+1) ) and $FF ); - if (Self_.DF.fGradientStyle in [gsRombic,gsElliptic,gsRectangle]) and - (C2 = C) then continue; - end; - Br := CreateSolidBrush( C ); - R0 := MakeRect( Ceil( fX1 + DX1 * I ), - Ceil( fY1 + DY1 * I ), - Ceil( fX2 + DX2 * I ) + 1, - Ceil( fY2 + DY2 * I ) + 1 ); - Rgn := 0; - case Self_.DF.fGradientStyle of - gsRectangle: - Rgn := CreateRectRgnIndirect( R0 ); - gsRombic: - begin - Poly[ 0 ].x := R0.Left; - Poly[ 0 ].y := R0.Top + (R0.Bottom - R0.Top) div 2; - Poly[ 1 ].x := R0.Left + (R0.Right - R0.Left) div 2; - Poly[ 1 ].y := R0.Top; - Poly[ 2 ].x := R0.Right; - Poly[ 2 ].y := Poly[ 0 ].y; - Poly[ 3 ].x := Poly[ 1 ].x; - Poly[ 3 ].y := R0.Bottom; - Rgn := CreatePolygonRgn( Poly[ 0 ].x, 4, ALTERNATE ); - end; - gsElliptic: - Rgn := CreateEllipticRgnIndirect( R0 ); - end; - if Rgn <> 0 then - begin - if Rgn <> NULLREGION then - begin - Windows.FillRgn( Self_.fPaintDC, Rgn, Br ); - ExtSelectClipRgn( Self_.fPaintDC, Rgn, RGN_DIFF ); - end; - DeleteObject( Rgn ); - end; - DeleteObject( Br ); - C := C2; - end; - if TMethod( Self_.EV.fOnPaint2 ).Code = @ DummyPaintClear then - {$IFDEF MAKE_METHOD} - Self_.EV.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyObjProc ) ); - {$ELSE} - TMethod( Self_.EV.fOnPaint2 ).Code := @DummyObjProc; - {$ENDIF} - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnPaint ) then - {$ENDIF} - Self_.EV.fOnPaint( Self_, Self_.fPaintDC ); - if Self_.fPaintDC <> HDC( Msg.wParam ) then - EndPaint( Self_.fHandle, PaintStruct ); - Self_.fPaintDC := OldPaintDC; - Rslt := 0; - Result := True; -end; - -function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var - Sz: TSize; - P0: TPoint; - CR: TRect; - B : Boolean; - CShadow: TColor; - Target: PCanvas; - Txt: KOLString; - //LCaption: PKOLChar; - OldPaintDC: HDC; - - procedure doTextOut( shfx, shfy: Integer; col: TColor ); - begin - SetTextColor( Target.fHandle, col ); - {$IFDEF UNICODE_CTRLS} - Windows.ExtTextOutW( Target.fHandle, P0.x + shfx, P0.y + shfy, - ETO_CLIPPED, @CR, - PWideChar(Txt), Length(Txt), nil ); // KOL_ANSI - {$ELSE} - Windows.ExtTextOutA( Target.fHandle, P0.x + shfx, P0.y + shfy, - ETO_CLIPPED, @CR, - PAnsiChar(Txt), Length(Txt), nil ); // KOL_ANSI - {$ENDIF} - //GDIFlush; // for test only - end; - -var I, J, Istp : Integer; - PS: TPaintStruct; - //DoEndPaint: Boolean; -begin - Result := False; - case Msg.message of - WM_SETTEXT: - begin - Self_.fCaption := PKOLChar( Msg.lParam ); - Result := True; - Rslt := 1; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - WM_PRINTCLIENT, WM_PAINT: - begin - OldPaintDC := Self_.fPaintDC; - Self_.fPaintDC := Msg.wParam; - if Self_.fPaintDC = 0 then - Self_.fPaintDC := BeginPaint( Self_.fHandle, PS ); - begin - Target := Self_.Canvas; - Txt := Self_.fCaption; - Target.{$IFDEF UNICODE_CTRLS}WTextArea{$ELSE}TextArea{$ENDIF}( Txt, Sz, P0 ); - if Self_.DF.fShadowDeep <> 0 then - begin - for B := False to Self_.fCtl3D_child and 1 <> 0 do - begin - Inc( Sz.cx, Abs( Self_.DF.fShadowDeep ) ); - Inc( Sz.cy, Abs( Self_.DF.fShadowDeep ) ); - end; - end; - CR := Self_.ClientRect; - case Self_.fTextAlign of - taCenter: P0.x := P0.x + (CR.Right - Sz.cx) div 2; - taRight: P0.x := P0.x + (CR.Right - Sz.cx); - end; - case Self_.fVerticalAlign of - vaCenter: P0.y := P0.y + (CR.Bottom - Sz.cy) div 2; - vaBottom: P0.y := P0.y + (CR.Bottom - Sz.cy); - end; - if Self_.DF.fShadowDeep <> 0 then - begin - if Self_.DF.fColor2 = clNone then - CShadow := ColorsMix(Color2RGB(Self_.fTextColor),Color2RGB(Self_.DF.fColor2)) - else - CShadow := Color2RGB( Self_.DF.fColor2 ); - if {$IFDEF USE_FLAGS} not(G2_Transparent in Self_.fFlagsG2) - {$ELSE} not Self_.fTransparent {$ENDIF} then - Target.FillRect( CR ); // GDIFlush; for test only - Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - SetBkMode( Target.fHandle, Windows.TRANSPARENT ); - if Self_.fCtl3D_child and 1 <> 0 then - begin - I := - Self_.DF.fShadowDeep; - Istp := 1; - if Self_.DF.fShadowDeep > 0 then Istp := -1; - repeat - J := - Self_.DF.fShadowDeep; - repeat - if not ( (I=0) and (J=0) ) then - begin - if (I * Istp < 0) and (J * Istp < 0) then - doTextOut( I, J, CShadow ); - end; - J := J - Istp; - until J = Self_.DF.fShadowDeep - IStp; - I := I - Istp; - until I = Self_.DF.fShadowDeep - IStp; - end - else - doTextout( Self_.DF.fShadowDeep, Self_.DF.fShadowdeep, CShadow ); - doTextout( 0, 0, Color2RGB(Self_.fTextColor) ); - end - else - begin - Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas ); - SetBkMode( Target.fHandle, Windows.TRANSPARENT ); - doTextout( 0, 0, Color2RGB(Self_.fTextColor) ); - end; - end; - if Self_.fCanvas <> nil then - Self_.fCanvas.SetHandle( 0 ); - if Msg.wParam = 0 then - EndPaint( Self_.fHandle, PS ); - Self_.fPaintDC := OldPaintDC; - Rslt := 0; - Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.DoClick; -begin - PP.fControlClick( @Self ); - {$IFDEF NIL_EVENTS} - if Assigned( EV.fOnClick ) then - {$ENDIF} - EV.fOnClick( @Self ); -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.ParentForm: PControl; -begin - Result := @Self; - if {$IFDEF USE_FLAGS} G3_IsControl in Result.fFlagsG3 - {$ELSE} Result.fIsControl {$ENDIF} then - repeat - Result := Result.fParent; - until (Result = nil) or - {$IFDEF USE_FLAGS} not(G3_IsControl in Result.fFlagsG3) - {$ELSE} not Result.fIsControl {$ENDIF}; -end; -{$ENDIF PAS_VERSION} -{$IFDEF WIN_GDI} - -function TControl.FormParentForm: PControl; -begin - Result := @Self; - while ( {$IFDEF USE_FLAGS} G3_IsControl in Result.fFlagsG3 - {$ELSE} Result.fIsControl {$ENDIF} ) - and not( {$IFDEF USE_FLAGS} - [G5_IsButton, G5_IsBitBtn] * Result.fFlagsG5 = [G5_IsBitBtn] - {$ELSE} - Result.fIsBitBtn and not Result.fIsButton - {$ENDIF} ) do - Result := Result.fParent; -end; - -function TControl.MarkPanelAsForm: PControl; -begin - Result := @ Self; - {$IFDEF USE_FLAGS} - Include( fFlagsG5, G5_IsBitBtn ); - {$ELSE} - fIsBitBtn := TRUE; - {$ENDIF} -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetProgressColor(const Value: TColor); -begin - if Perform( PBM_SETBARCOLOR, 0, Color2RGB(Value) ) <> 0 then - fTextColor := Value; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.SetShadowDeep(const Value: Integer); -begin - DF.fShadowDeep := Value; - Invalidate; -end; -{$ENDIF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetFont: PGraphicTool; -begin - if FFont = nil then - begin - FFont := NewFont; - {$IFDEF USE_AUTOFREE4CONTROLS} - Add2AutoFree( FFont ); - {$ENDIF} - FFont.fData.Color := fTextColor; - FFont.OnChange := FontChanged; - end; - Result := FFont; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetBrush: PGraphicTool; -begin - if FBrush = nil then - begin - FBrush := NewBrush; - FBrush.fData.Color := fColor; - FBrush.OnChange := BrushChanged; - {$IFDEF USE_AUTOFREE4CONTROLS} - Add2AutoFree( FBrush ); - {$ENDIF} - end; - Result := FBrush; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN_GDI} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.FontChanged(Sender: PGraphicTool); -begin - fTextColor := Sender.fData.Color; - ApplyFont2Wnd_Proc(@Self); - Invalidate; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.BrushChanged(Sender: PGraphicTool); -begin - fColor := Sender.fData.Color; - if fTmpBrush <> 0 then - begin - DeleteObject( fTmpBrush ); - fTmpBrush := 0; - end; - if fPaintDC = 0 then - // only if not in painting already : - Invalidate; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure DoApplyFont2Wnd( _Self: PControl ); -begin - if _Self.fFont <> nil then - begin - if _Self.fHandle <> 0 then - begin - _Self.fTextColor := _Self.fFont.fData.Color; - _Self.Perform( WM_SETFONT, _Self.FFont.Handle, 1 ); - end; - - if _Self.fCanvas <> nil then - begin - _Self.fCanvas.Free; - _Self.fCanvas := nil; - end; - - _Self.DoAutoSize; - end; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE DoApplyFont2Wnd( _Self: PControl ); -VAR oldfontdesc: PPangoFontDescription; - rcstyle: PGtkRcStyle; - gcolor: TGdkColor; - i: Integer; -BEGIN - IF ( _Self.fFont <> nil ) THEN - BEGIN - gcolor := Color2GdkColor( _Self.fFont.Color ); - - rcstyle := gtk_widget_get_modifier_style( _Self.fHandle ); - oldfontdesc := rcstyle.font_desc; - rcstyle.font_desc := - pango_font_description_copy( _Self.fFont.GetPangoFontDesc ); - gtk_widget_modify_style( _Self.fHandle, rcstyle ); - - IF oldfontdesc <> nil THEN - pango_font_description_free( oldfontdesc ); - - FOR i := 0 TO 4 DO - gtk_widget_modify_fg( _Self.fCaptionHandle, {GTK_STATE_NORMAL} i, @ gcolor ); - END; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.ResizeParent: PControl; -begin - ResizeParentBottom; - ResizeParentRight; - // Once again, to fix Windows (or my???) bug with - // incorrect calculating of GetClientRect after - // SetWindowLong( GWL_[EX}STYLE,... ) - Result := ResizeParentBottom; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.ResizeParentBottom: PControl; -var NewCH: Integer; -begin - Result := @Self; - if fParent <> nil then - begin - NewCH := BoundsRect.Bottom + fParent.fMargin; - if {$IFDEF USE_FLAGS} G2_ChangedH in fParent.fFlagsG2 - {$ELSE} (fParent.fChangedPosSz and $20) <> 0 {$ENDIF} then - if NewCH <> fParent.ClientHeight then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>} - fParent.ClientHeight := NewCH; - {$IFDEF USE_FLAGS} include( fParent.fFlagsG2, G2_ChangedH ); - {$ELSE} fParent.fChangedPosSz := fParent.fChangedPosSz or $20; {$ENDIF} - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.ResizeParentRight: PControl; -var NewCW: Integer; -begin - Result := @Self; - if fParent <> nil then - begin - NewCW := fBoundsRect.Right + fParent.fMargin; - if {$IFDEF USE_FLAGS} G2_ChangedW in fParent.fFlagsG2 - {$ELSE} (fParent.fChangedPosSz and $10) <> 0 {$ENDIF} then - if NewCW < fParent.ClientWidth then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fParent.ClientWidth := NewCW; - {$IFDEF USE_FLAGS} include( fParent.fFlagsG2, G2_ChangedW ); - {$ELSE} fParent.fChangedPosSz := fParent.fChangedPosSz or $10; {$ENDIF} - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetClientHeight: Integer; -begin - with ClientRect do - Result := Bottom - Top; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetClientWidth: Integer; -begin - with ClientRect do - Result := Right - Left; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetClientHeight(const Value: Integer); -var Delta: Integer; -begin - Delta := ClientHeight; - Delta := Height - Delta; - Height := Value + Delta; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetClientWidth(const Value: Integer); -var Delta: Integer; -begin - Delta := ClientWidth; - Delta := Width - Delta; - Width := Value + Delta; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.CenterOnParent: PControl; -var PCR: TRect; -begin - Result := @Self; - if (fParent = nil) or - {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3) - {$ELSE} not fIsControl {$ENDIF} then - PCR := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) ) - else - PCR := fParent.ClientRect; - GetWindowHandle; - Left := (PCR.Right - PCR.Left - Width) div 2; - Top := (PCR.Bottom - PCR.Top - Height) div 2; -end; -{$ENDIF PAS_VERSION} - -function TControl.CenterOnForm( Form1: PControl ): PControl; -var PCR, DR: TRect; -begin - Result := @Self; - if (Form1 = nil) then - PCR := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) ) - else - PCR := Form1.BoundsRect; - GetWindowHandle; - Left := PCR.Left + (PCR.Right - PCR.Left - Width) div 2; - Top := PCR.Top + (PCR.Bottom - PCR.Top - Height) div 2; - PCR := BoundsRect; - DR := GetDesktopRect; - if PCR.Right > DR.Right then - OffsetRect( PCR, DR.Right - PCR.Right, 0 ); - if PCR.Bottom > DR.Bottom then - OffsetRect( PCR, 0, DR.Bottom - PCR.Bottom ); - if PCR.Left < DR.Left then - OffsetRect( PCR, DR.Left - PCR.Left, 0 ); - if PCR.Top < DR.Top then - OffsetRect( PCR, 0, DR.Top - PCR.Top ); - BoundsRect := PCR; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetHasBorder: Boolean; -begin - UpdateWndStyles; - Result := LongBool( fStyle.Value and (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME)) - or LongBool( fExStyle and WS_EX_CLIENTEDGE ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_noVERSION} // YS -procedure TControl.SetHasBorder(const Value: Boolean); -const style_mask = WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION - or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU; - exstyle_mask = not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME - or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE); -asm - - PUSH EAX - PUSH EDX - - CALL GetHasBorder - POP ECX - CMP AL, CL - - POP EAX - JZ @@exit - - MOV EDX, [EAX].fStyle - DEC CL - MOVZX ECX, [EAX].fIsControl - JNZ @@1 - - OR EDX, WS_THICKFRAME - INC ECX - LOOP @@set_style - OR EDX, style_mask - JMP @@set_style - -@@1: AND EDX, not style_mask - INC ECX - LOOP @@2 - OR EDX, WS_POPUP - -@@2: PUSH EDX - - MOV EDX, [EAX].fExStyle - AND EDX, exstyle_mask - - PUSH EAX - CALL SetExStyle - POP EAX - - POP EDX -@@set_style: - TEST [EAX].fTabStop, 1 - JZ @@no_tabstop - OR DX, WS_TABSTOP - JMP @@set_style_1 -@@no_tabstop: - AND DX, not WS_TABSTOP -@@set_style_1: - CALL SetStyle -@@exit: -end; -{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetHasBorder(const Value: Boolean); -var NewStyle: DWORD; -begin - if Value = GetHasBorder then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Value then - begin - if {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3) - {$ELSE} not fIsControl {$ENDIF} then - Style := fStyle.Value or WS_THICKFRAME or WS_BORDER or - WS_DLGFRAME or WS_CAPTION or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or - WS_SYSMENU - else - if fCtl3D_child and 1 <> 0 then - ExStyle := fExStyle or WS_EX_CLIENTEDGE - else - Style := fStyle.Value or WS_BORDER; - end - else - begin - NewStyle := fStyle.Value and not (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION - or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU); - if {$IFDEF USE_FLAGS} not(G3_IsControl in fFlagsG3) - {$ELSE} not fIsControl {$ENDIF} then - NewStyle := NewStyle or WS_POPUP; - Style := NewStyle; - ExStyle := fExStyle and not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME - or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE); - end; - {$IFDEF USE_FLAGS} - {$ELSE} //+MTsv DN - if fIsControl then - if fTabStop then - Style := fStyle.Value or WS_TABSTOP - else Style := fStyle.Value {xor} and not WS_TABSTOP; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetHasCaption: Boolean; -begin - UpdateWndStyles; - Result := not LongBool( fStyle.Value and (WS_POPUP or WS_DLGFRAME)) - or LongBool( fStyle.Value and WS_CAPTION); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetHasCaption(const Value: Boolean); -begin - if Value = GetHasCaption then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Value then - begin - Style := fStyle.Value and not (WS_POPUP or WS_DLGFRAME) or WS_CAPTION; - end - else - begin - if {$IFDEF USE_FLAGS} G3_IsControl in fFlagsG3 - {$ELSE} fIsControl {$ENDIF} then - Style := fStyle.Value and not WS_CAPTION or WS_DLGFRAME - else - Style := fStyle.Value and not (WS_CAPTION or WS_SYSMENU) or WS_POPUP; - ExStyle := fExStyle or WS_EX_DLGMODALFRAME; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetCanResize: Boolean; -begin - {$IFDEF USE_FLAGS} - Result := not(G1_PreventResize in fFlagsG1); - {$ELSE} - Result := not fPreventResize; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -function WndProcCanResize( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean; -var W, H: Integer; - P: PMinMaxInfo; -begin - if not Sender.CanResize then - if M.message = WM_GETMINMAXINFO then - begin - Rslt := Sender.CallDefWndProc( M ); - {$IFDEF FIX_WIDTH_HEIGHT} - W := Sender.FFixWidth; - H := Sender.FFixHeight; - {$ELSE} - W := Sender.fBoundsRect.Right - Sender.fBoundsRect.Left; - H := Sender.fBoundsRect.Bottom - Sender.fBoundsRect.Top; - {$ENDIF} - P := Pointer( M.lParam ); - P.ptMinTrackSize.x := W; - P.ptMinTrackSize.y := H; - P.ptMaxTrackSize := P.ptMinTrackSize; - Result := True; // stop further processing (prevent resizing) - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end - else - if M.message = WM_NCHITTEST then - begin - Rslt := Sender.CallDefWndProc( M ); - if (Rslt >= 10) and (Rslt <= 17) then - begin - {$IFDEF CANRESIZE_THICKFRAME} - Rslt := HTBORDER; - {$ELSE} - Rslt := HTNOWHERE; - {$ENDIF} - Result := True; - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end else - if M.message = WM_INITMENU then - begin - if not Sender.CanResize then - EnableMenuItem( GetSystemMenu( Sender.fHandle, FALSE ), - SC_SIZE, MF_GRAYED ); - end; - Result := False; // continue message processing -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetCanResize( const Value: Boolean ); -begin - if Value = CanResize then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF USE_FLAGS} - if Value then exclude( fFlagsG1, G1_PreventResize ) - else include( fFlagsG1, G1_PreventResize ); - {$ELSE} - fPreventResize := not Value; - {$ENDIF} - {$IFDEF CANRESIZE_THICKFRAME} - if Value then - Style := Style or WS_THICKFRAME - else - Style := Style and not WS_THICKFRAME; - {$ENDIF} - {$IFDEF FIX_WIDTH_HEIGHT} - GetWindowHandle; - FFixWidth := Width; - FFixHeight := Height; - {$ENDIF FIX_WIDTH_HEIGHT} - AttachProc( WndProcCanResize ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetStayOnTop: Boolean; -begin - UpdateWndStyles; - Result := LongBool( fExStyle and WS_EX_TOPMOST); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetStayOnTop(const Value: Boolean); -begin - if Value = GetStayOnTop then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fHandle <> 0 then - if Value then - SetWindowPos( fHandle, HWND_TOPMOST, 0,0,0,0, - SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE ) - else - SetWindowPos( fHandle, HWND_NOTOPMOST, 0,0,0,0, - SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE ) - else - if Value then fExStyle := fExStyle or WS_EX_TOPMOST - else fExStyle := fExStyle and not WS_EX_TOPMOST; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.UpdateWndStyles: PControl; -begin - Result := @Self; - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fStyle.Value := GetWindowLong( fHandle, GWL_STYLE ); - fExStyle := GetWindowLong( fHandle, GWL_EXSTYLE ); - fClsStyle := GetClassLong( fHandle, GCL_STYLE ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetChecked: Boolean; -begin - if bboFixed in DF.fBitBtnOptions then - Result := {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4 - {$ELSE} fChecked {$ENDIF} - else - Result := LongBool( Perform( BM_GETCHECK, 0, 0 ) ) ; //= BST_CHECKED; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.Set_Checked(const Value: Boolean); -begin - if bboFixed in DF.fBitBtnOptions then - begin - {$IFDEF USE_FLAGS} include( fFlagsG4, G4_Checked ); - {$ELSE} fChecked := Value; {$ENDIF} - Invalidate; - end - else - Perform( BM_SETCHECK, Integer( Value ), 0 ); -end; -{$ENDIF PAS_VERSION} - -function TControl.SetChecked(const Value: Boolean): PControl; -begin - Perform( BM_SETCHECK, Integer( Value ), 0 ); - Result := @Self; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function TControl.SetRadioChecked: PControl; -{$IFDEF USE_FLAGS} -var WasStyle: DWORD; -{$ELSE} -var WasTabStop: Boolean; -{$ENDIF} -begin - {$IFDEF USE_FLAGS} - WasStyle := fStyle.Value; - exclude( fStyle.f2_Style, F2_Tabstop ); - DoClick; - fStyle.Value := WasStyle; - {$ELSE} - WasTabStop := fTabStop; - fTabStop := FALSE; - DoClick; - fTabStop := WasTabStop; - {$ENDIF} - Result := @Self; -end; -{$ENDIF PAS_VERSION} - -function TControl.GetCheck3: TTriStateCheck; -begin - Result := TTriStateCheck(Perform(BM_GETCHECK, 0, 0) and 3); -end; - -procedure TControl.SetCheck3(value: TTriStateCheck); -var - wp: WPARAM; -begin - wp := Perform(BM_GETCHECK, 0, 0) and not 3; - wp := wp or byte(value); - Perform(BM_SETCHECK, wp, 0); -end; - -procedure TControl.Click; -begin - if (fCommandActions.aClick <> 0) or - (fCommandActions.aEnter = BN_SETFOCUS) then - Perform( WM_COMMAND, (fCommandActions.aClick shl 16) or fMenu, - GetWindowHandle ) - else - begin - Perform( WM_LBUTTONDOWN, MK_LBUTTON, 0 ); - Perform( WM_LBUTTONUP, MK_LBUTTON, 0 ); - end; -end; - -type - TCharRange = record - cpMin: Longint; - cpMax: LongInt; - end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetSelStart: Integer; -begin - Result := 0; - if fCommandActions.aGetSelRange <> 0 then - Perform( fCommandActions.aGetSelRange, Integer( @ Result ), 0 ); -end; -{$ENDIF PAS_VERSION} - -procedure TControl.SetSelStart(const Value: Integer); -begin - ItemSelected[ Value ] := True; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetSelLength: Integer; -var Start, Finish: Integer; -begin - Result := 0; - if fCommandActions.aGetSelCount <> 0 then - begin - if fCommandActions.aGetSelCount = EM_GETSEL then - begin - Perform( fCommandActions.aGetSelCount, Integer( @ Start ), Integer( @ Finish ) ); - Result := Finish - Start; - end - else - begin - Result := Perform( fCommandActions.aGetSelCount {and $7FFF}, 0, 0 ); - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetSelLength(const Value: Integer); -var SR: TCharRange; -begin - SR.cpMin := GetSelStart; - SR.cpMax := SR.cpMin + Value; - if Value < 0 then - SR.cpMax := -1; - if fCommandActions.aSetSelRange <> 0 then - Perform( fCommandActions.aSetSelRange, SR.cpMin, SR.cpMax ) - else - if fCommandActions.aExSetSelRange <> 0 then - Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TControl.GetItems(Idx: Integer): KOLString; -var L, Pos: Integer; - Buf: PKOLChar; -begin - Result := ''; - Pos := Item2Pos( Idx ); - Idx := Pos2Item( Pos ); - if fCommandActions.aGetItemLength <> 0 then - L := Perform( fCommandActions.aGetItemLength, Pos, 0 ) - else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if L = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - GetMem( Buf, (L + 4) * SizeOf( KOLChar ) ); - PDWORD( Buf )^ := L + 1; - if fCommandActions.aGetItemText <> 0 then - Perform( fCommandActions.aGetItemText, Idx, Integer( Buf ) ); - Buf[ L ] := #0; - Result := Buf; - FreeMem( Buf ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetItems(Idx: Integer; const Value: KOLString); -var Strt, L : DWORD; - {$IFNDEF NOT_FIX_CURINDEX} - TmpCurIdx: Integer; // AK - Andrzey Kubasek - TmpData: DWORD; - {$ENDIF NOT_FIX_CURINDEX} -begin - if fCommandActions.aSetItemText <> 0 then - begin - Strt := Item2Pos( Idx ); - L := Item2Pos( Idx + 1 ) - Strt; - SelStart := Strt; - SelLength := L; - Perform( fCommandActions.aSetItemText, 0, Integer( PKOLChar( Value ) ) ); - end - else - if fCommandActions.aDeleteItem <> 0 then - begin - {$IFNDEF NOT_FIX_CURINDEX} - TmpCurIdx := CurIndex; // +AK - TmpData := ItemData[ Idx ]; - {$ENDIF} - Delete( Idx ); - Insert( Idx, Value ); - {$IFNDEF NOT_FIX_CURINDEX} - CurIndex := TmpCurIdx; //+AK - ItemData[ Idx ] := TmpData; - {$ENDIF} - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetItemsCount: Integer; -begin - Result := 0; - {$IFDEF DEBUG_ANY} - try - if fCommandActions.aGetCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Perform( fCommandActions.aGetCount, 0, 0 ); - except - asm - int 3 - end; - end; - {$ELSE} - if fCommandActions.aGetCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Perform( fCommandActions.aGetCount, 0, 0 ); - {$ENDIF DEBUG_ANY} -end; -{$ENDIF PAS_VERSION} - -procedure TControl.SetItemsCount(const Value: Integer); -begin - if fCommandActions.aSetCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Perform( fCommandActions.aSetCount, Value, 0 ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.Item2Pos(ItemIdx: Integer): DWORD; -begin - Result := ItemIdx; - if Byte( fCommandActions.bItem2Pos ) <> 0 then - Result := Perform( fCommandActions.bItem2Pos, ItemIdx, 0 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.Pos2Item(Pos: Integer): DWORD; -begin - Result := Pos; - if Byte( fCommandActions.bPos2Item ) <> 0 then - Result := Perform( fCommandActions.bPos2Item, Pos, 0 ); -end; -{$ENDIF PAS_VERSION} - -function TControl.SavePosition: TEditPositions; -var {$IFNDEF NOT_USE_RICHEDIT} - p: TPoint; - {$ENDIF USE_RICHEDIT} - i: Integer; -begin - Result.SelStart := SelStart; - Result.SelLength := SelLength; - {$IFNDEF NOT_USE_RICHEDIT} - if {$IFDEF USE_FLAGS} (G1_CanNotDoublebuf in fFlagsG1) - {$ELSE} fCannotDoubleBuf {$ENDIF} - { TRUE for rich edit, FALSE for edit } then - begin - P.X := 0; - P.Y := 0; - i := Perform( EM_CHARFROMPOS, 0, Integer( @ P ) ); - Result.TopLine := Pos2Item( i ); - Result.TopColumn := i - Integer( Item2Pos( Result.TopLine ) ); - Perform( EM_GETSCROLLPOS, 0, Integer( @ Result.ScrollPos ) ); - end - else - {$ENDIF USE_RICHEDIT} - begin - i := 0; - i := Perform( EM_CHARFROMPOS, 0, i ); - Result.TopLine := HiWord( i ); - Result.TopColumn := LoWord( i ) - Item2Pos( Result.TopLine ); - Result.ScrollPos.Y := GetScrollPos( Handle, SB_VERT ); - Result.ScrollPos.X := GetScrollPos( Handle, SB_HORZ ); - end; - Result.RestoreScroll := TRUE; -end; - -procedure TControl.RestorePosition( const P: TEditPositions ); -var Cur: TEditPositions; -begin - SelStart := P.SelStart; - SelLength := P.SelLength; - if P.RestoreScroll then - begin - Perform( EM_SCROLLCARET, 0, 0 ); - Cur := SavePosition; - {$IFNDEF NOT_USE_RICHEDIT} - if {$IFDEF USE_FLAGS} (G1_CanNotDoublebuf in fFlagsG1) - {$ELSE} fCannotDoubleBuf {$ENDIF} then - begin // RichEdit - if P.TopLine <> Cur.TopLine then - Perform( EM_LINESCROLL, 0, P.TopLine - Cur.TopLine ); - Perform( EM_SETSCROLLPOS, 0, Integer( @ P.ScrollPos ) ); - end else // Edit - {$ENDIF USE_RICHEDIT} - begin - if (P.TopLine <> Cur.TopLine) or - (P.TopColumn <> Cur.TopColumn) then - Perform( EM_LINESCROLL, P.TopColumn - Cur.TopColumn, - P.TopLine - Cur.TopLine ); - SetScrollPos( Handle, SB_VERT, P.ScrollPos.Y, TRUE ); - SetScrollPos( Handle, SB_HORZ, P.ScrollPos.X, TRUE ); - end; - end; -end; - -procedure TControl.UpdatePosition( var p: TEditPositions; FromPos, - CountInsertDelChars, CountInsertDelLines: Integer ); -var d: Integer; -begin - if (FromPos <= p.SelStart) and (CountInsertDelChars >= 0) or - (CountInsertDelChars < 0) and - ((FromPos + Abs( CountInsertDelChars ) <= p.SelStart) - ) then - begin - p.SelStart := p.SelStart + CountInsertDelChars; - end else - if FromPos >= p.SelStart + p.SelLength then - begin - // nothing to do - end else - if CountInsertDelChars < 0 then // deleting - begin - if FromPos - CountInsertDelChars > p.SelStart + p.SelLength then - CountInsertDelChars := -( p.SelStart + p.SelLength - FromPos ); - if FromPos - CountInsertDelChars >= p.SelStart then - begin - d := FromPos - CountInsertDelChars - p.SelStart; - p.SelLength := p.SelLength - d; - //inc( CountInsertDelChars, d ); - end; - inc( p.SelStart, CountInsertDelChars ); - end else // inserting - begin - if (FromPos > p.SelStart) and (FromPos < p.SelStart + p.SelLength) then - inc( p.SelLength, CountInsertDelChars ) - else - if FromPos <= p.SelStart then - inc( p.SelStart, CountInsertDelChars ); - end; - p.TopLine := p.TopLine + CountInsertDelLines; -end; - -function WndProcTabChar( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean; -begin - if M.message = WM_CHAR then - begin - if M.wParam = 9 then - Sender.ReplaceSelection( #9, TRUE ); - end; - Result := FALSE; -end; - -function TControl.EditTabChar: PControl; -begin - AttachProc( WndProcTabChar ); - Result := @Self; -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TControl.Add(const S: KOLString): Integer; -begin - if fCommandActions.aAddItem <> 0 then - begin - Result := Perform( fCommandActions.aAddItem, 0, Integer( PKOLChar( S ) ) ); - if Count = 1 then - ItemSelected[ 0 ] := True; - end - else - begin - if Assigned( fCommandActions.aAddText ) then - fCommandActions.aAddText( @Self, S ) - else - Text := Text + S; - Result := 0; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.Delete(Idx: Integer); -begin - if fCommandActions.aDeleteItem <> 0 then - Perform( fCommandActions.aDeleteItem, Idx, 0 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TControl.Insert(Idx: Integer; const S: KOLString): Integer; -begin - if fCommandActions.aInsertItem <> 0 then - Result := Perform( fCommandActions.aInsertItem, Idx, Integer( PKOLChar( S ) ) ) - else - Result := -1; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetItemSelected(ItemIdx: Integer): Boolean; -var SS: Integer; -begin - if fCommandActions.aGetSelected <> 0 then - begin - SS := Perform( fCommandActions.aGetSelected, ItemIdx, LVIS_SELECTED ); - { Though it is written in docs that for combobox lParam for CB_GETCURSEL - is not used and _must_ be 0, therefore this code is working for - combobox too. } - if fCommandActions.aGetSelected <> CB_GETCURSEL then - ItemIdx := 1; - Result := SS = ItemIdx; - end - else - begin - SS := SelStart; - Result := (ItemIdx >= SS) and (ItemIdx < SS + SelLength); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetItemSelected(ItemIdx: Integer; const Value: Boolean); -var SR: TCharRange; -begin - if fCommandActions.aSetSelected <> 0 then - Perform( fCommandActions.aSetSelected, Integer( Value ), ItemIdx ) - else - if fCommandActions.aSetCurrent <> 0 then - Perform( fCommandActions.aSetCurrent, ItemIdx, 0 ) - else - if fCommandActions.aSetSelRange <> 0 then - Perform( fCommandActions.aSetSelRange, ItemIdx, ItemIdx ) - else - if fCommandActions.aExSetSelRange <> 0 then - begin - SR.cpMin := ItemIdx; - SR.cpMax := ItemIdx; - Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) ); - end - else - begin // for ImageShow: set the index and invalidate the control - FCurIndex := ItemIdx; - Invalidate; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetCtl3D(const Value: Boolean); -begin - fCtl3D_child := fCtl3D_child and not 1 or Integer( Value ) and 1; - UpdateWndStyles; - if Value then - begin - Style := fStyle.Value and not WS_BORDER; - ExStyle := fExStyle or WS_EX_CLIENTEDGE; - end else - begin - Style := fStyle.Value or WS_BORDER; - ExStyle := fExStyle and not WS_EX_CLIENTEDGE; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.Shift(dX, dY: Integer): PControl; -begin - Left := fBoundsRect.Left + dX; - Top := fBoundsRect.Top + dY; - Result := @Self; -end; -{$ENDIF PAS_VERSION} - -procedure SetKeyEvent( Self_: PControl ); -begin - Self_.PP.fWndProcKeybd := WndProcKeybd; -end; - -procedure TControl.SetOnChar(const Value: TOnChar); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnChar := Value; - SetKeyEvent( @Self ); -end; - -{$IFDEF SUPPORT_ONDEADCHAR} -procedure TControl.SetOnDeadChar(const Value: TOnChar); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnDeadChar := Value; - SetKeyEvent( @Self ); -end; -{$ENDIF SUPPORT_ONDEADCHAR} - -procedure TControl.SetOnKeyDown(const Value: TOnKey); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnKeyDown := Value; - SetKeyEvent( @Self ); -end; - -procedure TControl.SetOnKeyUp(const Value: TOnKey); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnKeyUp := Value; - SetKeyEvent( @Self ); -end; - -{$IFDEF ASM_TLIST} -function CollectTabControls( Form: PControl ): PList; -asm - PUSH EDI - PUSH EAX - CALL NewList - XCHG EDI, EAX - POP EAX - CALL @@collecttab - XCHG EAX, EDI - POP EDI - RET -@@collecttab: - { <- EDI = Result:PList - EAX = Form (or Control) - } - PUSH EBP - XOR EBP, EBP // Result := FALSE; - PUSH ESI - PUSH EBX - MOV EDX, [EAX].TControl.fChildren - MOV ECX, [EDX].TList.fCount - MOV ESI, [EDX].TList.fItems - JECXZ @@e_loop -@@loo: PUSH ECX - LODSD - - PUSH EAX - - TEST byte ptr [EAX].TControl.fStyle+2, WS_TABSTOP shr 16 - JZ @@call_recur - - {$IFDEF USE_FLAGS} - MOV EDX, dword ptr [EAX].TControl.fStyle.f2_Style - OR DL, DH - AND DL, (1 shl F3_Disabled) or (1 shl F2_Tabstop) - CMP DL, (1 shl F2_Tabstop) - JNZ @@call_recur - {$ELSE} - MOV DL, [EAX].TControl.fTabStop - AND DL, [EAX].TControl.fEnabled - JZ @@call_recur - {$ENDIF} - - CALL TControl.GetToBeVisible - TEST AL, AL - POP EAX - JZ @@next - PUSH EAX - - XCHG EDX, EAX - PUSH ESI - MOV ECX, [EDI].TList.fCount - MOV ESI, [EDI].TList.fItems - XOR EBX, EBX - JECXZ @@e_loo2 -@@loo2: LODSD - MOV AX, [EAX].TControl.fTabOrder - CMP AX, [EDX].TControl.fTabOrder - JLE @@next2 - POP ESI - MOV ECX, EDX - MOV EDX, EBX - MOV EAX, EDI - CALL TList.Insert - JMP @@call_recur - -@@next2: INC EBX - LOOP @@loo2 -@@e_loo2: - POP ESI - MOV EAX, EDI - CALL TList.Add - -@@call_recur: - //OR EBP, 1 // Result := TRUE; - INC EBP - POP EAX - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fStyle.f3_Style, (1 shl F3_Disabled) - JNZ @@next - {$ELSE} - MOVZX ECX, [EAX].TControl.fEnabled - JECXZ @@next - {$ENDIF USE_FLAGS} - PUSH EAX - CALL @@collecttab - POP EDX - JZ @@next - - MOV EAX, EDI - CALL TList.Remove - -@@next: POP ECX - LOOP @@loo - -@@e_loop: - POP EBX - POP ESI - TEST EBP, EBP - POP EBP -end; -{$ELSE PAS_VERSION} //Pascal -function CollectTabControls( Form: PControl ): PList; -var R: PList; - function CollectTab( P: PControl ): Boolean; - var I, J: Integer; - C, D: PControl; - begin - Result := FALSE; - for I := 0 to P.fChildren.fCount - 1 do - begin - C := P.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - if {$IFDEF USE_FLAGS} (TRUE) - {$ELSE} C.fTabstop {$ENDIF} - and {$IFDEF USE_FLAGS} not(F3_Disabled in C.fStyle.f3_Style) - {$ELSE} C.fEnabled {$ENDIF} - and C.ToBeVisible and - (F2_Tabstop in C.fStyle.f2_Style) then - begin - D := nil; - for J := 0 to R.fCount - 1 do - begin - D := R.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ J ]; - if D.fTabOrder > C.fTabOrder then - begin - Result := TRUE; - R.Insert( J, C ); - break; - end - else - D := nil; - end; - if D = nil then - begin - R.Add( C ); - Result := TRUE; - end; - end; - if {$IFDEF USE_FLAGS} not (F3_Disabled in C.fStyle.f3_Style) - {$ELSE} C.fEnabled {$ENDIF} then - begin - if CollectTab( C ) then - R.Remove( C ); - end; - end; - end; - {$IFDEF DEBUG_COLLECTTABCONTROLS} - var SL: PStrList; - i: Integer; - C: PControl; - {$ENDIF} -begin - R := NewList; - CollectTab( Form ); - {$IFDEF DEBUG_COLLECTTABCONTROLS} - SL := NewStrList; - for i := 0 to R.Count-1 do - begin - C := R.Items[ i ]; - SL.Add( Int2Str( C.fTabOrder ) + ' ' + Int2Str( C.fTag ) + ' ' + C.fCaption ); - end; - SL.SaveToFile( GetStartDir + 'debug_collecttabcontrols.txt' ); - SL.Free; - {$ENDIF} - - Result := R; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -procedure Tabulate2Next( Form: PControl; Dir: Integer ); -asm - PUSHAD - PUSH EAX // save Form - MOV EBX, EAX - MOV EBP, EDX // EBP = Dir (direction <0 or >0) - CALL CollectTabControls - XCHG EDI, EAX // EDI = CL (list of controls) - - MOV ECX, [EBX].TControl.DF.fCurrentControl // C := Form.fCurrentControl - XOR EBX, EBX // I = 0 - JECXZ @@1 - MOV BX, [ECX].TControl.fTabOrder // I = C.fTabOrder -@@1: - MOV ECX, [EDI].TList.fCount - MOV ESI, [EDI].TList.fItems - XOR EDX, EDX - PUSH EDX // Ctrl1 = nil - PUSH EDX // Ctrl2 = nil - TEST ECX, ECX - JZ @@e_loop - -@@loop: PUSH ECX - LODSD - CMP [EAX].TControl.fTabOrder, BX - JZ @@next - - MOV ECX, [ESP+8] // ECX = Ctrl1 - JECXZ @@c1nil - MOV CX, [ECX].TControl.fTabOrder // ECX = Ctrl1.fTabOrder - TEST EBP, EBP - JGE @@c1ge - - CMP [EAX].TControl.fTabOrder, BX - JGE @@2 - CMP [EAX].TControl.fTabOrder, CX - JLE @@2 - -@@c1new: - MOV [ESP+8], EAX // Ctrl1 := C - JMP @@2 - -@@c1ge: CMP [EAX].TControl.fTabOrder, BX - JLE @@2 - CMP [EAX].TControl.fTabOrder, CX - JL @@c1new - JMP @@2 - -@@c1nil: - TEST EBP, EBP - JL @@c1nil_dirL - CMP [EAX].TControl.fTabOrder, BX - JG @@c1new - JMP @@2 - -@@c1nil_dirL: - CMP [EAX].TControl.fTabOrder, BX - JL @@c1new - -@@2: - MOV ECX, [ESP+4] // ECX = Ctrl2 - JECXZ @@c2new - MOV CX, [ECX].TControl.fTabOrder - - TEST EBP, EBP - JL @@c2dirL - CMP [EAX].TControl.fTabOrder, CX - JGE @@next - JMP @@c2new - -@@c2dirL: - CMP [EAX].TControl.fTabOrder, CX - JLE @@next -@@c2new: - MOV [ESP+4], EAX - -@@next: POP ECX - DEC ECX - JNZ @@loop - //LOOP @@loop -@@e_loop: - - POP EDX // Ctrl2 - POP ECX // Ctrl1 - INC ECX - LOOP @@3 - MOV ECX, EDX -@@3: - POP EBX // EBX = Form - JECXZ @@exit - - XCHG EAX, ECX - {$IFDEF USE_GRAPHCTLS} - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fFlagsG6, 1 shl G6_GraphicCtl - JNZ @@4 - {$ELSE} - CMP [EAX].TControl.fWindowed, 0 - JZ @@4 - {$ENDIF} - {$ENDIF} - MOV ECX, [EAX].TControl.fHandle - JECXZ @@no_handle -@@4: - INC [EAX].TControl.fClickDisabled - - PUSH EAX - MOV DL, 1 - CALL TControl.SetFocused - POP EAX - - DEC [EAX].TControl.fClickDisabled - -@@no_handle: - MOV [EBX].TControl.DF.fCurrentControl, EAX - -@@exit: - XCHG EAX, EDI - CALL TObj.RefDec - POPAD -end; -{$ELSE PAS_VERSION} //Pascal -procedure Tabulate2Next( Form: PControl; Dir: Integer ); -var CL : PList; - I, J : Integer; - Ctrl1, Ctrl2, C : PControl; -begin - CL := CollectTabControls( Form ); - - I := 0; - C := Form.DF.fCurrentControl; - if C <> nil then - I := C.fTabOrder; - Ctrl2 := nil; - Ctrl1 := nil; - for J := 0 to CL.fCount - 1 do - begin - C := CL.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ J ]; - if C.fTabOrder = I then continue; - if (Ctrl1 = nil) - and ( (Dir >= 0) and (C.fTabOrder > I) - or (Dir < 0) and (C.fTabOrder < I) ) - or (Dir >= 0) - and (C.fTabOrder > I) and (C.fTabOrder < Ctrl1.fTabOrder) - or (Dir < 0) - and (C.fTabOrder < I) and (C.fTabOrder > Ctrl1.fTabOrder) - then Ctrl1 := C; - if (Ctrl2 = nil) - or (Dir >= 0) and (C.fTabOrder < Ctrl2.fTabOrder) - or (Dir < 0) and (C.fTabOrder > Ctrl2.fTabOrder) - then Ctrl2 := C; - end; - if Ctrl1 = nil then - Ctrl1 := Ctrl2; - if Ctrl1 <> nil then - begin - if (Ctrl1.fHandle <> 0) {$IFDEF USE_GRAPHCTLS} or - {$IFDEF USE_FLAGS} (G6_GraphicCtl in Ctrl1.fFlagsG6) - {$ELSE} not Ctrl1.fWindowed {$ENDIF} {$ENDIF} then - begin - Inc( Ctrl1.fClickDisabled ); - Ctrl1.Focused := TRUE; - Dec( Ctrl1.fClickDisabled ); - end; - Form.DF.fCurrentControl := Ctrl1; - end; - CL.Free; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean; -var Form: PControl; -begin - Result := False; - case Key of - VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit; {>>>>>>>>>>>>>>>>>>>>} - VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit; {>>>} - VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit; {>>>>>>>>>} - VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := True; - if checkOnly then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Form := Self_.ParentForm; - case Key of - VK_TAB: - if GetKeyState( VK_SHIFT ) < 0 then - Tabulate2Next( Form, -1 ) - else - Tabulate2Next( Form, 1 ); - VK_RIGHT, VK_DOWN, VK_NEXT: Tabulate2Next( Form, 1 ); - VK_LEFT, VK_UP, VK_PRIOR: Tabulate2Next( Form, -1 ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean; -asm - PUSH EDI - MOVZX EDI, CL - TEST byte ptr [EAX].TControl.fLookTabKeys, 1 - JZ @@1 -@@0: - MOV ECX, EDX - AND CL, 7Fh - CMP CL, VK_TAB - JNE @@1 - - PUSH EDX - CALL TControl.ParentForm - POP EDX - MOVSX EDX, DL - TEST EDX, EDX - JS @@tab - - PUSH EAX - - PUSH VK_SHIFT - CALL GetAsyncKeyState - SAR EAX, 31 - {$IFDEF PARANOIA} DB $0C, $01 {$ELSE} OR AL, 1 {$ENDIF} - MOV EDX, EAX - - POP EAX -@@tab: - TEST EDI, EDI - POP EDI - JNZ @@no_tab - CALL Tabulate2Next -@@no_tab: - MOV AL, 1 - RET - -@@data: DB VK_LEFT, VK_LEFT - DD offset[@@left] - DB VK_UP, 2 - DB VK_RIGHT, VK_RIGHT - DD offset[@@right] - DB VK_DOWN, 2 - DB VK_UP, VK_PRIOR - DD offset[@@up] - DB VK_TAB or 80h, $C - DB VK_DOWN, VK_NEXT - DD offset[@@down] - DB VK_TAB, $C - -@@1: - // EAX <- Self_:PControl - // DL <- Key - PUSH ESI - MOV ESI, offset[@@data]-6 - MOV DH, 9 - PUSH EAX -@@loop: - ADD DH, DH - JNB @@l1 - JMP @@abort -@@fault1: - POP EDI - POPAD - PUSH EAX -@@abort: - POP EAX -@@abort1: - POP ESI - POP EDI - XOR EAX, EAX - RET - -@@right: - MOV EAX, [ESP].TRect.Left - SUB EAX, [ESP+16].TRect.Left -@@left_right: - JL @@next1 - MOV EDX, [ESP].TRect.Bottom - SUB EDX, [ESP+16].TRect.Top - JL @@next1 - MOV EDX, [ESP].TRect.Top - SUB EDX, [ESP+16].TRect.Bottom - JGE @@next1 -@@chk_dist: - CMP EAX, EDI - JA @@next1 - MOV EDI, EAX - MOV EAX, [EBX+ECX*4-4] - MOV [ESP+36], EAX // Found = Ctrl - JMP @@next1 - -@@l1: - LODSD - LODSW - LODSW - CMP AL, DL - JE @@2 - CMP AH, DL - JNE @@loop - -@@2: - PUSH ESI - LODSD - LODSW - POP ESI - XCHG EDX, EAX - POP EAX - TEST [EAX].TControl.fLookTabKeys, DH - JZ @@abort1 - - PUSHAD - PUSH EDI - CALL TControl.ParentForm - MOV ECX, [EAX].TControl.DF.fCurrentControl - JECXZ @@fault1 - MOV EBP, ECX // EBP = CurCtrl - - PUSH EAX // save Form - MOV EBX, EAX - CALL CollectTabControls - PUSH 0 // save Found = nil - PUSH EAX // save CollectedList - MOV EDI, EAX - - MOV EBX, [EDI].TList.fItems - ADD ESP, -16 - PUSH ESP - PUSH [EBP].TControl.fHandle - CALL GetWindowRect - - MOV ECX, [EDI].TList.fCount - OR EDI, -1 // EDI = minDist -@@loop1: - MOV EAX, [EBX+ECX*4-4] - CMP EAX, EBP - JE @@next - {} - {$IFDEF USE_FLAGS} - MOV DX, word ptr [EAX].TControl.fStyle.f2_Style - AND DX, ($100 shl F3_Disabled) or (1 shl F2_Tabstop) - XOR DH, (1 shl F3_Disabled) - {$ELSE} - MOV DL, [EAX].TControl.fEnabled - AND DL, [EAX].TControl.fTabstop - {$ENDIF USE_FLAGS} - JZ @@next - {} - ADD ESP, -16 - MOV EDX, ESP - PUSH ECX - PUSH EDX - PUSH [EAX].TControl.fHandle - CALL GetWindowRect - POP ECX - JMP dword ptr [ESI] - -@@left: - MOV EAX, [ESP+16].TRect.Left - SUB EAX, [ESP].TRect.Left - JMP @@left_right - -@@not_found: - POP EDI - POPAD - MOV DL, [ESI+4] - POP ESI - JMP @@0 - -@@up: - MOV EAX, [ESP+16].TRect.Top - SUB EAX, [ESP].TRect.Top - JMP @@up_down -@@down: - MOV EAX, [ESP].TRect.Top - SUB EAX, [ESP+16].TRect.Top -@@up_down: - JL @@next1 - MOV EDX, [ESP].TRect.Right - SUB EDX, [ESP+16].TRect.Left - JL @@next1 - MOV EDX, [ESP].TRect.Left - SUB EDX, [ESP+16].TRect.Right - JL @@chk_dist - -@@next1: - ADD ESP, 16 -@@next: - LOOP @@loop1 - ADD ESP, 16 - POP EAX // pop CollectedList - CALL TObj.RefDec - POP ECX // pop Found - POP EAX // pop Form - JECXZ @@not_found - - POP EDI - TEST EDI, EDI - JNZ @@no_go - - MOV [EAX].TControl.DF.fCurrentControl, ECX - INC [ECX].TControl.fClickDisabled - PUSH ECX - MOV ECX, [ECX].TControl.fHandle - JECXZ @@4 - PUSH ECX - CALL Windows.SetFocus -@@4: POP ECX - DEC [ECX].TControl.fClickDisabled -@@no_go: - POPAD - POP ESI - POP EDI - MOV AL, 1 // Result = True -end; -{$ELSE PAS_VERSION} //Pascal -function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean; -label search_tabcontrol; -var Form: PControl; - CL : PList; - I : Integer; - CurCtrl, Ctrl, Found : PControl; - MinDist, Dist: Integer; - R, R1 : TRect; -begin - Result := False; - case Key of - VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit; {>>>>>>>>>>>>>>>>>>>>} - VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit; {>>>} - VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit; {>>>>>>>>>} - VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - else exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := True; - if checkOnly then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Form := Self_.ParentForm; - if Key = VK_TAB then - if GetKeyState( VK_SHIFT ) < 0 then - Tabulate2Next( Form, -1 ) - else - Tabulate2Next( Form, 1 ) - else - begin - CL := CollectTabControls( Form ); - I := CL.IndexOf( Form.DF.fCurrentControl ); - Found := nil; - if I >= 0 then - begin - CurCtrl := CL.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - GetWindowRect( CurCtrl.Handle, R ); - search_tabcontrol: - MinDist := MaxInt; - for I := CL.fCount - 1 downto 0 do - begin - Ctrl := CL.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - if Ctrl = CurCtrl then continue; - if not ({$IFDEF USE_FLAGS} not(F3_Disabled in Ctrl.fStyle.f3_Style) - {$ELSE} Ctrl.fEnabled {$ENDIF} - and - {$IFDEF USE_FLAGS} (F2_Tabstop in Ctrl.fStyle.f2_Style) - {$ELSE} Ctrl.fTabstop {$ENDIF} - ) then continue; - GetWindowRect( Ctrl.Handle, R1 ); - Dist := MaxInt; - case Key of - VK_LEFT: - begin - if (R1.Bottom < R.Top) - or (R1.Top >= R.Bottom) - or (R1.Left > R.Left) then continue; - Dist := R.Left - R1.Left; - end; - VK_RIGHT: - begin - if (R1.Bottom < R.Top) - or (R1.Top >= R.Bottom) - or (R1.Left < R.Left) then continue; - Dist := R1.Left - R.Left; - end; - VK_UP, VK_PRIOR: - begin - if (R1.Right < R.Left) - or (R1.Left >= R.Right) - or (R1.Top > R.Top) then continue; - Dist := R.Top - R1.Top; - end; - VK_DOWN, VK_NEXT: - begin - if (R1.Right < R.Left) - or (R1.Left >= R.Right) - or (R1.Top < R.Bottom) then continue; - Dist := R1.Top - R.Top; - end; - end; - if Dist < MinDist then - begin - Found := Ctrl; - MinDist := Dist; - end; - end; - if Found = nil then - begin - case Key of - VK_LEFT: - begin - Key := VK_UP; goto search_tabcontrol; - end; - VK_RIGHT: - begin - Key := VK_DOWN; goto search_tabcontrol; - end; - VK_UP, VK_PRIOR: - Tabulate2Next( Form, -1 ); - VK_DOWN, VK_NEXT: - Tabulate2Next( Form, 1 ); - end; - end - else - begin - if Found.fHandle <> 0 then - begin - Inc( Found.fClickDisabled ); - SetFocus( Found.fHandle ); - Dec( Found.fClickDisabled ); - end; - Form.DF.fCurrentControl := Found; - end; - end; - CL.Free; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.Tabulate: PControl; -var F : PControl; -begin - Result := @Self; - F := ParentForm; - if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - F.PP.fGotoControl := Tabulate2Control; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.TabulateEx: PControl; -var F : PControl; -begin - Result := @Self; - F := ParentForm; - if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - F.PP.fGotoControl := Tabulate2ControlEx; -end; -{$ENDIF PAS_VERSION} - -function WndProcMouseTransparent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := FALSE; - if Msg.message = WM_NCHITTEST then - begin - Rslt := HTTRANSPARENT; - Result := TRUE; - end; -end; - -function TControl.MouseTransparent: PControl; -begin - AttachProc( WndProcMouseTransparent ); - Result := @ Self; -end; - -procedure TControl.GotoControl(Key: DWORD); -var Form: PControl; -begin - Form := ParentForm; - if Form <> nil then - {$IFDEF NIL_EVENTS} - if Assigned( Form.PP.fGotoControl ) then - {$ENDIF} - Form.PP.fGotoControl( Form.DF.fCurrentControl, Key, false ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetCurIndex: Integer; -var I, J: Integer; -begin - Result := fCurIndex; - if fCommandActions.aGetCurrent = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - I := 0; - if fCommandActions.aGetCurrent = EM_LINEINDEX then - Dec( I ); - J := 0; - if fCommandActions.aGetCurrent = LVM_GETNEXTITEM then - begin - J := 2 {LVNI_SELECTED}; - Dec( I ); - end; - Result := Perform( fCommandActions.aGetCurrent, I, J ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetCurIndex(const Value: Integer); -var NMHdr: TNMHdr; idx: Integer; -begin - if fCommandActions.aSetCurrent <> 0 then - begin - idx := Perform( fCommandActions.aSetCurrent, Value, 0 ); // fix AV - if fCommandActions.aSetCurrent = TCM_SETCURSEL then - begin - fCurIndex := idx; // fix AV - NMHdr.code := TCN_SELCHANGE; - NMHdr.hwndFrom := fHandle; - Perform( WM_NOTIFY, 0, Integer( @NMHdr ) ); - end; - end - else - ItemSelected[ Value ] := True; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetTextAlign: TTextAlign; -begin - UpdateWndStyles; - if (fStyle.Value and fCommandActions.aTextAlignRight) = fCommandActions.aTextAlignRight then - Result := taRight - else - if (fStyle.Value and fCommandActions.aTextAlignCenter) = fCommandActions.aTextAlignCenter then - Result := taCenter - else - Result := fTextAlign; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TControl.GetTextAlign: TTextAlign; -BEGIN - Result := fTextAlign; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetTextAlign(const Value: TTextAlign); -var NewStyle: DWORD; -begin - fTextAlign := Value; - NewStyle := 0; - with fCommandActions{$IFDEF COMMANDACTIONS_OBJ}^{$ENDIF} do - case Value of - taLeft: NewStyle := fStyle.Value and not DWORD(aTextAlignCenter or aTextAlignRight) - or aTextAlignLeft; - taRight: NewStyle := fStyle.Value and not DWORD(aTextAlignLeft or aTextAlignCenter) - or aTextAlignRight; - taCenter: NewStyle := fStyle.Value and not DWORD(aTextAlignLeft or aTextAlignRight) - or aTextAlignCenter; - end; - NewStyle := NewStyle and not DWORD(fCommandActions.bTextAlignMask); - Style := NewStyle; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TControl.SetTextAlign(const Value: TTextAlign); -BEGIN - IF fTextAlign = Value THEN Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fTextAlign := Value; - IF Assigned( fSetTextAlign ) THEN - fSetTextAlign( @ Self ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetVerticalAlign: TVerticalAlign; -begin - UpdateWndStyles; - if (fStyle.Value and (Byte( fCommandActions.bVertAlignCenter ) shl 8)) - = (Byte( fCommandActions.bVertAlignCenter ) shl 8) then - Result := vaCenter - else - if (fStyle.Value and (fCommandActions.bVertAlignBottom shl 8)) - = (fCommandActions.bVertAlignBottom shl 8) then - Result := vaBottom - else - Result := fVerticalAlign; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TControl.GetVerticalAlign: TVerticalAlign; -BEGIN - Result := fVerticalAlign; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetVerticalAlign(const Value: TVerticalAlign); -var NewStyle: DWORD; -begin - fVerticalAlign := Value; - with fCommandActions{$IFDEF COMMANDACTIONS_OBJ}^{$ENDIF} do - begin - NewStyle := fStyle.Value and - not DWORD((bVertAlignTop or bVertAlignCenter or bVertAlignBottom) shl 8); - case Value of - vaCenter: NewStyle := NewStyle or (bVertAlignCenter shl 8); - vaTop: NewStyle := NewStyle or (bVertAlignTop shl 8); - vaBottom: NewStyle := NewStyle or (bVertAlignBottom shl 8); - end; - end; - Style := NewStyle; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE TControl.SetVerticalAlign(const Value: TVerticalAlign); -BEGIN - if fVerticalAlign = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fVerticalAlign := Value; - if Assigned( fSetTextAlign ) then - fSetTextAlign( @ Self ); -END; -{$ENDIF GTK} -{$ENDIF _X_} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.Dc2Canvas( Sender: PCanvas ): HDC; -begin - if fPaintDC <> 0 then - begin - Result := fPaintDC; - Sender.SetHandle( Result ); - Sender.fIsPaintDC := True; - end - else - begin - if Sender.fHandle <> 0 then - Result := Sender.fHandle - else - Result := GetDC( GetWindowHandle ); - end; -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetCanvas: PCanvas; -begin - {$IFDEF SAFE_CODE} - CreateWindow; - {$ENDIF} - if ( fCanvas = nil ) then - begin - fCanvas := NewCanvas( 0 ); - fCanvas.fOnGetHandle := Dc2Canvas; - fCanvas.fOwnerControl := @Self; - if ( fFont <> nil ) then - fCanvas.fFont := fCanvas.fFont.Assign( fFont ); - if ( fBrush <> nil ) then - fCanvas.fBrush := fCanvas.fBrush.Assign( fBrush ); - end; - Result := fCanvas; -end; -{$ENDIF PAS_VERSION} -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TControl.ProvideCanvasHandle( Sender: PCanvas ): HDC; -TYPE PPGdkGC = ^PGdkGC; -VAR Array_gc: PPGdkGC; -BEGIN - IF fInBkPaint THEN Array_gc := @ fEventboxHandle.style.bg_gc[ 0 ] - ELSE Array_gc := @ fEventboxHandle.style.fg_gc[ 0 ]; - CASE fEventboxHandle.state OF - GTK_STATE_NORMAL, - GTK_STATE_ACTIVE, - GTK_STATE_PRELIGHT, - GTK_STATE_SELECTED, - GTK_STATE_INSENSITIVE: Result := PPGdkGC( Integer( Array_gc ) + fEventboxHandle.state * sizeof( Pointer ) )^; - ELSE Result := Array_gc^; - END; -END; - -FUNCTION TControl.GetCanvas: PCanvas; -BEGIN - {$IFDEF SAFE_CODE} - CreateWindow; - {$ENDIF} - IF ( fCanvas = nil ) then - BEGIN - fCanvas := NewCanvas( nil ); - fCanvas.fOnGetHandle := ProvideCanvasHandle; - fCanvas.fOwnerControl := @Self; - fCanvas.fDrawable := Pointer( fEventboxHandle.window ); - END; - fCanvas.GetHandle; // получим здесь тот контекст, который соответствует - // текущему состоянию контрола (если это контрол) и текущей - // стадии рисования - Result := fCanvas; -END; -{$ENDIF GTK} -{$ENDIF _X_} -{$IFDEF WIN_GDI} - -function TControl.DblBufTopParent: PControl; -var Ctl: PControl; -begin - Result := nil; - Ctl := @ Self; - while Ctl <> nil do - begin - if {$IFDEF USE_FLAGS} ( [G2_DoubleBuffered, G2_Transparent] * Ctl.fFlagsG2 <> [] ) - {$ELSE} (Ctl.fDoubleBuffered) or (Ctl.fTransparent) {$ENDIF} then - Result := Ctl; - Ctl := Ctl.fParent; - end; -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure TControl.SetDoubleBuffered(const Value: Boolean); -begin - if {$IFDEF USE_FLAGS} (G1_CanNotDoublebuf in fFlagsG1) - {$ELSE} CannotDoubleBuf {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF USE_FLAGS} - if Value then - include( fFlagsG2, G2_DoubleBuffered ) - else exclude( fFlagsG2, G2_DoubleBuffered ); - {$ELSE} fDoubleBuffered := Value; {$ENDIF} - AttachProc(WndProcTransparent); - {$IFNDEF SMALLEST_CODE} - Global_AttachProcExtension := @TransparentAttachProcExtension; - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetTransparent(const Value: Boolean); -begin - if fParent = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF USE_FLAGS} - if Value then - include( fFlagsG2, G2_Transparent ) - else exclude( fFlagsG2, G2_Transparent ); - {$ELSE} fTransparent := Value; {$ENDIF} - -{$IFDEF GRAPHCTL_XPSTYLES} - if not AppTheming then - begin - {$IFDEF USE_FLAGS} - if Value then - include( fFlagsG3, G3_ClassicTransparent ) - else exclude( fFlagsG3, G3_ClassicTransparent ); - {$ELSE} fClassicTransparent := Value; {$ENDIF} - end; -{$ENDIF} - - if Value then begin - AttachProc(WndProcTransparent); - fParent.DoubleBuffered := TRUE; - end; -end; -{$ENDIF PAS_VERSION} - -function TControl.SetBorder( Value: Integer ): PControl; -begin - fMargin := Value; - Result := @ Self; -end; - -{ TTrayIcon } - -var FTrayItems: PList; - -{$IFDEF ASM_noVERSION} // ASM_TLIST! -function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; -asm - PUSH ECX - MOV ECX, [EDX].TMsg.message - CMP CX, CM_TRAYICON - JNE @@1 - - MOV ECX, [EDX].TMsg.lParam - MOV EDX, [EDX].TMsg.wParam - MOV EAX, [EDX].TTrayIcon.fOnMouse.TMethod.Data - CMP word ptr [EDX].TTrayIcon.fOnMouse.TMethod.Code+2, 0 - JE @@no_on - - CALL [EDX].TTrayIcon.fOnMouse.TMethod.Code -@@no_on: - POP ECX - XOR EAX, EAX - MOV [ECX], EAX - INC EAX - RET - -@@1: - SUB ECX, WM_CLOSE - JNE @@exit_0 -@@2: - - POP ECX - PUSH EBX - XCHG EBX, EAX - - MOV EAX, [EBX].TControl.fHandle - CMP EAX, [EDX].TMsg.hwnd - JNE @@otherwin - - MOV EDX, [FTrayItems] - MOV ECX, [EDX].TList.fCount - MOV EDX, [EDX].TList.fItems -@@loop: - MOV EAX, [EDX + ECX*4 - 4] - CMP [EAX].TTray.FNoAutoDeactivate, 0 - JNZ @@3 - CMP [EAX].TTrayIcon.fControl, EBX - JNE @@3 - PUSHAD - XOR EDX, EDX - CALL TTrayIcon.SetActive - POPAD -@@3: LOOP @@loop - -@@otherwin: - POP EBX - PUSH ECX -@@exit_0: - XOR EAX, EAX - POP ECX -end; -{$ELSE PAS_VERSION} //Pascal -function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; -var Self_: PTrayIcon; - I : Integer; -begin - Result := False; - case Msg.message of - CM_TRAYICON: - begin - Self_ := Pointer( Msg.wParam ); - if Assigned( Self_.FOnMouse ) then - Self_.FOnMouse( @Self_, Msg.lParam ); - Rslt := 0; - Result := True; - end; - WM_CLOSE: - if Msg.hwnd = Control.fHandle then - begin - if FTrayItems <> nil then // ????????????????? - for I := FTrayItems.Count - 1 downto 0 do - begin - Self_ := FTrayItems.Items[ I ]; - if not Self_.FNoAutoDeactivate then - if Self_.FControl = Control then - Self_.Active := False; - end; - end; - end; -end; -{$ENDIF PAS_VERSION} - -function WndProcTrayIconWnd( Wnd: HWnd; Msg: DWORD; wParam, lParam: Integer ): Integer; - stdcall; -var PrevProc: function ( Wnd: HWnd; Msg: DWORD; - wParam, lParam: Integer ): Integer; stdcall; -var Tr: PTrayIcon; -begin - PrevProc := Pointer( GetProp( Wnd, 'TRAYSAVEPROC' ) ); - if Msg = CM_TRAYICON then - begin - Tr := Pointer( wParam ); - if Assigned( Tr.FOnMouse ) then - Tr.FOnMouse( Tr, lParam ); - Result := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end - else - if Msg = WM_CLOSE then - begin - if Assigned( PrevProc ) then - begin - SetWindowLong( Wnd, GWL_WNDPROC, Integer( @ PrevProc ) ); - RemoveProp( Wnd, 'TRAYSAVEPROC' ); - PostMessage( Wnd, WM_CLOSE, wParam, lParam ); - Result := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - if (Wnd <> 0) and IsWindow( Wnd ) and Assigned( PrevProc ) then - Result := PrevProc( Wnd, Msg, wParam, lParam ) - else Result := DefWindowProc( Wnd, Msg, wParam, lParam ); -end; - -procedure TTrayIcon.AttachProc2Wnd; -begin - if FWnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if GetProp( FWnd, 'TRAYSAVEPROC' ) <> 0 then Exit; // already attached {>>>>>} - SetProp( FWnd, 'TRAYSAVEPROC', GetWindowLong( FWnd, GWL_WNDPROC ) ); - SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ WndProcTrayIconWnd ) ); -end; -// [END TTrayIcon.AttachProc2Wnd] - -// [PROCEDURE TTrayIcon.DetachProc2Wnd] -procedure TTrayIcon.DetachProc2Wnd; -var OldProc: function ( Wnd: HWnd; Msg: DWORD; - wParam, lParam: Integer ): Integer; stdcall; -begin - if FWnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - OldProc := Pointer( GetProp( FWnd, 'TRAYSAVEPROC' ) ); - if not Assigned( OldProc ) then Exit; // not attached {>>>>>>>>>>>>>>>>>>>>} - SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ OldProc ) ); - RemoveProp( FWnd, 'TRAYSAVEPROC' ); -end; -// [END TTrayIcon.DetachProc2Wnd] - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon; -begin - if FTrayItems = nil then - FTrayItems := NewList; - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TTrayIcon'; - {$ENDIF} - FTrayItems.Add( Result ); - if Wnd <> nil then - Wnd.AttachProc( WndProcTray ); - Result.FControl := Wnd; - Result.FIcon := Icon; - Result.Active := True; -end; -{$ENDIF PAS_VERSION} - -var fRecreateMsg: DWORD; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcRecreateTrayIcons( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var I: Integer; - TI: PTrayIcon; -begin - if Msg.message = fRecreateMsg then - begin - for I := 0 to FTrayItems.fCount - 1 do - begin - TI := FTrayItems.Items[ I ]; - if TI.fAutoRecreate then - if TI.fActive then - begin - TI.fActive := False; - TI.Active := True; - end; - end; - end; - Result := False; -end; -{$ENDIF PAS_VERSION} - -const - TaskbarCreatedMsg: array[ 0..14 ] of KOLChar = ('T','a','s','k','b','a','r', - 'C','r','e','a','t','e','d',#0); -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TTrayIcon.SetAutoRecreate(const Value: Boolean); -begin - fAutoRecreate := Value; - FControl.ParentForm.AttachProc( WndProcRecreateTrayIcons ); - fRecreateMsg := RegisterWindowMessage( TaskbarCreatedMsg ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TTrayIcon.Destroy; -begin - Active := False; - - if fIcon <> 0 then - DestroyIcon( fIcon ); - - FTrayItems.Remove( @ Self ); - if FTrayItems.Count = 0 then - Free_And_Nil( FTrayItems ); - FTooltip := ''; - inherited; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TTrayIcon.SetActive(const Value: Boolean); -begin - if FActive = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if FIcon = 0 then Exit; - if (Wnd = 0) and ((FControl = nil) or (FControl.GetWindowHandle = 0)) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FActive := Value; - if Value then - SetTrayIcon( NIM_ADD ) - else - SetTrayIcon( NIM_DELETE ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TTrayIcon.SetIcon(const Value: HIcon); -var Cmd : DWORD; -begin - if FIcon = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // Previous icon is not destroying. This is normal for icons, loaded from - // resources using LoadIcon. For icons, created using CreateIconIndirect, You - // have to call DestroyIcon manually. - Cmd := NIM_MODIFY; - if FIcon = 0 then - Cmd := NIM_ADD; - FIcon := Value; - if FActive then - SetTrayIcon( Cmd ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure TTrayIcon.SetTooltip(const Value: KOLString); -begin - if FTooltip = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FTooltip := Value; - if Active then - SetTrayIcon( NIM_MODIFY ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure TTrayIcon.SetTrayIcon(const Value: DWORD); -var NID : {$IFDEF UNICODE_CTRLS} TNotifyIconDataW {$ELSE} TNotifyIconData {$ENDIF}; - L : Integer; - V : DWORD; -begin - V := Value; - if AppletTerminated then - V := NIM_DELETE; - if Wnd <> 0 then - NID.Wnd := Wnd - else - NID.Wnd := FControl.fHandle; - - NID.cbSize := Sizeof( NID ); - NID.uID := DWORD( @Self ); - NID.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; - if V = NIM_DELETE then - NID.uFlags := 0; - NID.uCallbackMessage := CM_TRAYICON; - NID.hIcon := FIcon; - L := Length( FToolTip ); - if L > 63 then L := 63; - Move( FTooltip[1], NID.szTip[0], Min( 63, L )*SizeOf(KOLChar) ); - NID.szTip[ L ] := #0; - - Shell_NotifyIcon( V, @NID ); -end; -{$ENDIF PAS_VERSION} - -{ -- JustOne -- } - -var JustOneMutex: THandle; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; -begin - Result := False; - case Msg.message of - WM_CLOSE, WM_NCDESTROY: - if LongBool( JustOneMutex ) and (Control.Handle = Msg.hwnd) then - begin - CloseHandle( JustOneMutex ); - JustOneMutex := 0; - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_noUNICODE} -function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean; -asm - PUSH EBX - PUSH ESI - XOR ESI, ESI - PUSH EDI - XCHG EBX, EAX - - CALL EDX2PChar - PUSH EDX - - PUSH 0 - PUSH 1 - PUSH ESI - MOV EDI, offset[CreateMutex] - CALL EDI - - POP EDX - TEST EAX, EAX - JZ @@exit // - PUSH EAX - PUSH EAX - - PUSH EDX - PUSH ESI - PUSH ESI - CALL EDI - MOV [JustOneMutex], EAX - TEST EAX, EAX - JE @@1 // - - PUSH ESI - PUSH EAX - CALL WaitForSingleObject - SUB EAX, WAIT_TIMEOUT - JE @@1 - - INC ESI -@@1: - XCHG EAX, EBX - MOV EDX, offset[WndProcJustOne] - CALL TControl.AttachProc - - CALL ReleaseMutex - CALL CloseHandle - -@@exit: - XCHG EAX, ESI - POP EDI - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean; -var CritSecMutex : THandle; - DW : Longint; -begin - Result := False; - CritSecMutex := CreateMutex( nil, True, nil ); - if CritSecMutex = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - - JustOneMutex := CreateMutex( nil, False, PKOLChar( Identifier ) ); - if JustOneMutex <> 0 then - begin - DW := WaitForSingleObject( JustOneMutex, 0 ); - Result := (DW <> WAIT_TIMEOUT); - end; - Wnd.AttachProc( WndProcJustOne ); - CloseHandle( CritSecMutex ); -end; -{$ENDIF PAS_VERSION} - -{ JustOneNotify } - -var - OnAnotherInstance: TOnAnotherInstance; - JustOneMsg: DWORD; - -{$IFDEF ASM_UNICODE}{$ELSE ASM_UNICODE} //Pascal -function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; -var Buf : array[0..MAX_PATH] of KOLChar; -begin - WndProcJustOne( Control, Msg, Rslt ); - Result := False; - if Msg.message = JustOneMsg then - begin - Result := True; - if assigned( OnAnotherInstance ) then - begin - GetWindowText( Msg.lParam, Buf, MAX_PATH ); - OnAnotherInstance( Buf ); - end; - Rslt := 0; - end; -end; -{$ENDIF PAS_VERSION} - -// Redefine here incorrectly declared BroadcastSystemMessage API function. -// It should not refer to BroadcastSystemMessageA, which is not present in -// earlier versions of Windows95, but to BroadcastSystemMessage, which is -// present in all Windows95/98/Me and NT/2K/XP. -function BroadcastSystemMessage(Flags: DWORD; Recipients: PDWORD; - uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; stdcall; -external user32 name 'BroadcastSystemMessage'; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function JustOneNotify( Wnd: PControl; const Identifier : KOLString; - const aOnAnotherInstance: TOnAnotherInstance ) : Boolean; -var Recipients : DWord; - OldCap: KOLString; -begin - Result := False; - JustOneMsg := RegisterWindowMessage( PKOLChar( 'Message.' + Identifier ) ); - if JustOneMsg = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - - Result := JustOne( Wnd, Identifier ); - if not Result then - begin - // Send a message to the first instance of applet - OldCap := Wnd.Caption; - Wnd.Caption := GetCommandLine; - if Wnd.GetWindowHandle <> 0 then - begin - Recipients := BSM_APPLICATIONS; - BroadcastSystemMessage( BSF_QUERY or BSF_IGNORECURRENTTASK, @Recipients, - JustOneMsg, 0, Wnd.fHandle ); - end; - Wnd.Caption := OldCap; - end - else - begin - // Store event handler to notify this instance about another - // instance staring: - OnAnotherInstance := aOnAnotherInstance; - Wnd.AttachProc( WndProcJustOneNotify ); - end; -end; -{$ENDIF PAS_VERSION} - -///////////////////////////////////////// STRING LIST OBJECT ///////////////// - -{$ENDIF WIN} -{ TStrList } - -function NewStrList: PStrList; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TStrList'; - {$ENDIF} -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TStrList.Destroy; -begin - Clear; - inherited; -end; -{$ENDIF PAS_VERSION} - -procedure TStrList.Init; -begin - {$IFDEF CALL_INHERITED} - inherited; - {$ENDIF} - fNameDelim := DefaultNameDelimiter; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TStrList.Add(const S: Ansistring): integer; -begin - Result := fCount; - Insert( Result, S ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TStrList.AddStrings(Strings: PStrList); -begin - SetText( Strings.Text, True ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TStrList.Assign(Strings: PStrList); -begin - Clear; - AddStrings( Strings ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TStrList.Clear; -var I: Integer; -begin - if fCount > 0 then - for I := fList.Count - 1 downto 0 do - Delete( I ); - fList.Free; - fList := nil; - fCount := 0; - if fTextBuf <> nil then - begin - FreeMem( fTextBuf ); - fTextBuf := nil; - fTextSiz := 0; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION} {$DEFINE TStrList_Delete_ASM} {$ENDIF} -{$IFDEF TLIST_FAST} {$UNDEF TStrList_Delete_ASM} {$ENDIF} - -{$IFDEF TStrList_Delete_ASM} -{$ELSE PAS_VERSION} //Pascal -procedure TStrList.Delete(Idx: integer); -var P: DWORD; - El:Pointer; -begin - P := DWORD( fList.Items[ Idx ] ); - if (fTextBuf <> nil) and ( P >= DWORD( fTextBuf )) and - ( P < DWORD( fTextBuf ) + fTextSiz ) then - else - begin - El := FList.Items[ Idx ]; - FreeMem( El ); - end; - fList.Delete( Idx ); - Dec( fCount ); -end; -{$ENDIF PAS_VERSION} - -procedure TStrList.DeleteLast; -begin - Delete( Count-1 ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TStrList.Get(Idx: integer): Ansistring; -begin - if fList <> nil then - Result := PAnsiChar( fList.Items[ Idx ] ) - else Result := ''; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -function TStrList.GetPChars(Idx: Integer): PAnsiChar; -asm - MOV EAX, [EAX].fList - MOV EAX, [EAX].TList.fItems - MOV EAX, [EAX+EDX*4] -end; -{$ELSE PAS_VERSION} //Pascal -function TStrList.GetPChars(Idx: Integer): PAnsiChar; -begin - Result := PAnsiChar( fList.{$IFDEF TLIST_FAST}Items{$ELSE}fItems{$ENDIF}[ Idx ] ) -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -function TStrList.GetTextStr: Ansistring; -asm - PUSH ESI - PUSH EDI - MOV ECX, [EAX].fCount - MOV EAX, [EAX].fList - PUSH ECX - JECXZ @@1 - MOV ESI, [EAX].TList.fItems -@@1: PUSH ESI - XCHG EAX, EDX - XOR EDX, EDX - JECXZ @@10 - PUSH EAX -@@loo1: PUSH ECX - PUSH EDX - LODSD - CALL StrLen - POP EDX - LEA EDX, [EDX+EAX+2] - POP ECX - LOOP @@loo1 - POP EAX - POP ESI - XCHG ECX, EDX - PUSH EAX -@@10: {$IFDEF _D2} - CALL _LStrFromPCharLen - {$ELSE} - {$IFDEF _D2009orHigher} - XOR ECX, ECX - {$ENDIF} - CALL System.@LStrFromPCharLen - {$ENDIF} - POP EDI - POP ECX - JECXZ @@exit - MOV EDI, [EDI] -@@loo2: PUSH ECX - LODSD - PUSH EAX - CALL StrLen - XCHG ECX, EAX - POP EAX - XCHG EAX, ESI - REP MOVSB - XCHG ESI, EAX - MOV AX, $0A0D - STOSW - POP ECX - LOOP @@loo2 - XCHG EAX, ECX - STOSB -@@exit: POP EDI - POP ESI -end; -{$ELSE PAS_VERSION} //Pascal -function TStrList.GetTextStr: Ansistring; -var - I, Len, Size: integer; - P: PAnsiChar; -begin - Size := 0; - - for I := 0 to fCount - 1 do - Inc(Size, StrLen( PAnsiChar(fList. - {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} [I]) ) + - {$IFDEF LIN} 1 {$ELSE} 2 {$ENDIF}); - - SetString(Result, nil, Size); - - P := Pointer(Result); - for I := 0 to Count - 1 do - begin - Len := StrLen(PAnsiChar(fList. - {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} [I])); - if (Len > 0) then - begin - System.Move(PAnsiChar(fList. - {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[I])^, - P^, Len); - Inc(P, Len); - end; - P^ := #13; - Inc(P); - {$IFDEF WIN} - P^ := #10; - Inc(P); - {$ENDIF WIN} - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -function TStrList.IndexOf(const S: Ansistring): integer; -asm - PUSH EDI - PUSH ESI - PUSH EBX - OR EDI, -1 - MOV ECX, [EAX].fCount - JECXZ @@exit - MOV ESI, [EAX].fList - MOV ESI, [ESI].TList.fItems - CALL EDX2PChar - MOVZX EBX, BYTE[EDX] -@@loo: LODSD - INC EDI - CMP BL, BYTE[EAX] - JNE @@1 - PUSH EDX - PUSH ECX - CALL StrComp - POP ECX - POP EDX - JE @@exit -@@1: LOOP @@loo - OR EDI, -1 -@@exit: XCHG EAX, EDI - POP EBX - POP ESI - POP EDI -end; -{$ELSE PAS_VERSION} //Pascal -function TStrList.IndexOf(const S: AnsiString): integer; -var Word1: Word; -begin - if S = '' then - begin - for Result := 0 to fCount - 1 do - if PAnsiChar(fList.Items[Result])^ = #0 then Exit; {>>>>>>>>>>>>>>>>>>} - end else - begin - Word1 := PWord(PAnsiChar( S ))^; - for Result := 0 to fCount - 1 do - if (PWord(fList.Items[Result])^ = Word1) - and (StrComp( fList.Items[Result], PAnsiChar( S ) ) = 0) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := -1; -end; -{$ENDIF PAS_VERSION} - -function TStrList.IndexOf_NoCase(const S: AnsiString): integer; -var tmp: PAnsiChar; - c: AnsiChar; -begin - if S = '' then - begin - for Result := 0 to fCount - 1 do - if PAnsiChar( fList.Items[Result] )^ = #0 then Exit; {>>>>>>>>>>} - end else - begin - if not Upper_initialized then - Init_Upper; - for Result := 0 to fCount - 1 do - begin - tmp := fList.Items[Result]; - c := Upper[S[1]]; - if (c = Upper[tmp^]) and - (_AnsiCompareStrNoCaseA( PAnsiChar( S ), tmp ) = 0) then Exit; {>>>} - end; - end; - Result := -1; -end; - -function TStrList.IndexOfStrL_NoCase( Str: PAnsiChar; L: Integer ): integer; -begin - if L = 0 then - Result := 0 - else - begin - for Result := 0 to fCount - 1 do - if (StrLen( PAnsiChar( fList. - {$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ Result ] - ) ) = DWORD( L )) and - (StrLComp_NoCase( Str, PAnsiChar( - fList.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ Result ] - ), L ) = 0) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := -1; - end; -end; - -function CompareAnsiCase( const S1, S2: PAnsiChar ): Integer; -begin - Result := _AnsiCompareStrA( S1, S2 ); -end; - -function CompareAnsiNoCase( const S1, S2: PAnsiChar ): Integer; -begin - Result := _AnsiCompareStrNoCaseA( S1, S2 ); -end; - -function TStrList.Find(const S: AnsiString; var Index: Integer): Boolean; -var - L, H, C: Integer; -begin - Result := FALSE; - Index := 0; - L := 0; - H := FCount - 1; - if H < 0 then Exit; // === if FCount = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>} - if fAnsiSort then - begin - if fCaseSensitiveSort then - fCompareStrListFun := CompareAnsiCase - else - fCompareStrListFun := CompareAnsiNoCase; - end else - begin - if fCaseSensitiveSort then - fCompareStrListFun := StrComp - else - fCompareStrListFun := StrComp_NoCase; - end; - C := 0; - while L <= H do - begin - Index := (L + H) shr 1; - C := fCompareStrListFun( PAnsiChar( fList.Items[ Index ] ), - PAnsiChar( S ) ); - if C < 0 then L := Index + 1 else - begin - H := Index - 1; - if C = 0 then - begin - Result := TRUE; {Index := I;} Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; - if C < 0 then Index := -L; -end; - -function TStrList.FindFirst(const S: AnsiString; var Index: Integer): Boolean; -begin - Result := Find( S, Index ); - if Result then - begin - while (Index > 0) - and (fCompareStrListFun( PAnsiChar( fList.Items[ Index-1 ] ), - PAnsiChar( S )) = 0) do - dec( Index ); - end; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TStrList.Insert(Idx: integer; const S: Ansistring); -var Mem: PAnsiChar; - L: Integer; -begin - if fList = nil then - fList := NewList; - L := Length( S ) + 1; - GetMem( Mem, L ); - Mem[0] := #0; - if L > 1 then - System.Move( S[1], Mem[0], L ); - fList.Insert( Idx, Mem ); - Inc( fCount ); -end; -{$ENDIF PAS_VERSION} - -procedure TStrList.Move(CurIndex, NewIndex: integer); -begin - fList.MoveItem( CurIndex, NewIndex ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TStrList.Put(Idx: integer; const Value: Ansistring); -begin - Delete( Idx ); - Insert( Idx, Value ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -procedure TStrList.SetText(const S: Ansistring; Append2List: boolean); -asm - DEC CL - JZ @@1 - PUSHAD - CALL Clear - POPAD -@@1: CALL EDX2PChar - JZ @@exit - PUSH EBX - PUSH EDI - MOV EBX, EAX - MOV EDI, [EBX].fTextSiz - MOV EAX, [EDX-4] // EAX = Length(S) - INC EAX - PUSH EAX - // add S to text buffer - PUSH EDX - PUSH [EBX].fTextBuf - ADD EAX, [EBX].fTextSiz - CALL System.@GetMem - MOV [EBX].fTextBuf, EAX - MOV ECX, EDI - XCHG EDX, EAX - POP EAX - JECXZ @@atb_fin - PUSH EAX - CALL System.Move - POP EDX - PUSH EDX - PUSH ESI - MOV ESI, [EBX].fList - MOV ESI, [ESI].TList.fItems - MOV ECX, [EBX].fCount -@@atb_loo: - LODSD - SUB EAX, EDX - CMP EAX, [EBX].fTextSiz - JAE @@atb_nxt - ADD EAX, [EBX].fTextBuf - MOV [ESI-4], EAX -@@atb_nxt: LOOP @@atb_loo - POP ESI - POP EAX - CALL System.@FreeMem -@@atb_fin: - POP EAX - MOV EDX, EDI - ADD EDX, [EBX].fTextBuf - POP ECX - PUSH ECX - ADD [EBX].fTextSiz, ECX - CALL System.Move -@@eatb: - ADD EDI, [EBX].fTextBuf // EDI ~ P - MOV ECX, [EBX].fList - INC ECX - LOOP @@2 - CALL NewList - MOV [EBX].fList, EAX -@@2: - POP ECX - MOV EDX, [EBX].fCount - PUSH EDI - PUSH ECX - MOV AL, $0D -@@loo1: CMP byte ptr [EDI], 0 - JZ @@eloo1 - INC EDX - REPNZ SCASB - JNZ @@eloo1 - CMP byte ptr [EDI], $0A - JNZ @@loo1 - INC EDI - LOOP @@loo1 -@@eloo1: - MOV [EBX].fCount, EDX - MOV EAX, [EBX].fList - {$IFNDEF TLIST_FAST} - PUSH EDX - PUSH EAX - CMP EDX, [EAX].TList.fCapacity - JLE @@3 - CALL TList.SetCapacity -@@3: POP EAX - POP ECX - {$ENDIF TLIST_FAST} - XCHG ECX, [EAX].TList.fCount - MOV EDX, [EAX].TList.fItems - LEA EDX, [EDX+ECX*4] - POP ECX - POP EDI - MOV EAX, $0D -@@loo2: CMP byte ptr [EDI], AH - JZ @@eloo2 - MOV [EDX], EDI - ADD EDX, 4 - REPNZ SCASB - JNZ @@eloo2 - MOV [EDI-1], AH - CMP byte ptr [EDI], $0A - JNZ @@loo2 - INC EDI - LOOP @@loo2 -@@eloo2: - POP EDI - POP EBX -@@exit: -end; -{$ELSE PAS_VERSION} //Pascal -procedure TStrList.SetText(const S: Ansistring; Append2List: Boolean); -var - P, TheLast : PAnsiChar; - L, I : Integer; - - procedure AddTextBuf(Src: PAnsiChar; Len: DWORD); - var OldTextBuf, P: PAnsiChar; - I : Integer; - begin - if Src <> nil then - begin - OldTextBuf := fTextBuf; - GetMem( fTextBuf, fTextSiz + Len ); - if fTextSiz <> 0 then - begin - System.Move( OldTextBuf^, fTextBuf^, fTextSiz ); - for I := 0 to fCount - 1 do - begin - P := fList.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - if (DWORD( P ) >= DWORD( OldTextBuf )) and - (DWORD( P ) < DWORD( OldTextBuf ) + fTextSiz) then - fList.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ] := - Pointer( DWORD( P ) - DWORD( OldTextBuf ) + DWORD( fTextBuf ) ); - end; - FreeMem( OldTextBuf ); - end; - System.Move( Src^, fTextBuf[ fTextSiz ], Len ); - Inc( fTextSiz, Len ); - end; - end; -begin - if not Append2List then Clear; - if S = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - L := fTextSiz; - AddTextBuf( PAnsiChar( S ), Length( S ) + 1 ); - P := PAnsiChar( DWORD( fTextBuf ) + DWORD( L ) ); - if fList = nil then fList := NewList; - I := 0; - TheLast := P + Length( S ); - while P^ <> #0 do - begin - Inc( I ); - {$IFDEF WIN} - P := StrScanLen( P, #13, TheLast - P ); - if P^ = #10 then - Inc( P ); - {$ELSE LIN} - P := StrScanLen( P, #10, TheLast - P ); - {$ENDIF} - end; - Inc( fCount, I ); - {$IFNDEF TLIST_FAST} - if fList.fCapacity < fCount then - fList.Capacity := fCount; - {$ENDIF} - P := PAnsiChar( DWORD( fTextBuf ) + DWORD( L ) ); - while P^ <> #0 do - begin - fList.Add( P ); - {$IFDEF WIN} - P := StrScanLen( P, #13, TheLast - P ); - if PAnsiChar( P - 1 )^ = #13 then - PAnsiChar( P - 1 )^ := #0; - if P^ = #10 then Inc(P); - {$ELSE LIN} - P := StrScanLen( P, #10, TheLast - P ); - {$ENDIF} - end; -end; -{$ENDIF PAS_VERSION} - -procedure TStrList.SetUnixText(const S: AnsiString; Append2List: Boolean); -var S1: AnsiString; -begin - S1 := S; - NormalizeUnixText( S1 ); - SetText( S1, Append2List ); -end; - -procedure TStrList.SetTextStr(const Value: Ansistring); -begin - SetText( Value, False ); -end; - -{$IFDEF ASM_TLIST} -function CompareStrListItems_NoCase( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -asm - MOV EAX, [EAX].TStrList.fList - MOV EAX, [EAX].TList.fItems - MOV EDX, [EAX+EDX*4] - MOV EAX, [EAX+ECX*4] - XCHG EAX, EDX - JMP StrComp_NoCase -end; -{$ELSE PAS_VERSION} //Pascal -function CompareStrListItems_NoCase( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var S1, S2 : PAnsiChar; -begin - S1 := PStrList( Sender ).fList.Items[ e1 ]; - S2 := PStrList( Sender ).fList.Items[ e2 ]; - Result := StrComp_NoCase( S1, S2 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -function CompareStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -asm - MOV EAX, [EAX].TStrList.fList - MOV EAX, [EAX].TList.fItems - MOV EDX, [EAX+EDX*4] - MOV EAX, [EAX+ECX*4] - XCHG EAX, EDX - JMP StrComp -end; -{$ELSE PAS_VERSION} //Pascal -function CompareStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var S1, S2 : PAnsiChar; -begin - S1 := PStrList( Sender ).fList.Items[ e1 ]; - S2 := PStrList( Sender ).fList.Items[ e2 ]; - Result := StrComp( S1, S2 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -asm - MOV EAX, [EAX].TStrList.fList - MOV EAX, [EAX].TList.fItems - MOV EDX, [EAX+EDX*4] - MOV EAX, [EAX+ECX*4] - XCHG EAX, EDX - JMP _AnsiCompareStrNoCase -end; -{$ELSE PAS_VERSION} //Pascal -function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var S1, S2 : PAnsiChar; -begin - S1 := PStrList( Sender ).fList.Items[ e1 ]; - S2 := PStrList( Sender ).fList.Items[ e2 ]; - Result := _AnsiCompareStrNoCaseA( S1, S2 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_TLIST} -function CompareAnsiStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -asm - MOV EAX, [EAX].TStrList.fList - MOV EAX, [EAX].TList.fItems - MOV EDX, [EAX+EDX*4] - MOV EAX, [EAX+ECX*4] - XCHG EAX, EDX - JMP _AnsiCompareStr -end; -{$ELSE PAS_VERSION} //Pascal -function CompareAnsiStrListItems_Case( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var S1, S2 : PAnsiChar; -begin - S1 := PStrList( Sender ).fList.Items[ e1 ]; - S2 := PStrList( Sender ).fList.Items[ e2 ]; - Result := _AnsiCompareStrA( S1, S2 ) -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TStrList.Sort(CaseSensitive: Boolean); -begin - fCaseSensitiveSort := CaseSensitive; - fAnsiSort := FALSE; - {$IFDEF SPEED_FASTER} - {$DEFINE SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF TLIST_FAST} - {$UNDEF SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF _D2} - {$UNDEF SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF SORT_STRLIST_ARRAY} - if Count > 1 then - if CaseSensitive then - SortArray( fList.fItems, fCount, @StrComp ) - else - SortArray( fList.fItems, fCount, @StrComp_NoCase ); - {$ELSE} - if CaseSensitive then - SortData( @Self, fCount, @CompareStrListItems_Case, @TStrList.Swap ) - else - SortData( @Self, fCount, @CompareStrListItems_NoCase, @TStrList.Swap ) - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF noASM_VERSION} -procedure TStrList.AnsiSort(CaseSensitive: Boolean); -asm - MOV [EAX].fCaseSensitiveSort, DL - MOV [EAX].fAnsiSort, 1 - {$IFDEF SORT_STRLIST_ARRAY} - MOV ECX, Offset[_AnsiCompareStrA] - CMP DL, 0 - JNZ @@01 - MOV ECX, [_AnsiCompareStrNoCaseA] -@@01: - MOV EAX, [EAX].fList - MOV EDX, [EAX].TList.fCount - CMP EDX, 1 - JLE @@02 - MOV EAX, [EAX].TList.fItems - CALL SortArray -@@02: - {$ELSE} - PUSH Offset[TStrList.Swap] - MOV ECX, Offset[CompareAnsiStrListItems] - CMP DL, 0 - JNZ @1 - MOV ECX, Offset[CompareAnsiStrListItems_Case] -@1: MOV EDX, [EAX].fCount - CALL SortData - {$ENDIF} -end; -{$ELSE PAS_VERSION} //Pascal -procedure TStrList.AnsiSort(CaseSensitive: Boolean); -begin - fCaseSensitiveSort := CaseSensitive; - fAnsiSort := TRUE; - {$IFDEF SPEED_FASTER} - {$DEFINE SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF TLIST_FAST} - {$UNDEF SORT_STRLIST_ARRAY} - {$ENDIF} - {$IFDEF _D2} - {$UNDEF SORT_STRLIST_ARRAY} - {$ENDIF} - if Count > 1 then - begin - {$IFDEF SPEED_FASTER} - if CaseSensitive then // to prepare !!! - _AnsiCompareStrA( ItemPtrs[0], ItemPtrs[1] ) - else _AnsiCompareStrNoCaseA( ItemPtrs[0], ItemPtrs[1] ); - {$ENDIF} - {$IFDEF SORT_STRLIST_ARRAY} - if CaseSensitive then - SortArray( fList.fItems, fCount, @_AnsiCompareStrA ) - else - SortArray( fList.fItems, fCount, @_AnsiCompareStrNoCaseA ); - {$ELSE} - if CaseSensitive then - SortData( @Self, fCount, @CompareAnsiStrListItems_Case, @TStrList.Swap ) - else - SortData( @Self, fCount, @CompareAnsiStrListItems, @TStrList.Swap ); - {$ENDIF} - end; -end; -{$ENDIF PAS_VERSION} - -procedure TStrList.SortEx(const CompareFun: TCompareEvent); -begin - SortData( @Self, Count, CompareFun, @TStrList.Swap ); -end; - -procedure TStrList.Swap(Idx1, Idx2: Integer); -begin - fList.Swap( Idx1, Idx2 ); -end; - -function TStrList.Last: AnsiString; -begin - if Count = 0 then - Result := '' - else - Result := Items[ Count - 1 ]; -end; - -//-- code by Dod: -function TStrList.IndexOfName(AName: Ansistring): Integer; -var i: Integer; - L: Integer; -begin - Result:=-1; - // Do not start search if empty string - L := Length( AName ); - if L > 0 then - begin - AName := LowerCase( AName ) + fNameDelim; - Inc( L ); - for i := 0 to fCount - 1 do - begin - // For optimization, check only list entry that begin with same letter as searched name - if StrLComp( PAnsiChar( LowerCase( ItemPtrs[ i ] ) ), PAnsiChar( AName ), L ) = 0 then - begin - Result:=i; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; -end; - -function TStrList.IndexOfName_NoCase(AName: Ansistring): Integer; -var i: Integer; - L: Integer; - s, p: PAnsiChar; -begin - Result:=-1; - L := Length( AName ); - if L > 0 then - begin - s := PAnsiChar( AName ); - for i := 0 to fCount - 1 do - begin - if StrLComp_NoCase( ItemPtrs[ i ], s, L ) = 0 then - begin - p := ItemPtrs[ i ]; - inc( p, L ); - while (p^ <> #0) and (p^ <= ' ') do inc( p ); - if p^ = fNameDelim then - begin - Result := i; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; - end; -end; - -//-- code by Dod: -function TStrList.GetValue(const AName: Ansistring): Ansistring; -var - i: Integer; -begin - I := IndexOfName(AName); - if I >= 0 - then Result := Copy(Items[i], Length(AName) + 2, Length(Items[i])-Length(AName)-1) - else Result := ''; -end; - -//-- code by Dod: -procedure TStrList.SetValue(const AName, Value: Ansistring); -var - I: Integer; -begin - I := IndexOfName(AName); - if i=-1 - then Add( AName + fNameDelim + Value ) - else Items[i] := AName + fNameDelim + Value; -end; - -function TStrList.GetLineName(Idx: Integer): AnsiString; -var s: AnsiString; - Q: PAnsiChar; -begin - s := ItemPtrs[ Idx ]; - Q := StrScan( PAnsiChar(s), fNameDelim ); - if Assigned(Q) {by Dufa} then Q^ := #0; - Result := PAnsiChar(s); -end; - -procedure TStrList.SetLineName(Idx: Integer; const NV: AnsiString); -begin - Items[ Idx ] := NV + fNameDelim + LineValue[ Idx ]; -end; - -function TStrList.GetLineValue(Idx: Integer): AnsiString; -var Q: PAnsiChar; -begin - Q := ItemPtrs[ Idx ]; - Q := StrScan( Q, fNameDelim ); - if Q <> nil then - inc( Q ); - Result := Q; -end; - -procedure TStrList.SetLineValue(Idx: Integer; const Value: Ansistring); -begin - Items[ Idx ] := LineName[ Idx ] + fNameDelim + Value; -end; - -function TStrList.Join( const sep: AnsiString ): AnsiString; -var - I, Len, Size: integer; - P: PAnsiChar; -begin - Size := 0; - - for I := 0 to Count - 1 do - Inc(Size, Integer( StrLen( ItemPtrs[I] ) ) + Length(Sep)); - - SetString(Result, nil, Size); - - P := @ Result[ 1 ]; - for I := 0 to Count - 1 do - begin - Len := StrLen( ItemPtrs[I] ); - if (Len > 0) then - begin - System.Move( ItemPtrs[I]^, P^, Len); - Inc(P, Len); - end; - P := StrPCopy(P, Sep); - inc( P, Length( Sep ) ); // + by Korneev Ivan - end; -end; - -{$IFDEF WIN_GDI} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TStrList.AppendToFile(const FileName: KOLString): Boolean; -var F: HFile; - Buf: AnsiString; - L: Integer; -begin - F := FileCreate( FileName, ofOpenWrite or ofOpenAlways ); - Result := F <> INVALID_HANDLE_VALUE; - if Result then - begin - FileSeek( F, 0, spEnd ); - Buf := Text; - L := Length( Buf ); - FileWrite( F, Buf[ 1 ], L ); - FileClose( F ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TStrList.LoadFromFile(const FileName: KOLString): Boolean; -var Buf: AnsiString; - F: HFile; - Sz: Integer; -begin - F := FileCreate( FileName, ofOpenRead or ofShareDenyWrite or ofOpenExisting ); - Result := F <> INVALID_HANDLE_VALUE; - if Result then - begin - Sz := GetFileSize( F, nil ); - SetString( Buf, nil, Sz ); - FileRead( F, Buf[1], Sz ); - FileClose( F ); - - SetText( Buf, False ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_STREAM} -procedure TStrList.LoadFromStream(Stream: PStream; Append2List: boolean); -asm - PUSH EAX - PUSH ECX - PUSH EBX - XCHG EAX, EDX - MOV EBX, EAX - CALL TStream.GetSize - PUSH EAX - MOV EAX, EBX - CALL TStream.GetPosition - POP ECX - SUB ECX, EAX - XOR EDX, EDX - PUSH EDX - MOV EAX, ESP - PUSH ECX - {$IFDEF _D2} - CALL _LStrFromPCharLen - {$ELSE} - {$IFDEF _D2009orHigher} - push 0 - {$ENDIF} - CALL System.@LStrFromPCharLen - {$ENDIF} - POP ECX - POP EDX - XCHG EAX, EBX - PUSH EDX - CALL TStream.Read - POP EDX - POP EBX - POP ECX - POP EAX - PUSH EDX - CALL SetText - CALL RemoveStr -end; -{$ELSE PAS_VERSION} //Pascal -procedure TStrList.LoadFromStream(Stream: PStream; Append2List: Boolean); -var Buf: AnsiString; - Sz: Integer; -begin - Sz := Stream.Size - Stream.Position; - SetString( Buf, nil, Sz ); - Stream.Read( Buf[1], Sz ); - SetText( Buf, Append2List ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TStrList.MergeFromFile(const FileName: KOLString); -var TmpStream: PStream; -begin - TmpStream := NewReadFileStream( FileName ); - LoadFromStream( TmpStream, True ); - TmpStream.Free; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TStrList.SaveToFile(const FileName: KOLString): Boolean; -var F: HFile; - Buf: AnsiString; -begin - F := FileCreate( FileName, ofOpenWrite or ofCreateAlways ); - Result := F <> INVALID_HANDLE_VALUE; - if Result then - begin - Buf := Text; - FileWrite( F, Buf[ 1 ], Length( Buf ) ); - SetEndOfFile( F ); // necessary! - V.K. - FileClose( F ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TStrList.SaveToStream(Stream: PStream); -var S: Ansistring; - L: Integer; -begin - S := GetTextStr; - L := Length( S ); - if L <> 0 then - Stream.Write( S[1], L ); -end; -{$ENDIF PAS_VERSION} - -procedure TStrList.OptimizeForRead; -begin - {$IFDEF TLIST_FAST} - if fList <> nil then - fList.OptimizeForRead; - {$ENDIF} -end; - -{$ENDIF WIN_GDI} -////////////////////////////////// EXTENDED STRING LIST OBJECT //////////////// - -{$IFDEF PAS_ONLY} -procedure WStrCopy( Dest, Src: PWideChar ); -begin - while Src^ <> #0 do - begin - Dest^ := Src^; - inc(Src); - inc(Dest); - end; -end; -{$ELSE} -procedure WStrCopy( Dest, Src: PWideChar ); -asm - PUSH EDI - PUSH ESI - MOV ESI,EAX - MOV EDI,EDX - OR ECX, -1 - XOR EAX, EAX - REPNE SCASW - NOT ECX - MOV EDI,ESI - MOV ESI,EDX - REP MOVSW - POP ESI - POP EDI -end; -{$ENDIF} - -procedure WStrLCopy( Dest, Src: PWideChar; MaxLen: Integer ); -begin - while MaxLen > 0 do - begin - Dest^ := Src^; - if Src^ = #0 then break; - inc( Dest ); - inc( Src ); - dec( MaxLen ); - if MaxLen = 0 then - Dest^ := Src^; - end; -end; - -{$IFDEF PAS_ONLY} -function WStrCmp( W1, W2: PWideChar ): Integer; -begin - while (W1^ <> #0) and (w2^ <> #0) do - begin - Result := Integer(Ord(w1^)) - Integer(Ord(w2^)); - if Result <> 0 then Exit; - inc(w1); - inc(w2); - end; - Result := 0; -end; -{$ELSE} -function WStrCmp( W1, W2: PWideChar ): Integer; -asm - PUSH ESI - PUSH EDI - XCHG ESI, EAX - MOV EDI, EDX - XOR EAX, EAX -@@loop: LODSW - MOVZX EDX, word ptr [EDI] - INC EDI - INC EDI - CMP EAX, EDX - JNE @@exit - TEST EAX, EAX - JNZ @@loop -@@exit: SUB EAX, EDX - POP EDI - POP ESI -end; -{$ENDIF} - -{$IFDEF _D3orHigher} -function WStrCmp_NoCase( W1, W2: PWideChar ): Integer; -begin - Result := 0; - while (WUpperCase( '' + W1^ ) = WUpperCase( '' + W2^ )) do - begin - if W1^ = #0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - inc( W1 ); - inc( W2 ); - end; - Result := Integer(W1^) - Integer(W2^); -end; -{$ENDIF} - -{ TStrListEx } - -function NewStrListEx: PStrListEx; -begin - new( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TStrListEx'; - {$ENDIF} -end; - -destructor TStrListEx.Destroy; -var Obj: PList; -begin - Obj := FObjects; - inherited; - Obj.Free; -end; - -function TStrListEx.GetObjects(Idx: Integer): DWORD; -begin - Result := 0; - if FObjects.fCount > Idx then - Result := DWORD( FObjects.Items[ Idx ] ); -end; - -function TStrListEx.GetObjectCount: Integer; -begin - Result := FObjects.Count; -end; - -procedure TStrListEx.SetObjects(Idx: Integer; const Value: DWORD); -begin - ProvideObjCapacity( Idx + 1 ); - FObjects.Items[ Idx ] := Pointer( Value ); -end; - -procedure TStrListEx.Init; -begin - inherited; - FObjects := NewList; -end; - -procedure SwapStrListExItems( const Sender: Pointer; const e1, e2: DWORD ); -begin - PStrListEx( Sender ).Swap( e1, e2 ); -end; - -procedure TStrListEx.AnsiSort(CaseSensitive: Boolean); -begin - fCaseSensitiveSort := CaseSensitive; - fAnsiSort := TRUE; - if CaseSensitive then - SortData( @Self, fCount, @CompareAnsiStrListItems_Case, @SwapStrListExItems ) - else - SortData( @Self, fCount, @CompareAnsiStrListItems, @SwapStrListExItems ) -end; - -procedure TStrListEx.Sort(CaseSensitive: Boolean); -begin - fCaseSensitiveSort := CaseSensitive; - fAnsiSort := FALSE; - if CaseSensitive then - SortData( @Self, fCount, @CompareStrListItems_Case, @SwapStrListExItems ) - else SortData( @Self, fCount, @CompareStrListItems_NoCase, @SwapStrListExItems ); -end; - -procedure TStrListEx.Move(CurIndex, NewIndex: integer); -begin - // move string - fList.MoveItem( CurIndex, NewIndex ); - // move object - if FObjects.fCount >= Min( CurIndex, NewIndex ) then - begin - ProvideObjCapacity( max( CurIndex, NewIndex ) + 1 ); - FObjects.MoveItem( CurIndex, NewIndex ); - end; -end; - -procedure TStrListEx.Swap(Idx1, Idx2: Integer); -begin - // swap strings - fList.Swap( Idx1, Idx2 ); - // swap objects - if FObjects.fCount >= Min( Idx1, Idx2 ) then - begin - ProvideObjCapacity( max( Idx1, Idx2 ) + 1 ); - FObjects.Swap( Idx1, Idx2 ); - end; -end; - -procedure TStrListEx.ProvideObjCapacity(NewCap: Integer); -begin - if FObjects.FCount < NewCap then - begin - {$IFDEF TLIST_FAST} - while FObjects.FCount < NewCap do - FObjects.Add( nil ); - {$ELSE} - FObjects.Capacity := NewCap; - ZeroMemory( @FObjects.{$IFDEF TLIST_FAST} Items {$ELSE} FItems {$ENDIF}[ FObjects.FCount ], - (FObjects.Capacity - FObjects.Count) * sizeof( Pointer ) ); - FObjects.FCount := NewCap; - {$ENDIF} - end; -end; - -procedure TStrListEx.AddStrings(Strings: PStrListEx); -var I: Integer; -begin - I := Count; - if Strings.FObjects.fCount > 0 then - ProvideObjCapacity( I ); - inherited AddStrings( Strings ); - if Strings.FObjects.fCount > 0 then - begin - {$IFDEF TLIST_FAST} - for I := 0 to Strings.FObjects.fCount-1 do - FObjects.Add( Strings.FObjects.Items[ I ] ); - {$ELSE} - ProvideObjCapacity( I + Strings.FObjects.fCount ); - System.Move( Strings.FObjects.fItems[ 0 ], - FObjects.FItems[ I ], - Sizeof( Pointer ) * Strings.FObjects.fCount ); - {$ENDIF} - end; -end; - -procedure TStrListEx.Assign(Strings: PStrListEx); -begin - inherited Assign( Strings ); - FObjects.Assign( Strings.FObjects ); -end; - -procedure TStrListEx.Clear; -begin - inherited; - FObjects.Clear; -end; - -procedure TStrListEx.Delete(Idx: integer); -begin - inherited; - if FObjects.fCount > Idx then // mdw: '>=' -> '>' - FObjects.Delete( Idx ); -end; - -procedure TStrListEx.DeleteLast; -var C: Integer; -begin - C := fCount; - if C <= 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - inherited; - if FObjects.fCount >= C then FObjects.Delete( C ); -end; - - -function TStrListEx.LastObj: DWORD; -begin - if Count = 0 then - Result := 0 - else - Result := Objects[ Count - 1 ]; -end; - -function TStrListEx.AddObject(const S: AnsiString; Obj: DWORD): Integer; -begin - Result := Count; - InsertObject( Count, S, Obj ); -end; - -procedure TStrListEx.InsertObject(Before: Integer; const S: AnsiString; Obj: DWORD); -begin - Insert( Before, S ); - ProvideObjCapacity( Before ); - FObjects.Insert( Before, Pointer( Obj ) ); -end; - -function TStrListEx.IndexOfObj( Obj: Pointer ): Integer; -begin - Result := FObjects.IndexOf( Obj ); -end; - -function WStrLen( W: PWideChar ): Integer; -asm - XCHG EDI, EAX - XCHG EDX, EAX - OR ECX, -1 - XOR EAX, EAX - CMP EAX, EDI - JE @@exit0 - REPNE SCASW - DEC EAX - DEC EAX - SUB EAX, ECX -@@exit0: - MOV EDI, EDX -end; - -procedure TStrListEx.OptimizeForRead; -begin - {$IFDEF TLIST_FAST} - if fList <> nil then - fList.OptimizeForRead; - if FObjects <> nil then - FObjects.OptimizeForRead; - {$ENDIF} -end; - -{$IFDEF _D3orHigher} -function UTF8_2KOLWideString( const s: AnsiString ): KOLWideString; -var Buffer: PWideChar; - L: Integer; -begin - L := Length( s ) + 1; - GetMem( Buffer, L * 2 ); - MultiByteToWideChar( CP_UTF8, 0, PAnsiChar( s ), L-1, - Buffer, L ); - Result := Buffer; - FreeMem( Buffer ); -end; -{$ENDIF _D3orHigher} - -{------------------------------------------------------------------------------) -| | -| T W S t r L i s t | -| | -(------------------------------------------------------------------------------} - -{$IFDEF WIN_GDI} -{$IFNDEF _D2} - -function NewWStrList: PWStrList; -begin - new( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TWStrList'; - {$ENDIF} -end; - -{ TWStrList } - -function TWStrList.Add(const W: KOLWideString): Integer; -begin - Result := Count; - Insert( Result, W ); -end; - -procedure TWStrList.AddWStrings(WL: PWStrList); -begin - Text := Text + WL.Text; -end; - -function TWStrList.AppendToFile(const Filename: KOLString): Boolean; -var Strm: PStream; -begin - Strm := NewReadWriteFileStream( Filename ); - Result := Strm.Handle <> INVALID_HANDLE_VALUE; - if Result then - begin - Strm.Position := Strm.Size; - SaveToStream( Strm ); - end; - Strm.Free; -end; - -procedure TWStrList.Assign(WL: PWStrList); -begin - Text := WL.Text; -end; - -procedure TWStrList.Clear; -var I: Integer; - P: Pointer; -begin - for I := 0 to Count-1 do - begin - P := fList.Items[ I ]; - if P <> nil then - if not( (P >= fText) and (P <= fText + fTextBufSz) ) then - FreeMem( P ); - end; - if fText <> nil then - FreeMem( fText ); - fText := nil; - fTextBufSz := 0; - fList.Clear; -end; - -procedure TWStrList.Delete(Idx: Integer); -var P: Pointer; -begin - P := fList.Items[ Idx ]; - if P <> nil then - if not( (P >= fText) and (P <= fText + fTextBufSz) ) then - FreeMem( P ); - fList.Delete( Idx ); -end; - -destructor TWStrList.Destroy; -begin - Clear; - fList.Free; - inherited; -end; - -function TWStrList.GetCount: Integer; -begin - Result := fList.Count; -end; - -function TWStrList.GetItems(Idx: Integer): KOLWideString; -begin - Result := PWideChar( fList.Items[ Idx ] ); -end; - -function TWStrList.GetPtrs(Idx: Integer): PWideChar; -begin - Result := fList.Items[ Idx ]; -end; - -function TWStrList.GetText: KOLWideString; -const - EoL: Array[ 0..5 ] of AnsiChar = ( #13, #0, #10, #0, #0, #0 ); // KOL_ANSI -var - L, I: Integer; - P, Dest: Pointer; -begin - L := 0; - for I := 0 to Count-1 do - begin - P := fList.Items[ I ]; - if P <> nil then - L := L + WStrLen( P ) + 2 - else - L := L + 2; - end; - SetLength( Result, L ); - Dest := PWideChar( Result ); - for I := 0 to Count-1 do - begin - P := fList.Items[ I ]; - if P <> nil then - begin - WStrCopy( Dest, P ); - Dest := Pointer( Integer( Dest ) + WStrLen( P ) * 2 ); - end; - WStrCopy( Dest, Pointer( @ EoL[ 0 ] ) ); - Dest := Pointer( Integer( Dest ) + 4 ); - end; -end; - -procedure TWStrList.Init; -begin - fList := NewList; - fNameDelim := WideChar( DefaultNameDelimiter ); -end; - -procedure TWStrList.Insert(Idx: Integer; const W: KOLWideString); -var P: Pointer; -begin - while Idx > Count do // by Misha Shar. a.k.a. kreit - fList.Add( nil ); - GetMem( P, (Length( W ) + 1) * Sizeof(WideChar) ); - fList.Insert( Idx, P ); - WStrCopy( P, PWideChar( W ) ); -end; - -function TWStrList.LoadFromFile(const Filename: KOLString): Boolean; -begin - Clear; - Result := MergeFromFile( Filename ); -end; - -procedure TWStrList.LoadFromStream(Strm: PStream; AppendToList: Boolean); -begin - if not AppendToList then Clear; - MergeFromStream( Strm ); -end; - -const - BOM : WideChar = #$FEFF; - -function TWStrList.MergeFromFile(const Filename: KOLString): Boolean; -var Strm: PStream; - DBOM: WideChar; -begin - Strm := NewReadFileStream( Filename ); - Result := Strm.Handle <> INVALID_HANDLE_VALUE; - if Result then - begin - Strm.Read(DBOM, SizeOf(DBOM)); - if DBOM<>BOM then Strm.Position := 0; - MergeFromStream( Strm ); - end; - Strm.Free; -end; - -procedure TWStrList.MergeFromStream(Strm: PStream); -var Buf: KOLWideString; - L: Integer; -begin - L := Strm.Size - Strm.Position; - {$IFDEF KOL_ASSERTIONS} - Assert( L mod 1 = 0, 'Wide strings streams must be of even length in bytes.' ); - {$ENDIF KOL_ASSERTIONS} - if L = 0 then Exit; - SetLength( Buf, L div 2 ); - Strm.Read( Buf[ 1 ], L ); - Text := Text + Buf; -end; - -procedure TWStrList.Move(IdxOld, IdxNew: Integer); -begin - fList.MoveItem( IdxOld, IdxNew ); -end; - -procedure TWStrList.Put(Idx: integer; const Value: KOLWideString); -begin - Delete( Idx ); - Insert( Idx, Value ); -end; - -function TWStrList.SaveToFile(const Filename: KOLString): Boolean; -var Strm: PStream; - DBOM: WideChar; -begin - Strm := NewWriteFileStream( Filename ); - Result := Strm.Handle <> INVALID_HANDLE_VALUE; - if Result then - begin - DBOM := BOM; - Strm.Write(DBOM, SizeOf(DBOM)); - SaveToStream( Strm ); - end; - Strm.Free; -end; - -procedure TWStrList.SaveToStream(Strm: PStream); -var Buf, Dest: PWideChar; - I, L, Sz: Integer; - P: Pointer; -begin - Sz := 0; - for I := 0 to Count-1 do - begin - P := fList.Items[ I ]; - if P <> nil then - Sz := Sz + WStrLen( P ) * 2 + 4 - else - Sz := Sz + 4; - end; - GetMem( Buf, Sz ); - Dest := Buf; - for I := 0 to Count-1 do - begin - P := fList.Items[ I ]; - if P <> nil then - begin - L := WStrLen( P ); - System.Move( P^, Dest^, L * 2 ); - Inc( Dest, L ); - end; - Dest^ := #13; - Inc( Dest ); - Dest^ := #10; - Inc( Dest ); - end; - Strm.Write( Buf^, Sz ); - FreeMem( Buf ); -end; - -procedure TWStrList.SetItems(Idx: Integer; const Value: KOLWideString); -var P: Pointer; -begin - while Idx > Count-1 do - fList.Add( nil ); - if WStrLen( ItemPtrs[ Idx ] ) > Length( Value ) then // fixed by kreit - WStrCopy( ItemPtrs[ Idx ], PWideChar( Value ) ) - else - begin - P := fList.Items[ Idx ]; - if P <> nil then - if not ((P >= fText) and (P <= fText + fTextBufSz)) then - FreeMem( P ); - GetMem( P, (Length( Value ) + 1) * Sizeof(WideChar) ); - fList.Items[ Idx ] := P; - WStrCopy( P, PWideChar( Value ) ); - end; -end; - -procedure TWStrList.SetText(const Value: KOLWideString); -var L, N: Integer; - P: PWideChar; -begin - Clear; - if Value = '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - L := (Length( Value ) + 1) * Sizeof( WideChar ); - GetMem( fText, L ); - System.Move( Value[ 1 ], fText^, L ); - fTextBufSz := Length( Value ); - fText[ fTextBufSz ] := #0; - N := 0; - P := fText; - while Word( P^ ) <> 0 do - begin - if (Word( P^ ) = 13) then - begin - Inc( N ); - PWord( P )^ := 0; - if Word( P[ 1 ] ) = 10 then - begin - Inc( P ); - //PWord( P )^ := 0; - end; - end - else - if (Word( P^ ) = 10) and ((P = fText) or (Word( P[ -1 ] ) <> 0)) then - begin - Inc( N ); - PWord( P )^ := 0; - end; - Inc( P ); - end; - fList.Capacity := N; - P := fText; - while P < fText + fTextBufSz do - begin - fList.Add( P ); - while Word( P^ ) <> 0 do Inc( P ); - Inc( P ); - if Word( P^ ) = 10 then Inc( P ); - end; -end; - -function CompareWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer; -var WL: PWStrList; -begin - WL := Sender; - Result := WStrCmp( WL.fList.Items[ Idx1 ], WL.fList.Items[ Idx2 ] ); -end; - -function CompareWStrListItems_UpperCase( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer; -var WL: PWStrList; - L1, L2, tL1, tL2: Integer; -begin - WL := Sender; - L1 := WStrLen( WL.fList.Items[ Idx1 ] ); - L2 := WStrLen( WL.fList.Items[ Idx2 ] ); - tL1 := Length( WL.fTmp1 ); - if tL1 <= L1 then - SetLength( WL.fTmp1, L1 + 1 ); - tL2 := Length( WL.fTmp2 ); - if tL2 <= L2 then - SetLength( WL.fTmp2, L2 + 1 ); - if L1 > 0 then - Move( WL.fList.Items[ Idx1 ]^, WL.fTmp1[ 1 ], (L1 + 1) * 2 ) - else - WL.fTmp1[ 1 ] := #0; - if L2 > 0 then - Move( WL.fList.Items[ Idx2 ]^, WL.fTmp2[ 1 ], (L2 + 1) * 2 ) - else - WL.fTmp2[ 1 ] := #0; - CharUpperBuffW( PWideChar( WL.fTmp1 ), L1 ); - CharUpperBuffW( PWideChar( WL.fTmp2 ), L2 ); - Result := WStrCmp( PWideChar( WL.fTmp1 ), PWideChar( WL.fTmp2 ) ); -end; - -procedure SwapWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD ); -var WL: PWStrList; -begin - WL := Sender; - WL.Swap( Idx1, Idx2 ); -end; - -procedure TWStrList.Sort( CaseSensitive: Boolean ); -begin - if CaseSensitive then - SortData( @ Self, Count, @CompareWStrListItems, @SwapWStrListItems ) - else - begin - SortData( @ Self, Count, @CompareWStrListItems_UpperCase, @SwapWStrListItems ); - fTmp1 := ''; - fTmp2 := ''; - end; -end; - -procedure TWStrList.Swap(Idx1, Idx2: Integer); -begin - fList.Swap( Idx1, Idx2 ); -end; - -function TWStrList.IndexOf( const s: KOLWideString ): Integer; -var i: Integer; - p: PWideChar; -begin - if s = '' then - begin - for i := 0 to fList.fCount-1 do - begin - p := ItemPtrs[ i ]; - if (p = nil) or - (p^ = #0) then - begin - Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end - else - begin - for i := 0 to Count-1 do - begin - p := ItemPtrs[ i ]; - if (p <> nil) and - (WStrCmp( PWideChar( s ), p ) = 0) then - begin - Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; - Result := -1; -end; - -function TWStrList.IndexOf_NoCase( const s: KOLWideString ): Integer; -var i: Integer; - p: PWideChar; -begin - if s = '' then - begin - for i := 0 to fList.fCount-1 do - begin - p := ItemPtrs[ i ]; - if (p = nil) or - (p^ = #0) then - begin - Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end - else - begin - for i := 0 to Count-1 do - begin - p := ItemPtrs[ i ]; - if (p <> nil) and - (WStrCmp_NoCase( PWideChar( s ), p ) = 0) then - begin - Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; - Result := -1; -end; - -function TWStrList.Last: KOLWideString; -begin - if Count <= 0 then Result := '' - else Result := Items[ Count-1 ]; -end; - -function NewWStrListEx: PWStrListEx; -begin - new( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TWStrListEx'; - {$ENDIF} -end; - -function TWStrList.GetLineName(Idx: Integer): KOLWideString; -var s: KOLWideString; - Q: PWideChar; -begin - s := ItemPtrs[ Idx ]; - Q := WStrScan( PWideChar(s), fNameDelim ); - Q^ := #0; - Result := PWideChar(s); -end; - -function TWStrList.GetLineValue(Idx: Integer): KOLWideString; -var Q: PWideChar; -begin - Q := ItemPtrs[ Idx ]; - Q := WStrScan( Q, fNameDelim ); - if Q <> nil then - inc( Q ); - Result := Q; -end; - -procedure TWStrList.SetLineName(Idx: Integer; const NV: KOLWideString); -var del: KOLWideString; -begin - del := fNameDelim; - Items[ Idx ] := NV + del + LineValue[ Idx ]; -end; - -procedure TWStrList.SetLineValue(Idx: Integer; const Value: KOLWideString); -var del: KOLWideString; -begin - del := fNameDelim; - Items[ Idx ] := LineName[ Idx ] + del + Value; -end; - -procedure TWStrList.OptimizeForRead; -begin - {$IFDEF TLIST_FAST} - if fList <> nil then - fList.OptimizeForRead; - {$ENDIF} -end; - -function TWStrList.IndexOfName(AName: KOLWideString): Integer; -var i: Integer; - L: Integer; - fCount: integer; -begin - Result:=-1; - L := Length( AName ); - if L > 0 then - begin - AName := WLowerCase( AName ) + fNameDelim; - Inc( L ); - fCount := GetCount - 1; - for i := 0 to fCount do - begin - if _WStrLComp( PWideChar( WLowerCase( ItemPtrs[ i ] ) ), PWideChar( AName ), L ) = 0 then - begin - Result:=i; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; -end; - -procedure TWStrList.SetValue(const AName, Value: KOLWideString); -var - I: Integer; -begin - I := IndexOfName(AName); - if i=-1 - then Add( AName + fNameDelim + Value ) - else Items[i] := AName + fNameDelim + Value; -end; - -function TWStrList.GetValue(const AName: KOLWideString): KOLWideString; -var - i: Integer; -begin - I := IndexOfName(AName); - if I >= 0 - then Result := Copy(Items[i], Length(AName) + 2, Length(Items[i])-Length(AName)-1) - else Result := ''; -end; - -{ TWStrListEx } - -function TWStrListEx.AddObject(const S: KOLWideString; Obj: DWORD): Integer; -begin - Result := Count; - InsertObject( Count, S, Obj ); -end; - -procedure TWStrListEx.AddWStrings(WL: PWStrListEx); -var I: Integer; -begin - {$IFDEF TLIST_FAST} - {$ELSE} - I := Count; - {$ENDIF} - if WL.FObjects.Count > 0 then - ProvideObjectsCapacity( Count ); - inherited AddWStrings( WL ); - if WL.FObjects.Count > 0 then - begin - {$IFDEF TLIST_FAST} - for I := 0 to WL.FObjects.Count-1 do - FObjects.Add( WL.fObjects.Items[ I ] ); - {$ELSE} - ProvideObjectsCapacity( I + WL.FObjects.Count ); - System.Move( WL.FObjects.FItems[ 0 ], - FObjects.FItems[ I ], - Sizeof( Pointer ) * WL.FObjects.Count ); - {$ENDIF} - end; -end; - -procedure TWStrListEx.Assign(WL: PWStrListEx); -begin - inherited Assign( WL ); - FObjects.Assign( WL.FObjects ); -end; - -procedure TWStrListEx.Clear; -begin - inherited Clear; - FObjects.Clear; -end; - -procedure TWStrListEx.Delete(Idx: Integer); -begin - inherited Delete( Idx ); - if FObjects.FCount >= Idx then - FObjects.Delete( Idx ); -end; - -destructor TWStrListEx.Destroy; -begin - fObjects.Free; - inherited; -end; - -function TWStrListEx.GetObjects(Idx: Integer): DWORD; -begin - Result := DWORD( fObjects.Items[ Idx ] ); -end; - -function TWStrListEx.IndexOfObj(Obj: Pointer): Integer; -begin - Result := FObjects.IndexOf( Obj ); -end; - -procedure TWStrListEx.Init; -begin - inherited; - fObjects := NewList; -end; - -procedure TWStrListEx.InsertObject(Before: Integer; const S: KOLWideString; - Obj: DWORD); -begin - Insert( Before, S ); - FObjects.Insert( Before, Pointer( Obj ) ); -end; - -procedure TWStrListEx.Move(IdxOld, IdxNew: Integer); -begin - fList.MoveItem( IdxOld, IdxNew ); - if FObjects.FCount >= Min( IdxOld, IdxNew ) then - begin - ProvideObjectsCapacity( Max( IdxOld, IdxNew ) + 1 ); - FObjects.MoveItem( IdxOld, IdxNew ); - end; -end; - -procedure SwapWStrListExItems( const Sender: Pointer; const Idx1, Idx2: DWORD ); -var WL: PWStrListEx; -begin - WL := Sender; - WL.Swap( Idx1, Idx2 ); -end; - -procedure TWStrListEx.Sort(CaseSensitive: Boolean); -begin - if CaseSensitive then - SortData( @ Self, Count, @CompareWStrListItems, @SwapWStrListExItems ) - else - begin - SortData( @ Self, Count, @CompareWStrListItems_UpperCase, @SwapWStrListExItems ); - fTmp1 := ''; - fTmp2 := ''; - end; -end; - -procedure TWStrListEx.Swap(Idx1, Idx2: Integer); -begin - inherited Swap( Idx1, Idx2 ); - if FObjects.fCount >= Min( Idx1, Idx2 ) then - begin - ProvideObjectsCapacity( max( Idx1, Idx2 ) + 1 ); - FObjects.Swap( Idx1, Idx2 ); - end; -end; - -procedure TWStrListEx.OptimizeForRead; -begin - {$IFDEF TLIST_FAST} - if fList <> nil then - fList.OptimizeForRead; - if FObjects <> nil then - FObjects.OptimizeForRead; - {$ENDIF} -end; - -procedure TWStrListEx.ProvideObjectsCapacity(NewCap: Integer); -begin - if fObjects.Capacity >= NewCap then Exit; - fObjects.Capacity := NewCap; - {$IFDEF TLIST_FAST} - {$ELSE} - ZeroMemory( @FObjects.FItems[ FObjects.Count ], - (FObjects.Capacity - FObjects.Count) * Sizeof( Pointer ) ); - FObjects.FCount := NewCap; - {$ENDIF} -end; - -procedure TWStrListEx.SetObjects(Idx: Integer; const Value: DWORD); -begin - ProvideObjectsCapacity( Idx + 1 ); - fObjects.Items[ Idx ] := Pointer( Value ); -end; - -{$ENDIF} -{$ENDIF WIN_GDI} - -function NewKOLStrList: PKOLStrList; -begin - new( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TKOLStrList'; - {$ENDIF} -end; - -function NewKOLStrListEx: PKOLStrListEx; -begin - new( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TKOLStrListEx'; - {$ENDIF} -end; - -////////////////////////////////////////////////////////////////////////// -// S O R T I N G -////////////////////////////////////////////////////////////////////////// - -{ -- qsort -- } -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure SortData( const Data: Pointer; const uNElem: Dword; - const CompareFun: TCompareEvent; - const SwapProc: TSwapEvent ); -{ uNElem - number of elements to sort } - - function Compare( const e1, e2 : DWord ) : Integer; - begin - Result := CompareFun( Data, e1 - 1, e2 - 1 ); - end; - - procedure Swap( const e1, e2 : DWord ); - begin - SwapProc( Data, e1 - 1, e2 - 1 ); - end; - - procedure qSortHelp(pivotP: Dword; nElem: Dword); - label - TailRecursion, - qBreak; - var - leftP, rightP, pivotEnd, pivotTemp, leftTemp: Dword; - lNum: Dword; - retval: integer; - begin - TailRecursion: - if (nElem <= 2) then - begin - if (nElem = 2) then - begin - rightP := pivotP +1; - retval := Compare(pivotP,rightP); - if (retval > 0) then Swap(pivotP,rightP); - end; - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - rightP := (nElem -1) + pivotP; - leftP := (nElem shr 1) + pivotP; - { sort pivot, left, and right elements for "median of 3" } - retval := Compare(leftP,rightP); - if (retval > 0) then Swap(leftP, rightP); - retval := Compare(leftP,pivotP); - - if (retval > 0) then - Swap(leftP, pivotP) - else - begin - retval := Compare(pivotP,rightP); - if retval > 0 then Swap(pivotP, rightP); - end; - if (nElem = 3) then - begin - Swap(pivotP, leftP); exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - { now for the classic Horae algorithm } - pivotEnd := pivotP + 1; - leftP := pivotEnd; - repeat - - retval := Compare(leftP, pivotP); - while (retval <= 0) do - begin - - if (retval = 0) then - begin - Swap(leftP, pivotEnd); - Inc(pivotEnd); - end; - if (leftP < rightP) then - Inc(leftP) - else - goto qBreak; - retval := Compare(leftP, pivotP); - end; {while} - while (leftP < rightP) do - begin - retval := Compare(pivotP, rightP); - if (retval < 0) then - Dec(rightP) - - else - begin - Swap(leftP, rightP); - if (retval <> 0) then - begin - Inc(leftP); - Dec(rightP); - end; - break; - end; - end; {while} - - until (leftP >= rightP); - qBreak: - retval := Compare(leftP,pivotP); - if (retval <= 0) then Inc(leftP); - - leftTemp := leftP -1; - pivotTemp := pivotP; - while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do - begin - Swap(pivotTemp, leftTemp); - Inc(pivotTemp); - Dec(leftTemp); - end; {while} - lNum := (leftP - pivotEnd); - nElem := ((nElem + pivotP) -leftP); - - if (nElem < lNum) then - begin - qSortHelp(leftP, nElem); - nElem := lNum; - end - else - begin - qSortHelp(pivotP, lNum); - pivotP := leftP; - end; - goto TailRecursion; - end; {qSortHelp } - -begin - if (uNElem < 2) then exit; { nothing to sort } {>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - qSortHelp(1, uNElem); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF _D3orHigher} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure SortArray( const Data: Pointer; const uNElem: Dword; - const CompareFun: TCompareArrayEvent ); -{ uNElem - number of elements to sort } -type TDWORDArray = array[0..0] of Integer; - PDWORDArray = ^TDWORDArray; -var DataArray: PDWORDArray; - - procedure SwapIdx( const e1, e2 : DWord ); - begin - Swap( DataArray[e1], DataArray[e2] ); - end; - - procedure qSortArrayHelp(pivotP: Dword; nElem: Dword); - label - TailRecursion, - qBreak; - var - leftP, rightP, pivotEnd, pivotTemp, leftTemp: Dword; - lNum: Dword; - retval: integer; - begin - TailRecursion: - if (nElem <= 2) then - begin - if (nElem = 2) then - begin - rightP := pivotP +1; - retval := CompareFun(DataArray[pivotP],DataArray[rightP]); - if (retval > 0) then SwapIdx(pivotP,rightP); - end; - exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - rightP := (nElem -1) + pivotP; - leftP := (nElem shr 1) + pivotP; - { sort pivot, left, and right elements for "median of 3" } - retval := CompareFun(DataArray[leftP],DataArray[rightP]); - if (retval > 0) then SwapIdx(leftP, rightP); - retval := CompareFun(DataArray[leftP],DataArray[pivotP]); - - if (retval > 0) then - SwapIdx(leftP, pivotP) - else - begin - retval := CompareFun(DataArray[pivotP],DataArray[rightP]); - if retval > 0 then SwapIdx(pivotP, rightP); - end; - if (nElem = 3) then - begin - SwapIdx(pivotP, leftP); exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - { now for the classic Horae algorithm } - pivotEnd := pivotP + 1; - leftP := pivotEnd; - repeat - - retval := CompareFun(DataArray[leftP], DataArray[pivotP]); - while (retval <= 0) do - begin - - if (retval = 0) then - begin - SwapIdx(leftP, pivotEnd); - Inc(pivotEnd); - end; - if (leftP < rightP) then - Inc(leftP) - else - goto qBreak; - retval := CompareFun(DataArray[leftP], DataArray[pivotP]); - end; {while} - while (leftP < rightP) do - begin - retval := CompareFun(DataArray[pivotP], DataArray[rightP]); - if (retval < 0) then - Dec(rightP) - - else - begin - SwapIdx(leftP, rightP); - if (retval <> 0) then - begin - Inc(leftP); - Dec(rightP); - end; - break; - end; - end; {while} - - until (leftP >= rightP); - qBreak: - retval := CompareFun( DataArray[leftP], DataArray[pivotP] ); - if (retval <= 0) then Inc(leftP); - - leftTemp := leftP -1; - pivotTemp := pivotP; - while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do - begin - SwapIdx(pivotTemp, leftTemp); - Inc(pivotTemp); - Dec(leftTemp); - end; {while} - lNum := (leftP - pivotEnd); - nElem := ((nElem + pivotP) -leftP); - - if (nElem < lNum) then - begin - qSortArrayHelp(leftP, nElem); - nElem := lNum; - end - else - begin - qSortArrayHelp(pivotP, lNum); - pivotP := leftP; - end; - goto TailRecursion; - end; {qSortHelp } - -begin - DataArray := Pointer( Integer( Data ) - Sizeof( DWORD ) ); - if (uNElem < 2) then exit; { nothing to sort } {>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - qSortArrayHelp(1, uNElem); -end; -{$ENDIF PAS_VERSION} -{$ENDIF _D3orHigher} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var I1, I2 : Integer; -begin - I1 := PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^; - I2 := PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^; - Result := 0; - if I1 < I2 then Result := -1 - else - if I1 > I2 then Result := 1; -end; -{$ENDIF PAS_VERSION} - -function Compare2Integers( e1, e2: Integer ) : Integer; -begin - Result := e1-e2; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; -var I1, I2 : DWord; -begin - I1 := PDWORD( DWORD( Sender ) + e1 * Sizeof( Integer ) )^; - I2 := PDWORD( DWORD( Sender ) + e2 * Sizeof( Integer ) )^; - Result := 0; - if I1 < I2 then Result := -1 - else - if I1 > I2 then Result := 1; -end; -{$ENDIF PAS_VERSION} - -function Compare2Dwords( e1, e2 : DWORD ) : Integer; forward; -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function Compare2Dwords( e1, e2 : DWORD ) : Integer; -begin - if e1 < e2 then - Result := -1 - else - if e1 > e2 then - Result := 1 - else - Result := 0; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD ); -var Tmp : Integer; -begin - Tmp := PInteger( DWORD( Sender ) + e1 * SizeOf( Integer ) )^; - PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^ := - PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^; - PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^ := Tmp; -end; -{$ENDIF PAS_VERSION} - -procedure SortIntegerArray( var A : array of Integer ); -begin - {$IFDEF SPEED_FASTER} - SortArray( @A[ 0 ], High(A)-Low(A)+1, @Compare2Integers ); - {$ELSE} - SortData( @A[ 0 ], High(A)-Low(A)+1, @CompareIntegers, @SwapIntegers ); - {$ENDIF} -end; - -procedure SwapListItems( const L: Pointer; const e1, e2: DWORD ); -begin - PList( L ).Swap( e1, e2 ); -end; - -procedure SortDwordArray( var A : array of DWORD ); -begin - {$IFDEF SPEED_FASTER} - SortArray( @A[ 0 ], High(A)-Low(A)+1, @Compare2DWORDS ); - {$ELSE} - SortData( @A[ 0 ], High(A)-Low(A)+1, @CompareDwords, @SwapIntegers ); - {$ENDIF} -end; -{$IFDEF WIN_GDI} - -{ -- status bar implementation -- } - -function _NewStatusbar( AParent: PControl ): PControl; forward; -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function _NewStatusbar( AParent: PControl ): PControl; -var Style: DWORD; -begin - Style := WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or 3 or WS_VISIBLE; - if {$IFDEF USE_FLAGS} G3_SizeGrip in AParent.fFlagsG3 - {$ELSE} AParent.fSizeGrip {$ENDIF} then - Style := (Style or SBARS_SIZEGRIP) and not 3; - Result := _NewCommonControl( AParent, STATUSCLASSNAME, - Style, FALSE, - {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:StatusBar'; - {$ENDIF} - with Result.fBoundsRect do - begin - Left := 0; - Right := 0; - Top := 0; - Bottom := 0; - end; - Result.fAlign := caBottom; - {$IFDEF USE_FLAGS} include( Result.fFlagsG4, G4_NotUseAlign ); - {$ELSE} Result.fNotUseAlign := True; {$ENDIF} - {$IFDEF TEST_VERSION} - Result.fTag := DWORD( PAnsiChar( 'Status bar' ) ); - {$ENDIF} - InitCommonControlSizeNotify( Result ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetStatusText(Index: Integer; const Value: KOLString); -var ch: Integer; - R : TRect; - N, I, L, W : Integer; - WidthsBuf: array[ 0..254 ] of Integer; - Val: Integer; -begin - if fStatusCtl = nil then - begin - ch := GetClientHeight; - fStatusCtl := _NewStatusBar( @Self ); - fStatusCtl.Perform( SB_SIMPLE, Integer( LongBool( Index = 255 ) ), 0 ); - GetWindowRect( {fStatusWnd}fStatusCtl.fHandle, R ); - fClientBottom := R.Bottom - R.Top; - SetClientHeight( ch ); - fStatusCtl.Perform( WM_SIZE, 0, 0 ); - end; - if Index < 255 then - begin - N := fStatusCtl.Perform( SB_GETPARTS, 0, 0 ); - if N <= Index then - begin - W := Width; - L := W div (Index + 1); - W := L; - for I := 0 to Index - 1 do - begin - WidthsBuf[ I ] := W; - Inc( W, L ); - end; - WidthsBuf[ Index ] := -1; - fStatusCtl.Perform( SB_SETPARTS, Index + 1, Integer( @WidthsBuf[ 0 ] ) ); - end; - fStatusCtl.Perform( SB_SIMPLE, 0, 0 ); - end; - Val := 0; - if Value <> '' then - Val := Integer( @ Value[1] ); - fStatusCtl.Perform( - {$IFDEF UNICODE_CTRLS} SB_SETTEXTW {$ELSE} SB_SETTEXT {$ENDIF}, Index, Val ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF noASM_UNICODE} -function TControl.GetStatusText( Index: Integer ): KOLString; -asm - MOV ECX, [EAX].fStatusCtl - JECXZ @@exit - PUSH EBX - PUSH ESI - XCHG ESI, EAX // ESI = @Self - MOV EBX, EDX // EBX = Index - XOR EAX, EAX - XCHG EAX, [ESI].fStatusTxt - TEST EAX, EAX - JZ @@1 - CALL System.@FreeMem -@@1: - XOR EAX, EAX - CDQ - MOV DL, WM_GETTEXTLENGTH - PUSH WM_GETTEXT - CMP EBX, 255 - JZ @@2 - POP EAX - MOV EAX, EBX - MOV DX, SB_GETTEXTLENGTH - PUSH SB_GETTEXT -@@2: - MOV EBX, EAX - PUSH 0 - PUSH EAX - PUSH EDX - PUSH [ESI].fStatusCtl - CALL Perform - TEST AX, AX - JZ @@get_rslt - PUSH EAX - INC EAX - CALL System.@GetMem - POP EDX - MOV [ESI].fStatusTxt, EAX - MOV byte ptr [EAX+EDX], 0 - POP EDX // Msg - PUSH EAX - PUSH EBX - PUSH EDX - PUSH [ESI].fStatusCtl - CALL Perform - PUSH EDX -@@get_rslt: - POP EDX - MOV ECX, [ESI].fStatusTxt - POP ESI - POP EBX -@@exit: XCHG EAX, ECX -end; -{$ELSE PAS_VERSION} //Pascal -function TControl.GetStatusText( Index: Integer ): KOLString; -var L, I: Integer; - Msg: DWORD; -begin - Result := ''; - if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Msg := SB_GETTEXTLENGTH; - I := Index; - if Index = 255 then - begin - Msg := WM_GETTEXTLENGTH; - I := 0; - end; - L := fStatusCtl.Perform( Msg, I, 0 ) and $FFFF; - if L > 0 then - begin - SetLength( Result, L ); - Msg := {$IFDEF UNICODE_CTRLS} SB_GETTEXTW {$ELSE} SB_GETTEXT {$ENDIF}; - if Index = 255 then - Msg := WM_GETTEXT; - fStatusCtl.Perform( Msg, I, Integer( @ Result[1] ) ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.RemoveStatus; -var ch: Integer; -begin - if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ch := ClientHeight; - fStatusCtl.Free; - fStatusCtl := nil; - fClientBottom := 0; - ClientHeight := ch; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.StatusPanelCount: Integer; -begin - Result := 0; - if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := fStatusCtl.Perform( SB_GETPARTS, 0, 0 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetStatusPanelX(Idx: Integer): Integer; -var Buf: array[0..254] of Integer; - N : Integer; -begin - Result := 0; - if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - N := fStatusCtl.Perform( SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) ); - if N <= Idx then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := Buf[ Idx ]; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetStatusPanelX(Idx: Integer; const Value: Integer); -var Buf: array[0..254] of Integer; - N : Integer; -begin - if fStatusCtl = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - N := fStatusCtl.Perform( SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) ); - if N <= Idx then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Buf[ Idx ] := Value; - fStatusCtl.Perform( SB_SETPARTS, N, Integer( @Buf[ 0 ] ) ); -end; -{$ENDIF PAS_VERSION} - -procedure TControl.SetColor1(const Value: TColor); -begin - DF.fColor1 := Value; - Invalidate; -end; - -procedure TControl.SetColor2(const Value: TColor); -begin - DF.fColor2 := Value; - Invalidate; -end; - -procedure TControl.SetGradientLayout(const Value: TGradientLayout); -begin - DF.fGradientLayout := Value; - Invalidate; -end; - -procedure TControl.SetGradientStyle(const Value: TGradientStyle); -begin - DF.fGradientStyle := Value; - Invalidate; -end; - -{ -- Image List -- } - -{$IFDEF USE_CONSTRUCTORS} -function NewImageList( AOwner: PControl ): PImageList; -begin - new( Result, CreateImageList( AOwner ) ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TImageList'; - {$ENDIF} -end; -{$ELSE not_USE_CONSTRUCTORS} -function NewImageList( AOwner: PControl ): PImageList; -begin - {*************} DoInitCommonControls( ICC_WIN95_CLASSES ); - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TImageList'; - {$ENDIF} - Result.FAllocBy := 1; - Result.FMasked := True; - Result.fBkColor := clNone; - //ImageList_SetBkColor( Result.FHandle, CLR_NONE ); - Result.FImgWidth := 32; - Result.FImgHeight := 32; - Result.FColors := ilcDefault; - - if AOwner = nil then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result.fNext := PImageList( AOwner.fImageList ); - if AOwner.fImageList <> nil then - PImageList( AOwner.fImageList ).fPrev := Result; - Result.FControl := AOwner; - {$IFDEF USE_AUTOFREE4CONTROLS} - AOwner.Add2AutoFree( Result ); - {$ENDIF} - AOwner.fImageList := Result; -end; -{$ENDIF USE_CONSTRUCTORS} - -function ImageList_Create; stdcall; external cctrl name 'ImageList_Create'; -function ImageList_Destroy; external cctrl name 'ImageList_Destroy'; -function ImageList_GetImageCount; external cctrl name 'ImageList_GetImageCount'; -function ImageList_SetImageCount; external cctrl name 'ImageList_SetImageCount'; -function ImageList_Add; external cctrl name 'ImageList_Add'; -function ImageList_ReplaceIcon; external cctrl name 'ImageList_ReplaceIcon'; -function ImageList_SetBkColor; external cctrl name 'ImageList_SetBkColor'; -function ImageList_GetBkColor; external cctrl name 'ImageList_GetBkColor'; -function ImageList_SetOverlayImage; external cctrl name 'ImageList_SetOverlayImage'; -function ImageList_Draw; external cctrl name 'ImageList_Draw'; -function ImageList_Replace; external cctrl name 'ImageList_Replace'; -function ImageList_AddMasked; external cctrl name 'ImageList_AddMasked'; -function ImageList_DrawEx; external cctrl name 'ImageList_DrawEx'; -function ImageList_Remove; external cctrl name 'ImageList_Remove'; -function ImageList_GetIcon; external cctrl name 'ImageList_GetIcon'; -{$IFDEF UNICODE_CTRLS} -function ImageList_LoadImage; external cctrl name 'ImageList_LoadImageW'; -{$ELSE} -function ImageList_LoadImage; external cctrl name 'ImageList_LoadImageA'; -{$ENDIF} -function ImageList_BeginDrag; external cctrl name 'ImageList_BeginDrag'; -function ImageList_EndDrag; external cctrl name 'ImageList_EndDrag'; -function ImageList_DragEnter; external cctrl name 'ImageList_DragEnter'; -function ImageList_DragLeave; external cctrl name 'ImageList_DragLeave'; -function ImageList_DragMove; external cctrl name 'ImageList_DragMove'; -function ImageList_SetDragCursorImage; external cctrl name 'ImageList_SetDragCursorImage'; -function ImageList_DragShowNolock; external cctrl name 'ImageList_DragShowNolock'; -function ImageList_GetDragImage; external cctrl name 'ImageList_GetDragImage'; -function ImageList_GetIconSize; external cctrl name 'ImageList_GetIconSize'; -function ImageList_SetIconSize; external cctrl name 'ImageList_SetIconSize'; -function ImageList_GetImageInfo; external cctrl name 'ImageList_GetImageInfo'; -function ImageList_Merge; external cctrl name 'ImageList_Merge'; - -function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer; -begin - Result := ImageList_ReplaceIcon(ImageList, -1, Icon); -end; - -function Index2OverlayMask(Index: Integer): Integer; -begin - Result := Index shl 8; -end; - -{ macros } -procedure ImageList_RemoveAll(ImageList: HImageList); stdcall; -begin - ImageList_Remove(ImageList, -1); -end; - -function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList; - Image: Integer): HIcon; stdcall; -begin - Result := ImageList_GetIcon(ImageList, Image, 0); -end; - -function ImageList_LoadBitmap(Instance: THandle; Bmp: PKOLChar; - CX, Grow: Integer; Mask: TColorRef): HImageList; stdcall; -begin - Result := ImageList_LoadImage(Instance, Bmp, CX, Grow, Mask, IMAGE_BITMAP, 0); -end; - -procedure FreeBmp( Bmp: HBitmap ); -begin - DeleteObject( Bmp ); -end; - -function LoadBmp( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap; -{$IFDEF LOAD_RLE_BMP_RSRCES} -var B: PBitmap; - R: PStream; -{$ENDIF} -begin - {$IFDEF LOAD_RLE_BMP_RSRCES} - R := NewMemoryStream; - Resource2Stream( R, hInstance, Rsrc, RT_BITMAP ); - B := NewBitmap( 0, 0 ); - R.Position := 0; - B.LoadFromStreamEx( R ); - R.Free; - //B.SaveToFile( GetStartDir + 'test_loadbmp.bmp' ); - Result := B.ReleaseHandle; - B.Free; - {$ELSE} - Result := LoadBitmap( Instance, Rsrc ); - {$ENDIF} - MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) ); -end; - -function LoadBmp32( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap; -var B: PBitmap; -begin - B := NewBitmap( 0, 0 ); - B.Handle := LoadBmp( Instance, Rsrc, MasterObj ); - B.PixelFormat := pf32bit; - Result := B.ReleaseHandle; - B.Free; -end; - -{ TImageList } - -function TImageList.Add(Bmp, Msk: HBitmap): Integer; -begin - Result := -1; - if not HandleNeeded then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := ImageList_Add( FHandle, Bmp, Msk ); -end; - -function TImageList.AddIcon(Ico: HIcon): Integer; -{var Bmp : HBitmap; - DC : HDC;} -begin - Result := -1; - if ImgWidth = 0 then - ImgWidth := 32; - if ImgHeight = 0 then - ImgHeight := 32; - if not HandleNeeded then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := ImageList_AddIcon( fHandle, Ico ); -end; - -function TImageList.AddMasked(Bmp: HBitmap; Color: TColor): Integer; -{$IFDEF TEST_IL} -var B: PBitmap; -{$ENDIF} -begin - Result := -1; - if not HandleNeeded then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF TEST_IL} - B := NewBitmap( 0, 0 ); - B.Handle := Bmp; - B.PixelFormat := pf32bit; - B.SaveToFile( GetStartDir + 'test_Add_masked1.bmp' ); - Bmp := B.ReleaseHandle; - B.Free; - {$ENDIF} - Result := ImageList_AddMasked( FHandle, Bmp, Color2RGB( Color ) ); - {$IFDEF TEST_IL} - B := NewBitmap( 0, 0 ); - B.Handle := GetBitmap; - B.SaveToFile( GetStartDir + 'test_Add_masked2.bmp' ); - B.ReleaseHandle; - B.Free; - B := NewBitmap( 0, 0 ); - B.Handle := GetMask; - B.SaveToFile( GetStartDir + 'test_Add_masked3.bmp' ); - B.ReleaseHandle; - B.Free; - {$ENDIF} -end; - -procedure TImageList.Clear; -begin - Handle := 0; -end; - -procedure TImageList.Delete(Idx: Integer); -begin - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ImageList_Remove( FHandle, Idx ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TImageList.Destroy; -begin - Clear; - if fNext <> nil then - fNext.fPrev := fPrev; - if fPrev <> nil then - fPrev.fNext := fNext; - if fControl <> nil then - begin - if PControl( fControl ).fImageList = @Self then - PControl( fControl ).fImageList := fNext; - {$IFDEF USE_AUTOFREE4CONTROLS} - PControl(fControl).RemoveFromAutoFree( @ Self ); - {$ENDIF} - end; - inherited; -end; -{$ENDIF PAS_VERSION} - -procedure TImageList.Draw(Idx: Integer; DC: HDC; X, Y: Integer); -begin - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ImageList_Draw( FHandle, Idx, DC, X, Y, GetDrawStyle ); -end; - -function TImageList.ExtractIcon(Idx: Integer): HIcon; -begin - Result := ImageList_ExtractIcon( 0, FHandle, Idx ); -end; - -function TImageList.ExtractIconEx(Idx: Integer): HIcon; -begin - Result := ImageList_GetIcon( FHandle, Idx, GetDrawStyle ); -end; - -function TImageList.GetBitmap: HBitmap; -var II : TImageInfo; -begin - Result := 0; - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if ImageList_GetImageInfo( FHandle, 0, II ) then - Result := II.hbmImage; -end; - -function TImageList.GetBkColor: TColor; -begin - Result := fBkColor; - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := ImageList_GetBkColor( FHandle ); -end; - -function TImageList.GetCount: Integer; -begin - Result := 0; - if FHandle <> 0 then - Result := ImageList_GetImageCount( FHandle ); -end; - -function TImageList.GetDrawStyle: DWord; -begin - Result := 0; - if dsBlend25 in DrawingStyle then - Result := Result or ILD_BLEND25; - if dsBlend50 in DrawingStyle then - Result := Result or ILD_BLEND50; - if dsTransparent in DrawingStyle then - Result := Result or ILD_TRANSPARENT - else - if dsMask in DrawingStyle then - Result := Result or ILD_MASK - {else Result := Result or ILD_NORMAL}; // ILD_NORMAL = 0 - Result := Result or WORD(FOverlayIdx shl 8); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TImageList.GetHandle: THandle; -begin - HandleNeeded; - Result := FHandle; -end; -{$ENDIF PAS_VERSION} - -function TImageList.GetMask: HBitmap; -var II : TImageInfo; -begin - Result := 0; - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if ImageList_GetImageInfo( FHandle, 0, II ) then - Result := II.hbmMask; -end; - -{$IFDEF ASM_noVERSION} -function TImageList.HandleNeeded: Boolean; -const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR, - ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24, - ILC_COLOR32, ILC_COLORDDB ); -asm - MOV ECX, [EAX].FHandle - JECXZ @@make_handle - MOV AL, 1 - RET -@@make_handle: - MOV ECX, [EAX].fImgWidth - JECXZ @@ret_ECX - MOV EDX, ECX - MOV ECX, [EAX].fImgHeight - JECXZ @@ret_ECX - PUSH EBX - XCHG EBX, EAX - - PUSH [EBX].FAllocBy - PUSH 0 - MOVZX EAX, [EBX].FColors - MOVZX EAX, byte ptr [ColorFlags+EAX] - CMP [EBX].FMasked, 0 - JZ @@flags_ready - {$IFDEF PARANOIA} DB $0C, $01 {$ELSE} OR AL, 1 {$ENDIF} -@@flags_ready: - PUSH EAX - PUSH ECX - PUSH EDX - CALL ImageList_Create - MOV [EBX].FHandle, EAX - XCHG ECX, EAX - POP EBX -@@ret_ECX: - TEST ECX, ECX - SETNZ AL -end; -{$ELSE PAS_VERSION} //Pascal -function TImageList.HandleNeeded: Boolean; -const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR, - ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24, - ILC_COLOR32, ILC_COLORDDB, 0 ); -var Flags : DWord; -begin - Result := True; - if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := False; - if ImgWidth = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if ImgHeight = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Flags := ColorFlags[ FColors ]; - if Masked then - Flags := Flags or ILC_MASK; - FHandle := ImageList_Create( ImgWidth, ImgHeight, Flags, 0, FAllocBy ); - if fBkColor <> clNone then - SetBkColor( fBkColor ); - Result := FHandle <> 0; -end; -{$ENDIF PAS_VERSION} - -function TImageList.ImgRect(Idx: Integer): TRect; -var II : TImageInfo; -begin - Result := MakeRect( 0, 0, 0, 0 ); - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if ImageList_GetImageInfo( FHandle, Idx, II ) then - Result := II.rcImage; -end; - -{$IFDEF ASM_noVERSION_UNICODE} -function TImageList.LoadBitmap(ResourceName: PAnsiChar; - TranspColor: TColor): Boolean; -asm - PUSH EBX - XCHG EBX, EAX - XCHG EAX, ECX //TranspColor - PUSH EDX - CMP EAX, clNone - JNE @@2rgb - OR EAX, -1 - JMP @@tranColorReady -@@2rgb: - CALL Color2RGB -@@tranColorReady: - POP EDX - PUSH EAX - PUSH [EBX].fAllocBy - PUSH [EBX].fImgWidth - PUSH EDX - PUSH [hInstance] - CALL ImageList_LoadBitmap - TEST EAX, EAX - JZ @@exit - XCHG EDX, EAX - XCHG EAX, EBX - CALL SetHandle - MOV AL, 1 -@@exit: POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function TImageList.LoadBitmap(ResourceName: PKOLChar; - TranspColor: TColor): Boolean; -var NewHandle : THandle; - TranColr: TColor; -begin - TranColr := TranspColor; - if TranColr = clNone then TranColr := TColor( CLR_NONE ) - else TranColr := Color2RGB( TranColr ); - NewHandle := ImageList_LoadBitmap( hInstance, ResourceName, - ImgWidth, AllocBy, TranColr ); - //ImageList_GetIconSize( NewHandle, fImgWidth, fImgHeight ); - Result := NewHandle <> 0; - if Result then - Handle := NewHandle; - ImageList_GetIconSize( fHandle, FImgWidth, FImgHeight ); -end; -{$ENDIF PAS_VERSION} - -function TImageList.LoadFromFile(FileName: PKOLChar; TranspColor: TColor; - ImgType: TImageType): Boolean; -const ImgTypes:array[ TImageType ] of DWord = ( IMAGE_BITMAP, IMAGE_ICON, IMAGE_CURSOR ); -var NewHandle : THandle; - TranspFlag : DWord; -begin - TranspFlag := 0; - if TranspColor <> clNone then - TranspFlag := LR_LOADTRANSPARENT; - NewHandle := ImageList_LoadImage( hInstance, FileName, ImgWidth, AllocBy, - Color2RGB( TranspColor ), ImgTypes[ ImgType ], - LR_LOADFROMFILE or LR_CREATEDIBSECTION or TranspFlag ); - Result := NewHandle <> 0; - if Result then - Handle := NewHandle; -end; - -function TImageList.LoadSystemIcons(SmallIcons: Boolean): Boolean; -var NewHandle : THandle; - FileInfo : TSHFileInfo; - Flags : DWord; -begin - OleInit; - Flags := SHGFI_SYSICONINDEX; - if SmallIcons then - Flags := Flags or SHGFI_SMALLICON; - NewHandle := {$IFDEF UNICODE_CTRLS} SHGetFileInfoW {$ELSE} SHGetFileInfoA {$ENDIF} - ( '', 0, FileInfo, Sizeof( FileInfo ), Flags ); - Result := NewHandle <> 0; - if Result then - begin - Handle := NewHandle; - FShareImages := True; - end; -end; - -function TImageList.Merge(Idx: Integer; ImgList2: PImageList; Idx2, X, - Y: Integer): PImageList; -var L : THandle; -begin - Result := nil; - L := ImageList_Merge( FHandle, Idx, ImgList2.Handle, Idx2, X, Y ); - if L <> 0 then - begin - Result := NewImageList( fControl ); - Result.Handle := L; - end; -end; - -function TImageList.Replace(Idx: Integer; Bmp, Msk: HBitmap): Boolean; -begin - Result := False; - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := ImageList_Replace( FHandle, Idx, Bmp, Msk ); -end; - -function TImageList.ReplaceIcon(Idx: Integer; Ico: HIcon): Boolean; -begin - Result := False; - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := ImageList_ReplaceIcon( FHandle, Idx, Ico ) >= 0; -end; - -procedure TImageList.SetAllocBy(const Value: Integer); -begin - if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // AllocBy can be changed only before adding images and creating handle - FAllocBy := Value; -end; - -procedure TImageList.SetBkColor(const Value: TColor); -begin - fBkColor := Value; - if fHandle <> 0 then - ImageList_SetBkColor( FHandle, Color2RGB( Value ) ); -end; - -procedure TImageList.SetColors(const Value: TImageListColors); -begin - if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FColors := Value; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TImageList.SetHandle(const Value: THandle); -begin - if FHandle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (FHandle <> 0) and not FShareImages then - ImageList_Destroy( FHandle ); - FHandle := Value; - if FHandle <> 0 then - ImageList_GetIconSize( FHandle, FImgWidth, FImgHeight ) - else - begin - FImgWidth := 0; - FImgHeight := 0; - end; -end; -{$ENDIF PAS_VERSION} - -procedure TImageList.SetImgHeight(const Value: Integer); -begin - if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FImgHeight := Value; -end; - -procedure TImageList.SetImgWidth(const Value: Integer); -begin - if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FImgWidth := Value; -end; - -procedure TImageList.SetMasked(const Value: Boolean); -begin - if FHandle <> 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FMasked := Value; -end; - -function TImageList.GetOverlay(Idx: TImgLOVrlayIdx): Integer; -begin - Result := fOverlay[ Idx ]; -end; - -procedure TImageList.SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer); -begin - if ImageList_SetOverlayImage( fHandle, Value, Idx shl 8 ) then - fOverlay[ Idx ] := Value; -end; - -procedure TImageList.StretchDraw(Idx: Integer; DC: HDC; const Rect: TRect); -begin - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - ImageList_DrawEx( FHandle, Idx, DC, Rect.Left, Rect.Top, - Rect.Right- Rect.Left, Rect.Bottom-Rect.Top, - BkColor, BlendColor, GetDrawStyle ); -end; - -function GetImgListSize( Sender: PControl; Size: Integer ): PImageList; -begin - if Size > 16 then - Result := Sender.DF.fCtlImageListNormal - else - Result := Sender.DF.fCtlImageListSml; - if Result <> nil then - begin - if Result.fImgWidth = 0 then - Result.ImgWidth := Size; - if Result.fImgHeight = 0 then - Result.ImgHeight := Size; - end; - if Result = nil then - begin - Result := Sender.fImageList; - while Result <> nil do - begin - if (Result.FImgWidth = Size) and (Result.FImgHeight = Size) then - break; - Result := Result.fNext; - end; - end; -end; - -function TControl.GetImgListIdx(const Index: Integer): PImageList; -begin - if Index <> 0 then - Result := GetImgListSize( @Self, Index ) - else - begin - Result := DF.fCtlImgListState; - if Result = nil then - begin - Result := fImageList; - while Result <> nil do - begin - if (Result <> GetImgListIdx( 16 )) and (Result <> GetImgListIdx( 32 )) then - break; - Result := Result.fNext; - end; - end; - end; -end; - -procedure TControl.SetImgListIdx(const Index: Integer; - const Value: PImageList); -begin - - if Value <> nil then - begin - if Index <> 0 then - if (Value.ImgWidth = 0) or (Value.ImgHeight = 0) then - begin - Value.ImgWidth := Index; - Value.ImgHeight := Index; - end; - end; - - case Index of - 32: DF.fCtlImageListNormal := Value; - 16: DF.fCtlImageListSml := Value; - else DF.fCtlImgListState := Value; - end; - ApplyImageLists2Control( @Self ); -end; - -{ -- list view -- } - -function WndProcEndLabelEdit( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var NMhdr: PNMHdr; - LVDisp: PLVDispInfo; - Flag: Boolean; -begin - Result := False; - if Msg.message = WM_NOTIFY then - begin - NMHdr := Pointer( Msg.lParam ); - case NMHdr.code of - LVN_ENDLABELEDIT: - begin - LVDisp := Pointer( Msg.lParam ); - Result := True; - if LVDisp.item.pszText = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Rslt := 1; - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnEndEditLVItem ) then - {$ENDIF} - begin - Flag := Self_.EV.fOnEndEditLVItem( Self_, LVDisp.item.iItem, - LVDisp.item.iSubItem, LVDisp.item.pszText ); - if Flag then Rslt := 1 - else Rslt := 0; - end; - end; - end; - end; -end; - -procedure TControl.SetOnEndEditLVItem(const Value: TOnEditLVItem); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnEndEditLVITem := Value; - AttachProc( WndProcEndLabelEdit ); -end; - -procedure TControl.LVColAdd(const aText: KOLString; aalign: TTextAlign; - aWidth: Integer); -begin - LVColInsert( DF.fLVColCount, aText, aalign, aWidth );// 21.10.2001 -end; - -//****************** changed by Mike Gerasimov -procedure TControl.LVColInsert(ColIdx: Integer; const aText: KOLString; - aAlign: TTextAlign; aWidth: Integer); -var LVColData: TLVColumn; -begin - LVColData.mask := LVCF_FMT or LVCF_TEXT; - if ImageListSmall <> nil then - LVColData.mask := LVColData.mask; // or LVCF_IMAGE ; - LVColData.iImage := -1; - LVColData.fmt := Ord( aAlign ); - if aWidth < 0 then - begin - aWidth := -aWidth; - LVColData.fmt := LVColData.fmt or LVCFMT_BITMAP_ON_RIGHT; - end; - LVColData.cx := aWidth; - if aWidth > 0 then - LVColData.mask := LVColData.mask or LVCF_WIDTH; - LVColData.pszText := PKOL_Char( aText ); - if Perform( LVM_INSERTCOLUMN, ColIdx, Integer( @LVColData ) ) >= 0 then - Inc( DF.fLVColCount ); -end; - -function TControl.GetLVColText(Idx: Integer): KOLString; -var Buf: array[ 0..4095 ] of KOLChar; - LC: TLVColumn; -begin - LC.mask := LVCF_TEXT; - LC.pszText := @ Buf[ 0 ]; - LC.cchTextMax := 4096; - Buf[ 0 ] := #0; - Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) ); - Result := Buf; -end; - -procedure TControl.SetLVColText(Idx: Integer; const Value: KOLString); -var LC: TLVColumn; -begin - ZeroMemory( @LC, Sizeof( LC ) ); {Alexey (Lecha2002)} - LC.mask := LVCF_TEXT; - LC.pszText := ''; - if Value <> '' then - LC.pszText := @ Value[ 1 ]; - Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) ); -end; - -function TControl.GetLVColalign(Idx: Integer): TTextAlign; -const Formats: array[ 0..2 ] of TTextAlign = ( taLeft, taRight, taCenter ); -var LC: TLVColumn; -begin - ZeroMemory( @LC, Sizeof( LC ) ); {Alexey (Lecha2002)} - LC.mask := LVCF_FMT; - Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) ); - Result := Formats[ LC.fmt and LVCFMT_JUSTIFYMASK ]; -end; - -procedure TControl.SetLVColalign(Idx: Integer; const Value: TTextAlign); -const FormatFlags: array[ TTextAlign ] of BYTE = ( LVCFMT_LEFT, LVCFMT_RIGHT, - LVCFMT_CENTER ); -var LC: TLVColumn; -begin - ZeroMemory( @LC, Sizeof( LC ) ); {Alexey (Lecha2002)} - LC.mask := LVCF_FMT; - Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) ); - LC.fmt := LC.fmt and not LVCFMT_JUSTIFYMASK or FormatFlags[ Value ]; - Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) ); -end; - -function TControl.GetLVColEx(Idx: Integer; const Index: Integer): Integer; -var LC: TLVColumn; -begin - ZeroMemory( @LC, Sizeof( LC ) ); {Alexey (Lecha2002)} - LC.mask := LoWord( Index ); - Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) ); - Result := PDWORD( Integer( @ LC ) + HiWord( Index ) )^; -end; - -//********************** changed by Mike Gerasimov -procedure TControl.SetLVColEx(Idx: Integer; const Index: Integer; - const Value: Integer); -var LC: TLVColumn; -begin - ZeroMemory(@LC,SizeOf(LC)); // Added Line - LC.mask := LoWord( Index ); - if HiWord( Index ) = 24 then // Added Line - begin // Added Line - LC.mask := LC.mask or LVCF_FMT; // Added Line - if Value <>-1 then // Added Line - LC.fmt := LC.fmt or LVCFMT_IMAGE or LVCFMT_COL_HAS_IMAGES // Added Line - else LC.mask := LC.mask and not LVCF_IMAGE; // + by non - end; - if (value<>-1)or(HiWord( Index )<>24) then // + by non - PDWORD( Integer( @ LC ) + HiWord( Index ) )^ := Value; - Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) ); -end; - -function TControl.LVAdd(const aText: KOLString; ImgIdx: Integer; - State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; - Data: DWORD): Integer; -begin - Result := LVInsert( MaxInt {Count}, aText, ImgIdx, State, StateImgIdx, OverlayImgIdx, Data ); -end; - -function TControl.LVInsert(Idx: Integer; const aText: KOLString; - ImgIdx: Integer; State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; - Data: DWORD): Integer; -const - LVM_REDRAWITEMS = LVM_FIRST + 21; -var LVI: TLVItem; -begin - LVI.mask := LVIF_TEXT or LVIF_IMAGE or LVIF_PARAM or LVIF_STATE - or LVIF_DI_SETITEM; - LVI.iItem := Idx; - LVI.iSubItem := 0; - LVI.state := 0; - if lvisBlend in State then - LVI.state := LVIS_CUT; - if lvisHighlight in State then - LVI.state := LVI.state or LVIS_DROPHILITED; - if lvisFocus in State then - LVI.state := LVI.state or LVIS_FOCUSED; - if lvisSelect in State then - LVI.state := LVI.state or LVIS_SELECTED; - LVI.stateMask := $FFFF; - if StateImgIdx <> 0 then - LVI.state := LVI.state or ((StateImgIdx and $F) shl 12); - if OverlayImgIdx <> 0 then - LVI.state := LVI.state or ((OverlayImgIdx and $F) shl 8); - LVI.pszText := PKOL_Char( aText ); - LVI.iImage := ImgIdx; - LVI.lParam := Data; - Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) ); -end; - -procedure TControl.LVSetItem(Idx, Col: Integer; const aText: KOLString; - ImgIdx: Integer; State: TListViewItemState; StateImgIdx, - OverlayImgIdx: Integer; Data: DWORD); -var LVI: TLVItem; - {$IFDEF KOL_ASSERTIONS} I: Integer; {$ENDIF} -begin - LVI.mask := LVIF_TEXT or {LVIF_STATE or} LVIF_DI_SETITEM; - if Col = 0 then - begin - LVI.mask := LVIF_TEXT or LVIF_STATE or LVIF_PARAM - or LVIF_DI_SETITEM; - end; - if ImgIdx <> I_SKIP then - LVI.mask := LVI.mask or LVIF_IMAGE; - if ImgIdx < I_SKIP then - LVI.mask := LVIF_TEXT or LVIF_DI_SETITEM; - LVI.iItem := Idx; - LVI.iSubItem := Col; - LVI.state := 0; - if lvisBlend in State then - LVI.state := LVIS_CUT; - if lvisHighlight in State then - LVI.state := LVI.state or LVIS_DROPHILITED; - if lvisFocus in State then - LVI.state := LVI.state or LVIS_FOCUSED; - if lvisSelect in State then - LVI.state := LVI.state or LVIS_SELECTED; - LVI.stateMask := $FFFF; - if StateImgIdx <> 0 then - LVI.state := LVI.state or ((StateImgIdx and $F) shl 12); - if StateImgIdx < 0 {= I_SKIP} then - LVI.stateMask := $F0FF; - if OverlayImgIdx <> 0 then - LVI.state := LVI.state or ((OverlayImgIdx and $F) shl 8); - if OverlayImgIdx < 0 {=I_SKIP} then - LVI.stateMask := LVI.stateMask and $FFF; - LVI.pszText := PKOL_Char( aText ); - LVI.iImage := ImgIdx; - LVI.lParam := Data; - {$IFDEF KOL_ASSERTIONS} I := {$ENDIF} - Perform( LVM_SETITEM, 0, Integer( @LVI ) ); - {$IFDEF KOL_ASSERTIONS} - if (I = 0) and (Col = 0) then - Assert( False, 'Can not set item ' ); - {$ENDIF KOL_ASSERTIONS} -end; - -procedure LVGetItem( Sender: PControl; Idx, Col: Integer; var LVI: TLVItem; - TextBuf: PKOL_Char; TextBufSize: Integer ); -begin - LVI.mask := LVIF_STATE or LVIF_PARAM or LVIF_IMAGE; - if Col > 0 then - if not (lvoSubItemImages in Sender.DF.fLVOptions) then - LVI.mask := LVIF_STATE or LVIF_PARAM; - LVI.iItem := Idx; - LVI.iSubItem := Col; - LVI.pszText := TextBuf; - LVI.cchTextMax := TextBufSize; - if TextBufSize <> 0 then - LVI.mask := LVI.mask or LVIF_TEXT; - Sender.Perform( LVM_GETITEM, 0, Integer( @LVI ) ); -end; - -function TControl.LVGetItemImgIdx(Idx: Integer): Integer; -var LVI: TLVItem; -begin - LVI.iImage := -1;//= Result if image is not assigned {Andrzej Kubaszek} - LVGetItem( @Self, Idx, 0, LVI, nil, 0 ); - Result := LVI.iImage; -end; - -procedure TControl.LVSetItemImgIdx(Idx: Integer; const Value: Integer); -var LVI: TLVItem; -begin - LVGetItem( @Self, Idx, 0, LVI, nil, 0 ); - LVI.iImage := Value; - Perform( LVM_SETITEM, 0, Integer( @LVI ) ); -end; - -function TControl.LVGetItemText(Idx, Col: Integer): KOLString; -var LVI: TLVItem; - TextBuf: PKOL_Char; - BufSize: Integer; -begin - BufSize := 0; - TextBuf := nil; - repeat - if TextBuf <> nil then - FreeMem( TextBuf ); - BufSize := BufSize * 2 + 100; // to vary in asm version - GetMem( TextBuf, BufSize * Sizeof( KOLChar ) ); - TextBuf[ 0 ] := #0; - LVGetItem( @Self, Idx, Col, LVI, TextBuf, BufSize ); - until Integer({$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF} - ( PKOLChar( TextBuf ) )) < BufSize - 1; - Result := TextBuf; - FreeMem( TextBuf ); -end; - -procedure TControl.LVSetItemText(Idx, Col: Integer; const Value: KOLString); -var LVI: TLVItem; -begin - LVI.iSubItem := Col; - LVI.pszText := PKOL_Char( Value ); - Perform( LVM_SETITEMTEXT, Idx, Integer( @LVI ) ); -end; - -procedure TControl.LVColDelete(ColIdx: Integer); -begin - Perform( LVM_DELETECOLUMN, ColIdx, 0 ); - if DF.fLVColCount > 0 then - Dec( DF.fLVColCount ); -end; - -procedure TControl.SetLVOptions(const Value: TListViewOptions); -begin - if DF.fLVOptions = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DF.fLVOptions := Value; - ApplyImageLists2ListView( @Self ); - PostMessage( fHandle, WM_SIZE, 0, 0 ); // to restore scrollers (otherwise its are lost) -end; - -procedure TControl.SetLVStyle(const Value: TListViewStyle); -begin - if DF.fLVStyle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DF.fLVStyle := Value; - ApplyImageLists2ListView( @Self ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.Perform(msgcode: DWORD; wParam, lParam: Integer): Integer; stdcall; -begin - {$IFDEF INPACKAGE} - Log( '->TControl.Perform' ); - TRY - {$ENDIF INPACKAGE} - Result := SendMessage( GetWindowHandle, msgcode, wParam, lParam ); - {$IFDEF INPACKAGE} - LogOK; - FINALLY - Log( '<-TControl.Perform' ); - END; - {$ENDIF INPACKAGE} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.Postmsg(msgcode: DWORD; wParam, lParam: Integer): Boolean; stdcall; -begin - Result := PostMessage( GetWindowHandle, msgcode, wParam, lParam ); -end; -{$ENDIF PAS_VERSION} - -{$ENDIF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.GetChildCount: Integer; -begin - Result := fChildren.Count; -end; -{$ENDIF PAS_VERSION} -{$IFDEF WIN_GDI} - -procedure TControl.LVDelete(Idx: Integer); -begin - Perform( LVM_DELETEITEM, Idx, 0 ); -end; - -procedure TControl.LVEditItemLabel(Idx: Integer); -begin - Perform( LVM_EDITLABEL, Idx, 0 ); -end; - -function TControl.LVItemRect(Idx: Integer; Part: TGetLVItemPart): TRect; -const Parts: array[ TGetLVItemPart ] of Byte = ( - LVIR_BOUNDS, LVIR_ICON, LVIR_LABEL, LVIR_SELECTBOUNDS ); -begin - Result := MakeRect( Parts[ Part ], 0, 0, 0 ); - if Perform( LVM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then - Result := MakeRect( 0, 0, 0, 0 ); -end; - -function TControl.LVSubItemRect(Idx, ColIdx: Integer): TRect; -var Hdr: HWnd; - R, R1: TRect; - ClassNameBuf: array[ 0..31 ] of KOLChar; - HdItem: THDItem; -begin - Result.Top := ColIdx; // + 1; error in MSDN ? - Result.Left := LVIR_BOUNDS; - if Perform( LVM_GETSUBITEMRECT, Idx, Integer( @Result ) ) <> 0 then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := MakeRect( 0, 0, 0, 0 ); - if ColIdx > 0 then R := LVSubItemRect( Idx, ColIdx - 1 ) - else R := LVItemRect( Idx, lvipBounds ); - if (R.Left = 0) and (R.Right = 0) and - (R.Top = 0) and (R.Bottom = 0) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Hdr := GetWindow( GetWindowHandle, GW_CHILD ); - if Hdr <> 0 then - begin - if GetClassName( Hdr, ClassNameBuf, 32 ) > 0 then - if ClassNameBuf = 'SysHeader32' then - begin - if ColIdx > 0 then R.Left := R.Right - else R.Left := 0; - R1.Top := 0; R1.Left := 0; - Windows.ClientToScreen( Hdr,{$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} ); - Windows.ScreenToClient( fHandle, {$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} ); - R1 := R; - HdItem.Mask := HDI_WIDTH; - if SendMessage( Hdr, HDM_GETITEM, ColIdx, Integer( @HdItem ) ) = 0 then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - R1.Right := R1.Left + HdItem.cxy; - Result := R1; - end; - end; -end; - -function TControl.LVGetItemPos(Idx: Integer): TPoint; -begin - Perform( LVM_GETITEMPOSITION, Idx, Integer( @Result ) ); -end; - -procedure TControl.LVSetItemPos(Idx: Integer; const Value: TPoint); -begin - Perform( LVM_SETITEMPOSITION32, Idx, Integer( @Value ) ); -end; - -function TControl.LVItemAtPos(X, Y: Integer): Integer; -var Dummy: TWherePosLVItem; -begin - Result := LVItemAtPosEx( X, Y, Dummy ); -end; - -function TControl.LVItemAtPosEx(X, Y: Integer; - var Where: TWherePosLVItem): Integer; -var HTI: TLVHitTestInfo; -begin - HTI.pt.x := X; - HTI.pt.y := Y; - Perform( LVM_HITTEST, 0, Integer( @HTI ) ); - Result := HTI.iItem; - Where := lvwpOnColumn; - if HTI.flags = LVHT_ONITEMICON then - Where := lvwpOnIcon - else - if HTI.flags = LVHT_ONITEMLABEL then - Where := lvwpOnLabel - else - if HTI.flags = LVHT_ONITEMSTATEICON then - Where := lvwpOnStateIcon - else - if HTI.flags = LVHT_ONITEM then - Where := lvwpOnItem; -end; - -procedure TControl.LVMakeVisible(Item: Integer; PartiallyOK: Boolean); -begin - if Item < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Perform( LVM_ENSUREVISIBLE, Item, Integer( PartiallyOK ) ); -end; - -procedure TControl.LVSetColorByIdx(const Index: Integer; - const Value: TColor); -var MsgCode: Integer; - ColorValue: TColor; -begin - MsgCode := Index + 1; - case MsgCode of - LVM_SETTEXTCOLOR: fTextColor := Value; - LVM_SETTEXTBKCOLOR: DF.fLVTextBkColor := Value; - LVM_SETBKCOLOR: fColor := Value; - end; - ColorValue := Color2RGB( Value ); - Perform( MsgCode, 0, ColorValue ); -end; - -{$IFDEF F_P} -function TControl.LVGetColorByIdx(const Index: Integer): TColor; -begin - CASE Index OF - LVM_SETTEXTCOLOR: Result := fTextColor; - LVM_SETTEXTBKCOLOR: Result := fLVTextBkColor; - LVM_SETBKCOLOR: Result := fColor; - END; -end; -{$ENDIF F_P} - -function TControl.GetIntVal(const Index: Integer): Integer; -begin - Result := GetItemVal( 0, Index ); -end; - -procedure TControl.SetIntVal(const Index, Value: Integer); -begin - SetItemVal( Value, Index, 0 ); -end; - -function TControl.GetItemVal(Item: Integer; const Index: Integer): Integer; -begin - Result := Perform( LoWord(Index), Item, 0 ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.SetItemVal(Item: Integer; const Index: Integer; const Value: Integer); -var MsgCode: Integer; -begin - MsgCode := HiWord( Index ); - if MsgCode = 0 then - MsgCode := Index + 1; - Perform( MsgCode and $7FFF, Item, Value ); - if (MsgCode and $8000) <> 0 then - Invalidate; -end; -{$ENDIF PAS_VERSION} - -function TControl.GetSBMinMax: TPoint; -{$IFDEF _D2} -var X, Y: Integer; -{$ENDIF} -begin - if (Handle <> 0) then begin - {$IFDEF _D2} - GetScrollRange(Handle, SB_CTL, X, Y); - Result.X := X; - Result.Y := Y; - {$ELSE} - GetScrollRange(Handle, SB_CTL, Result.X, Result.Y); - {$ENDIF} - Dec(Result.Y, SBPageSize - 1); - end - else - Result := DF.fSBMinMax; -end; - -function TControl.GetSBPageSize: Integer; -var - SI: TScrollInfo; -begin - ZeroMemory(@SI, SizeOf(SI)); - SI.cbSize := SizeOf(SI); - SI.fMask := SIF_PAGE; - SBGetScrollInfo(SI); - Result := SI.nPage; -end; - -function TControl.GetSBPosition: Integer; -begin - Result := GetScrollPos(Handle, SB_CTL); -end; - -procedure TControl.SetSBMax(Value: Longint); -var - P: TPoint; -begin - DF.fSBMinMax.Y := Value; - if (Handle <> 0) then - begin - P := SBMinMax; - P.Y := Value; - SBMinMax := P; - end; -end; - -procedure TControl.SetSBMin(Value: Longint); -var - P: TPoint; -begin - DF.fSBMinMax.X := Value; - if (Handle <> 0) then - begin - P := SBMinMax; - P.X := Value; - SBMinMax := P; - end; -end; - -procedure TControl.SetSBPageSize(Value: Integer); -var - SI: TScrollInfo; -begin - DF.fSBPageSize := Value; - if fHandle <> 0 then - begin - ZeroMemory(@SI, SizeOf(SI)); - SI.cbSize := SizeOf(SI); - SI.fMask := SIF_PAGE or SIF_RANGE; - SBGetScrollInfo(SI); - {$IFDEF SCROLL_OLD} // by QAZ - {$IFDEF SCROLL_OLD_MAX1} - if (SI.nMax = 0) and (SI.nMin = 0) then - SI.nMax := 1; - {$ENDIF} - SI.nMax := SI.nMax - Integer(SI.nPage) + Value; - {$ENDIF} - SI.nPage := Value; - SBSetScrollInfo(SI); - end; -end; - -procedure TControl.SetSBPosition(Value: Integer); -begin - DF.fSBPosition := Value; - if (Handle <> 0) then - SetScrollPos(Handle, SB_CTL, Value, True); -end; - -procedure TControl.SetSBMinMax(const Value: TPoint); -begin - GetSBMinMax; - if (Handle <> 0) then - SetScrollRange(Handle, SB_CTL, Value.X, - Value.Y {$IFDEF SCROLL_OLD} + SBPageSize - 1{$ENDIF (by QAZ)} , True) - else - DF.fSBMinMax := Value; -end; - -function TControl.SBSetScrollInfo(const SI: TScrollInfo): Integer; -begin - Result := SetScrollInfo(Handle, SB_CTL, SI, True) -end; - -function TControl.SBGetScrollInfo(var SI: TScrollInfo): Boolean; -begin - Result := Cardinal(GetScrollInfo(Handle, SB_CTL, SI)) <> 0; -end; - -{ -- OpenSaveDialog -- } - -function NewOpenSaveDialog( const Title, StrtDir: KOLString; - Options: TOpenSaveOptions ): POpenSaveDialog; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TOpenSaveDialog'; - {$ENDIF} - Result.FOptions := Options; - if Options = [] then - Result.FOptions := DefOpenSaveDlgOptions; - Result.fOpenDialog := True; - Result.FTitle := Title; - Result.FInitialDir := StrtDir; -end; - -{ TOpenSaveDialog } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TOpenSaveDialog.Destroy; -begin - FFilter := ''; - FInitialDir := ''; - FDefExtension := ''; - FFileName := ''; - FTitle := ''; - {$IFDEF OpenSaveDialog_Extended} - TemplateName := ''; - {$ENDIF} - inherited; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TOpenSaveDialog.Execute: Boolean; -const OpenSaveFlags: array[ TOpenSaveOption ] of Integer = ( - OFN_CREATEPROMPT, - OFN_EXTENSIONDIFFERENT, - OFN_FILEMUSTEXIST, - OFN_HIDEREADONLY, - OFN_NOCHANGEDIR, - OFN_NODEREFERENCELINKS, - OFN_ALLOWMULTISELECT, - OFN_NONETWORKBUTTON, - OFN_NOREADONLYRETURN, - OFN_OVERWRITEPROMPT, - OFN_PATHMUSTEXIST, - OFN_READONLY, - OFN_NOVALIDATE, - OFN_ENABLETEMPLATE, - OFN_ENABLEHOOK ); -var - Ofn : TOpenFilename; - Fltr : KOLString; - TempFilename : KOLString; - Function MakeFilter(s : KOLString) : KOLString; - { format of filter for API call is following: - 'text files'#0'*.txt'#0 - 'bitmap files'#0'*.bmp'#0#0 } - var Str: PKOLChar; - begin - Result := s; - if Result='' then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result:=Result+#0; {Delphi string always end on #0 is this is #0#0} - Str := PKOLChar( Result ); - while Str^ <> #0 do - begin - if Str^ = '|' then - Str^ := #0; - Inc( Str ); - end; - end; - -var m: Integer; -begin - ZeroMemory( @ofn, sizeof( ofn ) ); - - {$IFDEF OpenSaveDialog_Extended} - if (WinVer <= wvNT) and (WinVer <> wvME) then - ofn.lStructSize := 76 - else - begin - ofn.lStructSize := Sizeof( ofn ); - ofn.FlagsEx := Integer( NoPlaceBar ); - end; - {$ELSE} - ofn.lStructSize:= 76; //to provide correct work in Win9x - {$ENDIF} - if fWnd <> 0 then - ofn.hWndOwner := fWnd - else - if Applet <> nil then - ofn.hwndOwner := applet.Handle; - - ofn.hInstance:=HInstance; - - Fltr := MakeFilter(FFilter); - if Fltr <> '' then - ofn.lpstrFilter := PKOLchar(Fltr); - ofn.nFilterIndex := FFilterIndex; - - if OSAllowMultiSelect in FOptions then - ofn.nMaxFile := High(word)-14 // by V.K. (exchanged condition) - else - ofn.nMaxFile := MAX_PATH+2; - - SetLength( TempFileName, ofn.nMaxFile ); - ZeroMemory( @TempFileName[ 1 ], ofn.nMaxFile * sizeof( KOLChar ) ); - m := Min( ofn.nMaxFile, Length(fFileName) ); - {$IFDEF UNICODE_CTRLS} - ofn.lpstrFile := PKOLchar( TempFileName ); - WStrLCopy(PWideChar(TempFileName), PWideChar(fFileName), m ); - {$ELSE} - ofn.lpstrFile := StrLCopy(PKOLChar(TempFileName), PKOLchar(fFileName), m ); - {$ENDIF} - - ofn.lpstrInitialDir:=Pointer(FInitialDir); - ofn.lpstrTitle := Pointer(FTitle); - ofn.Flags := MakeFlags( @FOptions, OpenSaveFlags ) - or OFN_EXPLORER or OFN_LONGNAMES or OFN_ENABLESIZING; - - ofn.lpstrDefExt := PKOLChar(FDefExtension); - ofn.lCustData := integer(@self); - {$IFDEF OpenSaveDialog_Extended} - ofn.lpTemplateName := PKOLChar( TemplateName ); - ofn.lpfnHook := HookProc; - {$ELSE} - ofn.lpTemplateName := nil; - ofn.lpfnHook := nil; - {$ENDIF} - if fOpenDialog then - result := GetOpenFileName(POpenFileName( @ofn )^) - else - result := GetSaveFileName(POpenFileName( @ofn )^); - if result then begin - fFilterIndex := ofn.nFilterIndex; // by Vadim - fOpenReadOnly := OFN_READONLY and ofn.Flags <> 0; // by ECM (in my redaction) - if OSAllowMultiSelect in foptions then begin - FFileName := copy(TempFileName, 1, pos(KOLString(#0#0), tempfilename)-1); - while pos(KOLString(#0), ffilename) > 0 do begin - FFilename[pos(KOLString(#0), ffilename)]:=#13; - end; - end else - FFileName := copy(tempFileName, 1, pos(KOLString(#0), TempFilename) - -1 // by X.Y.B. - ); - end else - FFilename:=''; -end; -{$ENDIF PAS_VERSION} - -{ -- OpenDirDialog -- } - -function NewOpenDirDialog( const Title: KOLString; Options: TOpenDirOptions ): - POpenDirDialog; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TOpenDirDialog'; - {$ENDIF} - Result.FOptions := [ odOnlySystemDirs ]; - if Options <> [] then - Result.FOptions := Options; - Result.FTitle := Title; -end; - -{ TOpenDirDialog } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TOpenDirDialog.Destroy; -begin - FTitle := ''; - FInitialPath := ''; - FStatusText := ''; - inherited; -end; -{$ENDIF PAS_VERSION} - -type - PSHItemID = ^TSHItemID; - TSHItemID = packed record - cb: Word; { Size of the ID (including cb itself) } - abID: array[0..0] of Byte; { The item ID (variable length) } - end; - - PItemIDList = ^TItemIDList; - TItemIDList = record - mkid: TSHItemID; - end; - - PBrowseInfo = ^TBrowseInfo; - TBrowseInfoA = record - hwndOwner: HWND; - pidlRoot: PItemIDList; - pszDisplayName: PAnsiChar; { Return display name of item selected. } - lpszTitle: PAnsiChar; { text to go in the banner over the tree. } - ulFlags: UINT; { Flags that control the return stuff } - lpfn: Pointer; //TFNBFFCallBack; - lParam: LPARAM; { extra info that's passed back in callbacks } - iImage: Integer; { output var: where to return the Image index. } - end; - TBrowseInfoW = record - hwndOwner: HWND; - pidlRoot: PItemIDList; - pszDisplayName: PWideChar; { Return display name of item selected. } - lpszTitle: PWideChar; { text to go in the banner over the tree. } - ulFlags: UINT; { Flags that control the return stuff } - lpfn: Pointer; //TFNBFFCallBack; - lParam: LPARAM; { extra info that's passed back in callbacks } - iImage: Integer; { output var: where to return the Image index. } - end; - TBrowseInfo = {$IFDEF UNICODE_CTRLS} TBrowseInfoW {$ELSE} TBrowseInfoA {$ENDIF}; - -function SHBrowseForFolderA(var lpbi: TBrowseInfoA): PItemIDList; stdcall; - external 'shell32.dll' name 'SHBrowseForFolderA'; -{$IFDEF UNICODE_CTRLS} -function SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; stdcall; - external 'shell32.dll' name 'SHBrowseForFolderW'; -{$ENDIF UNICODE_CTRLS} -function SHGetPathFromIDListA(pidl: PItemIDList; pszPath: PAnsiChar): BOOL; stdcall; - external 'shell32.dll' name 'SHGetPathFromIDListA'; -{$IFDEF UNICODE_CTRLS} -function SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PKOLChar): BOOL; stdcall; - external 'shell32.dll' name 'SHGetPathFromIDListW'; -{$ENDIF UNICODE_CTRLS} -procedure CoTaskMemFree(pv: Pointer); stdcall; external 'ole32.dll' - name 'CoTaskMemFree'; - -const - BIF_RETURNONLYFSDIRS = $0001; { For finding a folder to start document searching } - BIF_DONTGOBELOWDOMAIN = $0002; { For starting the Find Computer } - BIF_STATUSTEXT = $0004; - BIF_RETURNFSANCESTORS = $0008; - BIF_EDITBOX = $0010; - BIF_VALIDATE = $0020; { insist on valid result (or CANCEL) } - BIF_NEWDIALOGSTYLE = $0040; { Use the new dialog layout with the ability to resize } - { Caller needs to call OleInitialize() before using this API (c) JVCL } - BIF_BROWSEFORCOMPUTER = $1000; { Browsing for Computers. } - BIF_BROWSEFORPRINTER = $2000; { Browsing for Printers } - BIF_BROWSEINCLUDEFILES = $4000; { Browsing for Everything } - - BFFM_INITIALIZED = 1; - BFFM_SELCHANGED = 2; - - BFFM_SETSTATUSTEXT = WM_USER + 100; - BFFM_ENABLEOK = WM_USER + 101; - BFFM_SETSELECTION = WM_USER + 102; - BFFM_SETSELECTIONW = WM_USER + 103; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TOpenDirDialog.Execute: Boolean; -const FlagsArray: array[ TOpenDirOption ] of Integer = - ( BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN, - BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT, - BIF_BROWSEINCLUDEFILES, BIF_EDITBOX, BIF_NEWDIALOGSTYLE ); -var BI : TBrowseInfo; - Browse : PItemIdList; -begin - Result := False; - if WndOwner <> 0 then - BI.hwndOwner := WndOwner - else - if Applet <> nil then - BI.hwndOwner := Applet.Handle - else - BI.hwndOwner := 0; - BI.pidlRoot := nil; - BI.pszDisplayName := @FBuf[ 0 ]; - BI.lpszTitle := PKOLChar( Title ); - BI.ulFlags := MakeFlags( @FOptions, FlagsArray ); - BI.lpfn := FCallBack; - BI.lParam := Integer( @Self ); - Browse := {$IFDEF UNICODE_CTRLS} SHBrowseForFolderW {$ELSE} SHBrowseForFolderA {$ENDIF} - ( BI ); - if Browse <> nil then - begin - {$IFDEF UNICODE_CTRLS}SHGetPathFromIDListW{$ELSE} SHGetPathFromIDListA{$ENDIF}( Browse, @FBuf[ 0 ] ); - CoTaskMemFree( Browse ); - Result := True; - end; -end; -{$ENDIF PAS_VERSION} - -function TOpenDirDialog.GetInitialPath: KOLString; -begin - Result := IncludeTrailingPathDelimiter( fInitialPath ); -end; - -function TOpenDirDialog.GetPath: KOLString; -begin - Result := FBuf; -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): - Integer; stdcall; -var _Self_: POpenDirDialog; - EnableOK: Integer; -begin - _Self_ := Pointer( lpData ); - if Assigned( _Self_.FOnSelChanged ) then - begin - {$IFDEF UNICODE_CTRLS} SHGetPathFromIDListW {$ELSE} SHGetPathFromIDListA {$ENDIF}( PItemIDList( lParam ), @ _Self_.FBuf[ 0 ] ); - EnableOK := 0; - _Self_.FOnSelChanged( _Self_, _Self_.FBuf, EnableOK, - KOL_String( KOLString( _Self_.FStatusText ) ) ); - SendMessage( Wnd, BFFM_ENABLEOK, 0, EnableOK ); - if _Self_.FStatusText <> '' then - SendMessage( Wnd, BFFM_SETSTATUSTEXT, 0, Integer( PKOLChar( _Self_.FStatusText ) ) ); - end; - Result := 0; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_LOCAL} {$UNDEF ASM_LOCAL} {$ENDIF} -{$IFNDEF NEW_OPEN_DIR_STYLE_EX} - {$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF} -{$ENDIF} - -{$IFDEF ASM_LOCAL} -{$ELSE PAS_VERSION} //Pascal -function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer; - stdcall; -const - Shel: array[ 0..3 ] of AnsiChar = 'SHBr'; // KOL_ANSI used as DWORD -var Self_ : POpenDirDialog; - {$IFDEF NEW_OPEN_DIR_STYLE_EX} - WList: HWnd; - ClassBuf: array[ 0..127 ] of KOLChar; - {$ENDIF} -begin - Self_ := Pointer( lpData ); - Self_.FDialogWnd := Wnd; - if Msg = BFFM_INITIALIZED then - begin - if Assigned( Self_.FCenterProc ) then - Self_.FCenterProc( Wnd ); - if Self_.FInitialPath <> '' then - begin - {$IFDEF NEW_OPEN_DIR_STYLE_EX} - WList := GetWindow( Wnd, GW_CHILD ); - while WList <> 0 do - begin - WList := GetWindow( WList, GW_HWNDNEXT ); - GetClassName( WList, @ ClassBuf[ 0 ], Sizeof( ClassBuf ) ); - if PDWord( @ ClassBuf[ 0 ] )^ = DWORD( Shel ) then - begin - PostMessage( Wnd, WM_NEXTDLGCTL, WList, 1 ); - break; - end; - end; - PostMessage( Wnd, {$IFDEF UNICODE_CTRLS} BFFM_SETSELECTIONW - {$ELSE} BFFM_SETSELECTION {$ENDIF}, 1, Integer( PKOLChar( - ExtractFilePath( Self_.FInitialPath ) ) ) ); - PostMessage( WND, WM_KEYDOWN, VK_ADD, 0 ); - PostMessage( WND, WM_KEYUP, VK_ADD, 0 ); - PostMessage( Wnd, {$IFDEF UNICODE_CTRLS} BFFM_SETSELECTIONW - {$ELSE} BFFM_SETSELECTION {$ENDIF}, 1, Integer( PKOLChar( Self_.FInitialPath ) ) ); - {$ELSE} - SendMessage( Wnd, {$IFDEF UNICODE_CTRLS} BFFM_SETSELECTIONW - {$ELSE} BFFM_SETSELECTION {$ENDIF}, 1, Integer( PKOLChar( Self_.FInitialPath ) ) ); - {$ENDIF} - SendMessage( Wnd, BFFM_ENABLEOK, 0, 1 ); - end; - end - else - if Msg = BFFM_SELCHANGED then - begin - if Assigned( Self_.FDoSelChanged ) then - Self_.FDoSelChanged( Wnd, Msg, lParam, lpData ) - else - SendMessage( Wnd, BFFM_ENABLEOK, 0, 1 ); - end; - Result := 0; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure OpenDirDlgCenter( Wnd: HWnd ); -var R: TRect; - W, H: Integer; -begin - GetWindowRect( Wnd, R ); - W := R.Right - R.Left; - H := R.Bottom - R.Top; - R.Left := (GetSystemMetrics( SM_CXSCREEN ) - W) div 2; - R.Top := (GetSystemMetrics( SM_CYSCREEN ) - H) div 2; - MoveWindow( Wnd, R.Left, R.Top, W, H, True ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TOpenDirDialog.SetCenterOnScreen(const Value: Boolean); -var P: procedure( Wnd: HWnd ); -begin - FCenterOnScreen := Value; - P := nil; - if Value then - P := @OpenDirDlgCenter; - FCenterProc := P; -end; -{$ENDIF PAS_VERSION} - -procedure TOpenDirDialog.SetInitialPath(const Value: KOLString); -begin - FCallBack := @OpenDirCallBack; - FInitialPath := ExcludeTrailingPathDelimiter( Value ); - if (FInitialPath <> '') and - (FInitialPath[ Length( FInitialPath ) ] = ':') then - FInitialPath := IncludeTrailingPathDelimiter( Value ); -end; - -procedure TOpenDirDialog.SetOnSelChanged(const Value: TOnODSelChange); -begin - FOnSelChanged := Value; - FCallBack := @OpenDirCallBack; - FDoSelChanged := @OpenDirSelChangeCallBack; -end; - -type - PByteArray =^TByteArray; - TByteArray = array[Word]of Byte; - -function CreateMappedBitmap(Instance: THandle; Bitmap: Integer; - Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; stdcall; - external cctrl name 'CreateMappedBitmap'; - -function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PKOLChar; Flags: -Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap; -var bi: TBITMAPINFO; - DC, tmcl: Cardinal; - Bits: PByteArray; - i, j, k, CO, bps: Integer; - tm: array [1..4] of byte absolute tmcl; - bm: Windows.TBITMAP; - CM: PColorMap; - DW: HWnd; -begin - Result := LoadBitmap( Instance, BmpRsrcName ); - if Result = 0 then - begin - {$IFDEF DEBUG_ANY} - ShowMessage( AnsiString('Can not load bitmap ') + BmpRsrcName + ', error ' + - Int2Str( GetLastError ) + ': ' + SysErrorMessage( GetLastError ) ); - {$ENDIF DEBUG_ANY} - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - DW := GetDesktopWindow; - DC := GetDC(DW); - ZeroMemory( @bm, SizeOf(bm) ); - GetObject( Result, SizeOf( bm ), @bm ); - - ZeroMemory( @bi, SizeOf( bi ) ); - bi.bmiHeader.biSize := SizeOf( bi.bmiHeader ); - bi.bmiHeader.biWidth := bm.bmWidth; - bi.bmiHeader.biHeight := -bm.bmHeight; - bi.bmiHeader.biPlanes := 1; - bi.bmiHeader.biBitCount := 24; -// BitCout - always 24 for easy algorythm - bi.bmiHeader.biCompression:=BI_RGB; - bps := CalcScanLineSize( @bi.bmiHeader ); - - GetMem( Bits, bps * bm.bmHeight ); - GetDIBits( DC, Result, 0, bm.bmHeight, @Bits[0], bi, DIB_RGB_COLORS ); - DeleteObject( Result ); - - for i := 0 to bm.bmHeight - 1 do begin - for j := 0 to bm.bmWidth - 1 do begin - CO := bps * i + 3 * j; - for k := 0 to NumMaps - 1 do begin - CM := Pointer( Integer( ColorMap ) + SizeOf( TColorMap ) * k ); - if RGB( Bits[CO+2], Bits[CO+1], Bits[CO] ) = CM.cFrom then - begin - tmcl := CM.cTo; - tm[4]:=tm[1]; - tm[1]:=tm[3]; - tm[3]:=tm[4]; - Move( tmcl, Bits[CO], 3); - end; - end; - end; - end; - Result := CreateDIBitmap( DC, bi.bmiHeader, CBM_INIT, @Bits[0], bi, - DIB_RGB_COLORS ); - ReleaseDC( DW, DC ); - FreeMem( Bits ); -end; - -function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor ) - : HBitmap; -var Map2Pass: Pointer; -begin - Map2Pass := nil; - if High( Map ) > 0 then - Map2Pass := PColorMap( @Map[ 0 ] ); - Result := CreateMappedBitmap( hInst, BmpResID, 0, Map2Pass, (High( Map ) + 1) div 2 ); -end; - -function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PKOLChar; const Map: array of TColor ) - : HBitmap; -var Map2Pass: Pointer; -begin - Map2Pass := nil; - if High( Map ) > 0 then - Map2Pass := PColorMap( @Map[ 0 ] ); - Result := CreateMappedBitmapEx( hInst, BmpResName, 0, Map2Pass, (High( Map ) + 1) div 2 ); - if MasterObj <> nil then - MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) ); -end; - -{ -- Toolbar -- } - -{$IFDEF ASM_noVERSION} // width -procedure TControl.TBAddBitmap(Bitmap: HBitmap); -const szBI = sizeof(TBitmapInfo); -asm - TEST EDX, EDX - JZ @@exit - JGE @@1 - CMP EDX, -6 - JL @@1 - NEG EDX - DEC EDX - PUSH EDX - PUSH -1 - XOR EDX, EDX - JMP @@2 -@@1: PUSH EDX // AB.hInst = Bitmap - PUSH 0 // AB.nID = 0 - PUSH EAX // > @Self - ADD ESP, -szBI - PUSH ESP - PUSH szBI - PUSH EDX - CALL GetObject - TEST EAX, EAX - JG @@11 - ADD ESP, szBI - JMP @@exit -@@11: MOV EAX, [ESP].TBitmapInfo.bmiHeader.biWidth - MOV ECX, [ESP].TBitmapInfo.bmiHeader.biHeight - TEST ECX, ECX - JGE @@12 - NEG ECX -@@12: ADD ESP, szBI - CDQ // EDX = 0 - DIV ECX // EAX = N - XCHG EAX, [ESP] // > N - PUSH EAX // > @Self - MOV EDX, ECX - SHL EDX, 16 - OR ECX, EDX - CDQ - PUSH EDX - PUSH EDX - PUSH TB_AUTOSIZE - PUSH EAX - PUSH ECX - PUSH EDX - PUSH TB_SETBITMAPSIZE - PUSH EAX - CALL Perform - CALL Perform - POP EAX - POP EDX -@@2: PUSH ESP - PUSH EDX - PUSH TB_ADDBITMAP - PUSH EAX - CALL Perform - POP ECX - POP ECX -@@exit: -end; -{$ELSE PAS_VERSION} //Pascal -procedure TControl.TBAddBitmap(Bitmap: HBitmap); -const NstdBitmaps: array[ 0..5 ] of DWORD = ( 15, 15, 0, 0, 13, 13 ); -var BI: TBitmapInfo; - AB: TTBAddBitmap; - N, W: Integer; -begin - if Bitmap = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (Integer( Bitmap ) >= -10) and (Integer( Bitmap ) <= -1) then - begin - AB.hInst := THandle(-1); - AB.nID := -Integer(Bitmap) - 1; - N := 0; //NstdBitmaps[ AB.nID ]; // (this value is ignored) - end - else - if GetObject( Bitmap, sizeof( TBitmapInfo ), @BI ) > 0 then - begin - AB.hInst := 0; - AB.nID := Bitmap; - W := DF.fTBBtnImgWidth; - if W = 0 then - W := Abs( BI.bmiHeader.biHeight ); - N := BI.bmiHeader.biWidth div W; - Perform( TB_SETBITMAPSIZE, 0, MAKELONG( W, Abs(BI.bmiHeader.biHeight )) ); - Perform( TB_AUTOSIZE, 0, 0 ); - end else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Perform( TB_ADDBITMAP, N, Integer( @AB ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TControl.TBAddInsButtons(Idx: Integer; const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer): Integer; stdcall; - - function AddInsButtons: Integer; - type TTBBtnArray = array[ 0..100000 ] of TTBButton; - PTBBtnArray = ^TTBBtnArray; - var AB: PTBBtnArray; - I, N, nBmp: Integer; - PAB: PTBButton; - Str: PKOLChar; - Str0: KOLString; - begin - Result := -1; - AB := nil; - if High( Buttons ) >= 0 then - GetMem( AB, Sizeof( TTBButton ) * (High(Buttons) + 1) ); - N := 0; - PAB := @AB[ 0 ]; - nBmp := -2; - if High(BtnImgIdxArray) >= 0 then - nBmp := BtnImgIdxArray[ 0 ] - 1; - for I:= 0 to High( Buttons ) do - begin - if Buttons[ I ] = nil then break; - if {$IFDEF UNICODE_CTRLS} WStrComp {$ELSE} StrComp {$ENDIF} - ( Buttons[ I ], {$IFDEF F_P}''+{$ENDIF} '-' ) = 0 then - begin - PAB.iBitmap := -1; - //PAB.idCommand := 0; - PAB.fsState := 0; - PAB.fsStyle := TBSTYLE_SEP; - PAB.iString := -1; - end - else - begin - Str := Buttons[ I ]; - Inc( nBmp ); - PAB.iBitmap := nBmp; - if nBmp < 0 then - Dec( nBmp ); - if High( BtnImgIdxArray ) >= N then - PAB.iBitmap := BtnImgIdxArray[ N ]; - PAB.fsState := TBSTATE_ENABLED; - PAB.fsStyle := TBSTYLE_BUTTON or DF.fDefaultTBBtnStyle; - if Str^ = '^' then - begin - PAB.fsStyle := TBSTYLE_DROPDOWN or DF.fDefaultTBBtnStyle; - Inc( Str ); - end; - if CharIn( Str^, [ '-', '+' ] ) then - begin - PAB.fsStyle := PAB.fsStyle or TBSTYLE_CHECK; - if Str^ = '+' then - PAB.fsState := PAB.fsState or TBSTATE_CHECKED; - Inc( Str ); - if Str^ = '!' then - begin - PAB.fsStyle := PAB.fsStyle or TBSTYLE_GROUP; - Inc( Str ); - end; - end; - {$IFDEF TOOLBAR_DOT_NOAUTOSIZE_BUTTON} - if Str^ = '.' then - begin - PAB.fsStyle := PAB.fsStyle and not TBSTYLE_AUTOSIZE; - inc( Str ); - end; - {$ENDIF TOOLBAR_DOT_NOAUTOSIZE_BUTTON} - if (KOLString(Str) = KOLString( {$IFDEF F_P}''+{$ENDIF} KOLChar( ' ' ) )) or (Str^ = #0) then - PAB.iString := -1 - else - begin - Str0 := KOLString('') + KOLString(Str) + #0; - PAB.iString := Perform( TB_ADDSTRING, 0, Integer(PKOLChar(Str0)) ); - end; - end; - - PAB.idCommand := ToolbarsIDcmd; - if Result < 0 then Result := PAB.idCommand; - Inc( ToolbarsIDcmd ); - - PAB.dwData := Integer( @Self ); - Inc( N ); - Inc( PAB ); - end; - if N > 0 then - begin - if Idx < 0 then - Perform( TB_ADDBUTTONS, N, Integer( @AB[ 0 ] ) ) - else - Perform( TB_INSERTBUTTON, Idx, Integer( @AB[ 0 ] ) ); - end; - if AB <> nil then - FreeMem( AB ); - end; -begin - if High( Buttons ) < 0 then - Result := -1 - else - Result := AddInsButtons; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.TBAddButtons(const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer): Integer; -begin - Result := TBAddInsButtons( -1, Buttons, BtnImgIdxArray ); -end; -{$ENDIF PAS_VERSION} - -function TControl.TBInsertButtons(BeforeIdx: Integer; - Buttons: array of PKOLChar; const BtnImgIdxArray: array of Integer): Integer; -var I, J, K: Integer; -begin - J := -1; - Result := -1; - for I := 0 to High( Buttons ) do - begin - if I <= High( BtnImgIdxArray ) then - J := BtnImgIdxArray[ I ] - else - if J >= 0 then Inc( J ); - K := TBAddInsButtons( BeforeIdx, [ Buttons[ I ], '' ], [ J ] ); - if Result < 0 then Result := K; - end; -end; - -function GetTBBtnGoodID( Toolbar: PControl; BtnIDorIdx: Integer ): Integer; -// change by Alexander Pravdin (to fix toolbar with separator first): -var Btn1st, i: Integer; btn: TTBButton; -begin - Result := BtnIDorIdx; - Btn1st := 0; - for i := 0 to Toolbar.TBButtonCount - 1 do begin - Toolbar.Perform( TB_GETBUTTON, i, Integer( @btn ) ); - if btn.fsStyle <> TBSTYLE_SEP then begin - Btn1st := i; - Break; - end; - end; - if Result < Toolbar.TBIndex2Item( Btn1st ) then - Result := Toolbar.TBIndex2Item( Result ); -end; - -type - TTBButtonEvent = packed Record - BtnID: DWORD; - Event: TOnToolbarButtonClick; - end; - PTBButtonEvent = ^TTBButtonEvent; - -procedure TControl.TBFreeTBevents; -begin - DF.fTBevents.Release; -end; - -function WndProcToolbarButtonsClicks( TB: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Notify: PTBNotify; - I: Integer; - Event: PTBButtonEvent; -begin - Result := FALSE; - if Msg.message = WM_NOTIFY then - begin - Notify := Pointer( Msg.lParam ); - if Notify.hdr.code = NM_CLICK then - begin - for I := TB.DF.fTBevents.fCount-1 downto 0 do - begin - Event := TB.DF.fTBevents.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - if Integer( Event.BtnID ) = Notify.iItem then - begin - if Assigned( Event.Event ) then - begin - TB.RefInc; - Rslt := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam ); - Event.Event( TB, Event.BtnID ); - TB.RefDec; - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - break; - end; - end; - end; - end; -end; - -procedure TControl.TBAssignEvents(BtnID: Integer; - Events: array of TOnToolbarButtonClick); -var I: Integer; - EventRec: PTBButtonEvent; -begin - if DF.fTBevents = nil then - begin - DF.fTBevents := NewList; - Add2AutoFreeEx( TBFreeTBevents ); - AttachProc( WndProcToolbarButtonsClicks ); - end; - BtnID := GetTBBtnGoodID( @Self, BtnID ); - for I := 0 to High( Events ) do - begin - GetMem( EventRec, Sizeof( TTBButtonEvent ) ); - DF.fTBevents.Add( EventRec ); - EventRec.Event := Events[ I ]; - EventRec.BtnID := BtnID; - Inc( BtnID ); - end; -end; - -function TControl.TBBtnEvent( Idx: Integer ): TOnToolbarButtonClick; -var EventRec: PTBButtonEvent; -begin - Result := nil; - if DF.fTBevents = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Idx < DF.fTBevents.Count then - begin - EventRec := DF.fTBevents.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} - [ Idx ]; - Result := EventRec.Event; - end; -end; - -procedure TControl.TBResetImgIdx( BtnID, BtnCount: Integer ); -begin - while BtnCount > 0 do - begin - TBButtonImage[ BtnID ] := -2; - Inc( BtnID ); - Dec( BtnCount ); - end; -end; - -function TControl.TBGetButtonVisible(BtnID: Integer): Boolean; -begin - Result := Perform( TB_ISBUTTONHIDDEN, GetTBBtnGoodID( @ Self, BtnID ), 0 ) = 0; -end; - -function TControl.TBItem2Index(BtnID: Integer): Integer; -begin - Result := Perform( TB_COMMANDTOINDEX, BtnID, 0 ); -end; - -procedure TControl.TBSetButtonVisible(BtnID: Integer; - const Value: Boolean); -begin - BtnID := GetTBBtnGoodID( @Self, BtnID ); - Perform( TB_HIDEBUTTON, BtnID, Integer( not Value ) ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean; -begin - BtnID := GetTBBtnGoodID( @Self, BtnID ); - Result := Perform( Index + 8, BtnID, 0 ) <> 0; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean); -begin - BtnID := GetTBBtnGoodID( @Self, BtnID ); - Perform( Index, BtnID, Integer( Value ) ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.TBIndex2Item(Idx: Integer): Integer; -var ButtonInfo: TTBButton; -begin - Result := -1; - if Perform( TB_GETBUTTON, Idx, Integer( @ButtonInfo ) ) <> 0 then - Result := ButtonInfo.idCommand; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.TBConvertIdxArray2ID(const IdxVars: array of PDWORD); -var i: Integer; -begin - for i := 0 to High( IdxVars ) do - IdxVars[ i ]^ := TBIndex2Item( IdxVars[ I ]^ ); -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -function TControl.TBGetButtonText( BtnID: Integer ): KOLString; -var Buffer: array[ 0..1023 ] of KOLChar; -begin - BtnID := GetTBBtnGoodID( @Self, BtnID ); - if Perform( TB_GETBUTTONTEXT, BtnID, Integer( @Buffer[ 0 ] ) ) > 0 then - Result := Buffer - else - Result := ''; -end; -{$ENDIF PAS_VERSION} - -function TControl.TBGetButtonRect(BtnID: Integer): TRect; -begin - BtnID := GetTBBtnGoodID( @Self, BtnID ); - Perform( TB_GETITEMRECT, TBItem2Index( BtnID ), Integer( @Result ) ); -end; - -function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect; -begin - Result := Toolbar.TBGetButtonRect(BtnID); -end; - -function TControl.TBGetRows: Integer; -begin - Result := 1; - UpdateWndStyles; - if (TBSTYLE_WRAPABLE and fStyle.Value) <> 0 then - Result := Perform( TB_GETROWS, 0, 0 ); -end; - -procedure TControl.TBSetRows(const Value: Integer); -begin - Perform( TB_SETROWS, Value, 0 ); -end; - -function TControl.TBMoveBtn(FromIdx, ToIdx: Integer): Boolean; -var btn: TTBButton; -begin - Perform(TB_GETBUTTON,FromIdx,integer(@btn)); - Result := Perform(TB_DELETEBUTTON,FromIdx,0) <> 0; - if Result then - Perform(TB_INSERTBUTTON,ToIdx,integer(@btn)); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.TBSetTooltips(BtnID1st: Integer; - const Tooltips: array of PKOLChar); -var I, J: Integer; -begin - if ( DF.fTBttCmd = nil ) then - begin - DF.fTBttCmd := NewList; - DF.fTBttTxt := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF}; - {$IFDEF USE_AUTOFREE4CONTROLS} - Add2AutoFree( DF.fTBttCmd ); - Add2AutoFree( DF.fTBttTxt ); - {$ENDIF} - end; - for I:= 0 to High( Tooltips ) do - begin - J := DF.fTBttCmd.IndexOf( Pointer( BtnID1st ) ); - if J < 0 then - begin - DF.fTBttCmd.Add( Pointer( BtnID1st ) ); - DF.fTBttTxt.Add( Tooltips[ I ] ); - end - else - DF.fTBttTxt.Items[ J ] := Tooltips[ I ]; - Inc( BtnID1st ); - end; -end; -{$ENDIF PAS_VERSION} - -function TControl.TBBtnTooltip( BtnID: Integer ): KOLString; -var J: Integer; -begin - Result := ''; - if DF.fTBttCmd = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - J := DF.fTBttCmd.IndexOf( Pointer( BtnID ) ); - if J < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Result := DF.fTBttTxt.Items[ J ]; -end; - -procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer; - const Tooltips: array of PKOLChar ); -begin - Toolbar.TBSetTooltips( BtnID1st, Tooltips ); -end; - -function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean; -begin - Result := Toolbar.TBButtonEnabled[ BtnID ]; -end; - -procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean ); -begin - Toolbar.TBButtonEnabled[ BtnID ] := Enable; -end; - -function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean; -begin - Result := Toolbar.TBButtonVisible[ BtnID ]; -end; - -procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean ); -begin - Toolbar.TBButtonVisible[ BtnID ] := Show; -end; - -function ToolbarButtonChecked( Toolbar: PControl; BtnID: Integer): Boolean; -begin - Result := Toolbar.TBButtonChecked[ BtnID ]; -end; - -procedure ToolbarButtonSetChecked( Toolbar: PControl; BtnID: Integer; Checked: Boolean ); -begin - Toolbar.TBButtonChecked[ BtnID ] := Checked; -end; - -procedure ToolbarAddButtons( Toolbar: PControl; const Buttons: array of PKOLChar; - const BtnImgIdxArray: array of Integer; Bitmap: HBitmap ); -begin - Toolbar.TBAddButtons( Buttons, BtnImgIdxArray ); - if Bitmap <> 0 then - Toolbar.TBAddBitmap( Bitmap ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.TBButtonAtPos(X, Y: Integer): Integer; -var I: Integer; -begin - I := TBBtnIdxAtPos( X, Y ); - if I >= 0 then - I := TBIndex2Item( I ); - Result := I; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.TBBtnIdxAtPos(X, Y: Integer): Integer; -var I: Integer; - R: TRect; - P: TPoint; -begin - P := MakePoint( X, Y ); - for I := TBButtonCount - 1 downto 0 do - begin - Perform( TB_GETITEMRECT, I, Integer( @R ) ); - if PointInRect( P, R ) then - begin - Result := I; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := -1; -end; -{$ENDIF PAS_VERSION} - -function TControl.TBButtonSeparator(BtnID: Integer): Boolean; -var B: TTBButton; -begin - Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID ) -), Integer( @B ) ) ; - Result := B.fsStyle = TBSTYLE_SEP; -end; - -procedure TControl.TBDeleteButton(BtnID: Integer); -begin - BtnID := GetTBBtnGoodID( @Self, BtnID ); - Perform( TB_DELETEBUTTON, TBItem2Index( BtnID ), 0 ); -end; - -procedure TControl.TBDeleteBtnByIdx(Idx: Integer); -begin - Perform( TB_DELETEBUTTON, Idx, 0 ); -end; - -procedure TControl.TBClear; -var - i: Integer; -begin - for i := 0 to Pred(TBButtonCount) do - TBDeleteBtnByIdx(0); -end; - -procedure TControl.Clear; -begin - fCommandActions.aClear( @Self ); -end; - -{$IFDEF ASM_noVERSION} -function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer; -const szTBButton = sizeof( TTBButton ); -asm - ADD ESP, -szTBButton - PUSH ESP - PUSH EAX - CALL TBItem2Index - POP EDX - PUSH EAX - PUSH TB_GETBUTTON - PUSH EDX - CALL Perform - POP EAX - ADD ESP, szTBButton-4 -end; -{$ELSE PAS_VERSION} //Pascal -function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer; -var B: TTBButton; -begin - Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID ) ), Integer( @B ) ); - Result := B.iBitmap; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.TBSetBtnImgIdx(BtnID: Integer; const Value: Integer); -begin - Perform( TB_CHANGEBITMAP, GetTBBtnGoodID( @Self, BtnID ), Value ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.TBSetButtonText(BtnID: Integer; const Value: KOLString); -var BI: TTBButtonInfo; -begin - BtnID := GetTBBtnGoodID( @Self, BtnID ); - BI.cbSize := Sizeof( BI ); - BI.dwMask := TBIF_TEXT; - BI.pszText := PKOLChar( Value ); - Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.TBGetBtnWidth(BtnID: Integer): Integer; -var R: TRect; -begin - R := TBButtonRect[ BtnID ]; - Result := R.Right - R.Left; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.TBSetBtnWidth(BtnID: Integer; const Value: Integer); -var BI: TTBButtonInfo; -begin - BI.cbSize := Sizeof( BI ); - BI.dwMask := TBIF_SIZE or TBIF_STYLE; - BtnID := GetTBBtnGoodID( @Self, BtnID ); - Perform( TB_GETBUTTONINFO, BtnID, Integer( @BI ) ); - BI.cx := Value; - BI.fsStyle := BI.fsStyle and not TBSTYLE_AUTOSIZE; - Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) ); -end; -{$ENDIF PAS_VERSION} - -procedure TControl.TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer); -begin - case Idx of - 0: DF.fTBBtMinWidth := Value; - 1: DF.fTBBtMaxWidth := Value; - end; - Perform( TB_SETBUTTONWIDTH, 0, DF.fTBBtMaxWidth or (DF.fTBBtMinWidth shl 16) ); -end; - -{$IFDEF F_P} -function TControl.TBGetBtMinMaxWidth(const Idx: Integer): Integer; -begin - CASE Idx OF - 0: Result := FTBBtMinWidth; - 1: Result := FTBBtMaxWidth; - END; -end; -{$ENDIF F_P} - -function TControl.TBGetButtonLParam(const Idx: Integer): DWORD; -var - tb: TTBButtonInfo; -begin - tb.cbSize := sizeof(tb); - tb.dwMask := TBIF_BYINDEX or TBIF_LPARAM; - Perform(TB_GETBUTTONINFO, Idx, Integer(@tb)); - Result := tb.lParam; -end; - -procedure TControl.TBSetButtonLParam(const Idx: Integer; const Value: DWORD); -var - tb: TTBButtonInfo; -begin - tb.cbSize := sizeof(tb); - tb.dwMask := TBIF_BYINDEX or TBIF_LPARAM; - tb.lParam := Value; - Perform(TB_SETBUTTONINFO, Idx, Integer(@tb)); -end; - -function WndProcTBCustomDraw( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var CD: PNMTBCustomDraw; - Br: HBrush; -begin - Result := FALSE; - if Msg.message = WM_NOTIFY then - begin - CD := Pointer( Msg.lParam ); - if CD.nmcd.hdr.code = NM_CUSTOMDRAW then - begin - if Assigned( Sender.DF.fOnTBCustomDraw ) then - Rslt := Sender.DF.fOnTBCustomDraw( Sender, CD^ ) - else - begin - if Sender.fBrush <> nil then - Windows.FillRect( CD.nmcd.hdc, Sender.ClientRect, Sender.fBrush.Handle ) - else - begin - Br := CreateSolidBrush( Color2RGB( Sender.Color ) ); - Windows.FillRect( CD.nmcd.hdc, Sender.ClientRect, Br ); - DeleteObject( Br ); - end; - Rslt := CDRF_SKIPDEFAULT; - end; - end; - end; -end; - -procedure TControl.SetOnTBCustomDraw( const Value: TOnTBCustomDraw ); -begin - DF.fOnTBCustomDraw := Value; - AttachProc( WndProcTBCustomDraw ); -end; - - -procedure TControl.SetDroppedDown(const Value: Boolean); -begin - Perform( CB_SHOWDROPDOWN, Integer( Value ), 0 ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.AddDirList(const Filemask: KOLString; Attrs: DWORD); -begin - if fCommandActions.aDir <> 0 then - Perform( fCommandActions.aDir, Attrs, Integer( PKOLChar( Filemask ) ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_noVERSION} -{$ELSE PAS_VERSION} //Pascal -function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -//var Accept: Boolean; // {Alexander Pravdin, AP} -begin - Result := FALSE; - if Msg.message = WM_CLOSE then - begin - if Self_.DF.fModalResult = 0 then { (Sergey Shishmintzev) } - Self_.DF.fModalResult := -1; - Rslt := 0; - Result := True; // Do not process ! - end - ; -end; -{$ENDIF PAS_VERSION} - -// by TR"]F -function WndProcFixModal( Self_: PControl; var Msg: TMsg; var Rslt: -Integer ): Boolean; -const HTERROR = $FFFE; - LBtnDown = $201; - LBtnUp = $202; - RBtnDown = $204; - RBtnUp = $205; - WeelDown = $207; - WeelUp = $208; -{$IFDEF MODAL_ACTIVATE_FIX} -var i: Integer; - C: PControl; -{$ENDIF MODAL_ACTIVATE_FIX} -begin - Result := false; - if (Msg.message = WM_SETCURSOR) then - if (LoWord(Msg.lParam) = HTERROR) then - if (HiWord(Msg.lParam) >= LBtnDown) and - (HiWord(Msg.lParam) <= RBtnUp) then - begin - if Applet.DF.fModalForm <> nil then - SetForegroundWindow(Applet.DF.fModalForm.Handle); - Rslt := 1; - Result := TRUE; - end; - - {$IFDEF MODAL_ACTIVATE_FIX} - if (Msg.message = WM_ACTIVATEAPP) then - begin - if not Applet.DF.fActivating then - begin - Applet.DF.fActivating := TRUE; - if Msg.wParam <> 0 then - begin - for i := Applet.ChildCount-1 downto 0 do - begin - C := Applet.Children[ i ]; - if C.Visible and not C.Enabled then - SetForegroundWindow( C.Handle ); - end; - if Applet.DF.fModalForm <> nil then - SetForegroundWindow( Applet.DF.fModalForm.Handle ); - end; - Applet.DF.fActivating := FALSE; - end; - end; - {$ENDIF MODAL_ACTIVATE_FIX} -end; - -{$IFDEF ASM_noVERSION} // ASM_TLIST! -function TControl.ShowModal: Integer; -asm - MOV ECX, [EAX].fParent - JECXZ @@show - MOVZX ECX, [EAX].fIsControl - JECXZ @@show_modal -@@show: - CALL Show - XOR EAX, EAX - RET -@@show_modal: - PUSHAD - MOV EBX, EAX - MOV EDI, [Applet] - XOR EBP, EBP // CurCtl = nil - MOV EAX, [EDI].fCurrentControl - {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG3, (1 shl G3_IsApplet) - {$ELSE} - CMP [EDI].TControl.FIsApplet, 0 - {$ENDIF} - {$IFDEF USE_CMOV} - CMOVZ EAX, EDI - {$ELSE} - JNZ @@curctrl_save - MOV EAX, EDI -@@curctrl_save: - {$ENDIF} - PUSH EAX - MOV EDX, offset[WndProcShowModal] - PUSH EDX - MOV EAX, EBX - CALL TControl.AttachProc - XOR EDX, EDX - MOV [EBX].fModalResult, EDX - CALL NewList - XCHG EAX, EBP - XOR ECX, ECX - INC ECX - MOV ESI, EDI - {$IFDEF USE_FLAGS} - TEST [EDI].TControl.fFlagsG3, (1 shl G3_IsApplet) - {$ELSE} - CMP [EDI].TControl.FIsApplet, 0 - {$ENDIF} - JZ @@isapplet - MOV EBP, [EDI].fCurrentControl // CurCtl = Applet.fCurrentControl - MOV ESI, [EDI].fChildren - MOV ECX, [ESI].TList.fCount - MOV ESI, [ESI].TList.fItems -@@1loo: LODSD -@@isapplet: - PUSH ECX - CMP EAX, EBX - JE @@1nx - PUSH EAX - CALL GetEnabled - TEST AL, AL - POP EAX - JZ @@1nx - PUSH EAX - MOV DL, 0 - CALL SetEnabled - POP EDX - MOV EAX, EBP - CALL TList.Add -@@1nx: POP ECX - LOOP @@1loo - INC [EBX].fModal - MOV EAX, [Applet] - MOV [EAX].fModalForm, EBX - MOV EAX, EBX - CALL Show -@@msgloo: - MOVZX ECX, [AppletTerminated] - OR ECX, [EBX].fModalResult - JNZ @@e_msgloo - CALL WaitMessage - MOV EAX, EDI - CALL ProcessMessages - {$IFDEF USE_OnIdle} - MOV EAX, EBX - CALL [ProcessIdle] - {$ENDIF} - JMP @@msgloo -@@e_msgloo: - POP EDX - MOV EAX, EBX - CALL TControl.DetachProc - DEC [EBX].fModal - MOV EAX, [Applet] - XOR ECX, ECX - MOV [EAX].fModalForm, ECX - MOV ECX, [EBP].TList.fCount - JECXZ @@2end - MOV ESI, [EBP].TList.fItems -@@2loo: LODSD - PUSH ECX - MOV DL, 1 - CALL TControl.SetEnabled - POP ECX - LOOP @@2loo -@@2end: - MOV EAX, EBP - CALL TObj.Free - POP ECX - JECXZ @@exit - PUSH 0 - PUSH WA_ACTIVE - PUSH WM_ACTIVATE - PUSH [ECX].fHandle - CALL PostMessage - TEST EBP, EBP // CurCtl = nil ? - JZ @@exit - MOV EAX, EBP - MOV DL, 1 - CALL TControl.SetFocused -@@exit: - POPAD - MOV EAX, [EAX].fModalResult -end; -{$ELSE PAS_VERSION} //Pascal -{$IFDEF USE_SHOWMODALPARENTED_ALWAYS} -function TControl.ShowModal: Integer; -begin - Result := ShowModalParented(Applet); -end; -{$ELSE not USE_SHOWMODALPARENTED_ALWAYS} -function TControl.ShowModal: Integer; -var FL: PList; -var CurForm: PControl; - I: Integer; - F: PControl; - CurCtl: PControl; // { Alexander Pravdin } -begin - Result := 0; - if {$IFDEF USE_FLAGS} (G3_IsControl in fFlagsG3) - {$ELSE} (fIsControl) {$ENDIF} - or (fParent = nil) then - begin - Show; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - AttachProc( WndProcShowModal ); - CurForm := Applet.DF.fCurrentControl; - FL := NewList; - CurCtl := nil; // { Alexander Pravdin } - - if Applet.IsApplet then - begin - for I := 0 to Applet.ChildCount - 1 do - begin - F := Applet.fChildren.Items[ I ]; - if F <> @Self then - if F.Enabled then - begin - FL.Add( F ); - F.Enabled := FALSE; - {$IFNDEF NOT_FIX_MODAL} - Inc( F.DF.fFixingModal ); - F.AttachProc(WndProcFixModal); {**************} - {$ENDIF} - end; - end - end - else - begin - CurForm := Applet; - if Applet.Enabled then - begin - FL.Add( Applet ); - CurCtl := Applet.DF.fCurrentControl; { Alexander Pravdin } - Applet.Enabled := FALSE; - {$IFNDEF NOT_FIX_MODAL} - Inc( Applet.DF.fFixingModal ); - Applet.AttachProc(WndProcFixModal); {**************} - {$ENDIF} - end; - end; - - Inc( DF.fModal ); - Applet.DF.fModalForm := @ Self; - Enabled := TRUE; - - ModalResult := 0; - Show; - while not AppletTerminated and (ModalResult = 0) do - begin - WaitMessage; - Applet.ProcessMessages; - {$IFDEF USE_OnIdle} - ProcessIdle( @Self ); - {$ENDIF} - end; - - Dec( DF.fModal ); - Applet.DF.fModalForm := nil; - - DetachProc( WndProcShowModal ); - for I := 0 to FL.Count - 1 do - begin - F := FL.Items[ I ]; - {$IFNDEF NOT_FIX_MODAL} - Dec( F.DF.fFixingModal ); - if F.DF.fFixingModal <= 0 then - F.DetachProc(WndProcFixModal); {**************} - {$ENDIF} - F.Enabled := TRUE; - end; - FL.Free; - - if CurForm <> nil then - PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 ); - if CurCtl <> nil then CurCtl.SetFocused( TRUE ); { Alexander Pravdin } - - Result := ModalResult; -end; -{$ENDIF USE_SHOWMODALPARENTED_ALWAYS} -{$ENDIF PAS_VERSION} - -{$IFNDEF NEW_MODAL} -function TControl.ShowModalParented( const AParent: PControl ): Integer; -begin - Result := 0; -end; -{$ELSE NEW_MODAL defined} -function TControl.ShowModalParented( const AParent: PControl ): Integer; -var - FL: PList; - OldMF, F: PControl; - I: Integer; -begin - Result := 0; - if ( AParent = nil ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Inc( DF.fModal ); - FL := NewList; - OldMF := AParent.DF.fModalForm; - AParent.DF.fModalForm := @Self; - if {$IFDEF USE_FLAGS} (G3_IsApplet in AParent.fFlagsG3) - {$ELSE} AParent.fIsApplet {$ENDIF} - or ( AParent.IsMainWindow and - {$IFDEF USE_FLAGS} (G3_IsForm in AParent.fFlagsG3) - {$ELSE} AParent.fIsForm {$ENDIF} ) then - begin - for I := 0 to AParent.ChildCount - 1 do - begin - F := AParent.fChildren.Items[ I ]; - if ( F <> @Self ) - and {$IFDEF USE_FLAGS} (G3_IsForm in F.fFlagsG3) - {$ELSE} F.fIsForm {$ENDIF} - and {$IFDEF USE_FLAGS} - not(F3_Disabled in F.fStyle.f3_Style) and - (F3_Visible in F.fStyle.f3_Style) - {$ELSE} F.fEnabled and F.fVisible {$ENDIF} then - begin - FL.Add( F ); - F.Enabled := FALSE; - {$IFNDEF NOT_FIX_MODAL} - F.AttachProc(WndProcFixModal); {**************} - {$ENDIF} - end; - end; - end; - - if {$IFDEF USE_FLAGS} (G3_IsForm in AParent.fFlagsG3) - {$ELSE} AParent.fIsForm {$ENDIF} - and {$IFDEF USE_FLAGS} not(F3_Disabled in AParent.fStyle.f3_Style) - {$ELSE} AParent.Enabled {$ENDIF} then - begin - FL.Add( AParent ); - AParent.Enabled := FALSE; - end; - - ModalResult := 0; - Show; - while not AppletTerminated and ( ModalResult = 0 ) do - begin - WaitMessage; - AParent.ProcessMessages; -{$IFDEF USE_OnIdle} - ProcessIdle( @Self ); -{$ENDIF} - end; - - AParent.DF.fModalForm := OldMF; - Dec( DF.fModal ); - for I := 0 to FL.Count - 1 do - begin - F := PControl( FL.Items[ I ] ); - F.Enabled := True; - {$IFNDEF NOT_FIX_MODAL} - F.DetachProc(WndProcFixModal); {**************} - {$ENDIF} - end; - FL.Free; - Hide; - Result := ModalResult; -end; -{$ENDIF NEW_MODAL} - -function DisableWindows( W: hwnd; LPARAM: Integer ): Bool; stdcall; -var FL: PList; - Buf: Array[ 0..127 ] of AnsiChar; -begin - FL := Pointer( LPARAM ); - if IsWindowEnabled( W ) and (W <> FL.Tag) then - begin - GetClassName( W, @ Buf[ 0 ], Sizeof( Buf ) ); - if Buf <> 'ComboLBox' then - begin - FL.Add( Pointer( W ) ); - EnableWindow( W, FALSE ); - end; - end; - Result := TRUE; -end; - -function TControl.ShowModalEx: Integer; -var FL: PList; -var CurForm: PControl; - I: Integer; - W: HWnd; - CurCtl: PControl; { Alexander Pravdin } -begin - Result := 0; - if {$IFDEF USE_FLAGS} (G3_IsControl in fFlagsG3) - {$ELSE} (fIsControl) {$ENDIF} - or (fParent = nil) then - begin - Show; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - AttachProc( WndProcShowModal ); - CurForm := Applet.DF.fCurrentControl; - FL := NewList; - FL.Tag := fHandle; - // ++++ { Alexander Pravdin } - if {$IFDEF USE_FLAGS} not(G3_IsApplet in Applet.fFlagsG3) - {$ELSE} not Applet.fIsApplet {$ENDIF} then - CurCtl := Applet.DF.fCurrentControl - else CurCtl := nil; - // ---- - CreateWindow; - - EnumThreadWindows( GetCurrentThreadID, @ DisableWindows, Integer( FL ) ); - Enabled := TRUE; - - Inc( DF.fModal ); - Applet.DF.fModalForm := @ Self; - Show; - DF.fModalResult := 0; - while not AppletTerminated and (DF.fModalResult = 0) do - begin - WaitMessage; - Applet.ProcessMessages; - {$IFDEF USE_OnIdle} - ProcessIdle( @Self ); - {$ENDIF} - end; - - Dec( DF.fModal ); - Applet.DF.fModalForm := @ Self; - - DetachProc( WndProcShowModal ); - - for I := 0 to FL.Count - 1 do - begin - W := THandle( FL.Items[ I ] ); - EnableWindow( W, TRUE ); - end; - FL.Free; - - if CurForm <> nil then - PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 ); - if CurCtl <> nil then CurCtl.SetFocused( True ); { Alexander Pravdin } - Result := ModalResult; -end; - -function TControl.GetModal: Boolean; -begin - Result := DF.fModal > 0; -end; - -{$IFDEF USE_SETMODALRESULT} -procedure TControl.SetModalResult( const Value: Integer ); -begin - DF.fModalResult := Value; - if Value <> 0 then - PostMessage( GetWindowHandle, 0, 0, 0 ); -end; -{$ENDIF} - -{$IFNDEF NEW_MENU_ACCELL} -procedure TControl.DoDestroyAccelTable; -begin - if fAccelTable <> 0 then - begin - DestroyAcceleratorTable( fAccelTable ); - fAccelTable := 0; - end; -end; -{$ENDIF} - -{$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION control_clicked( Obj: PGtkWidget; Sender: PControl ): Boolean; cdecl; -BEGIN - IF Assigned( Sender.fOnClick ) THEN - Sender.fOnClick( Sender ); - Result := FALSE; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -procedure TControl.SetOnClick( const Value: TOnEvent ); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnClick := Value; - {$IFDEF GTK} - IF fEventboxHandle = fHandle THEN - BEGIN - {$IFNDEF SMALLER_CODE} - IF NOT Assigned( Value ) THEN - gtk_signal_disconnect( GTK_OBJECT( fEventboxHandle ), fClickedEvent ) - ELSE - {$ENDIF SMALLEST_CODE} - fClickedEvent := gtk_signal_connect( GTK_OBJECT( fEventboxHandle ), 'clicked', - @ control_clicked, @ Self ) - END ELSE SetMouseEvent( @ Self, 'button_release_event' ); - {$ENDIF GTK} -end; -////////////////////////////////////////////////////////////////// -// T I M E R -////////////////////////////////////////////////////////////////// - -var {$IFDEF WIN} TimerOwnerWnd: PControl; {$ENDIF} // in Linux, timer not need in a window - TimerCount: Integer = 0; - -{ -- Constructor of timer -- } - -function NewTimer( Interval: Integer ): PTimer; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TTimer'; - {$ENDIF} - if Interval <= 0 then Interval := 1000; - Result.fInterval := Interval; - Inc( TimerCount ); -end; - -{ -- Timer procedure -- } - -{$IFDEF WIN} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer; - stdcall; -begin - {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED} - if not AppletTerminated then - {$ENDIF} - if Assigned( T.fOnTimer ) then - T.fOnTimer( T ); - Result := 0; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN} - -{ TTimer } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TTimer.Destroy; -begin - Enabled := False; - inherited; - Dec( TimerCount ); - {$IFDEF WIN} - if TimerCount = 0 then - begin - TimerOwnerWnd.Free; - TimerOwnerWnd := nil; - end; - {$ENDIF WIN} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF WIN_GDI} -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TTimer.SetEnabled(const Value: Boolean); -var WasEnabled: Boolean; -begin - WasEnabled := fEnabled; - fEnabled := Value; - if WasEnabled = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF TIMER_APPLETWND} - if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - - if Value then - begin - {$IFDEF TIMER_APPLETWND} - fHandle := SetTimer( Applet.GetWindowHandle, Integer( @Self ), - fInterval, @TimerProc ); - {$ELSE} - if TimerOwnerWnd = nil then - begin - TimerOwnerWnd := _NewWindowed( nil, '', TRUE, - {$IFDEF PACK_COMMANDACTIONS} PAnsiChar( OTHER_ACTIONS ) - {$ELSE} nil {$ENDIF} ); - TimerOwnerWnd.fStyle.Value := 0; - {$IFDEF USE_FLAGS} include( TimerOwnerWnd.fFlagsG3, G3_IsControl ); - {$ELSE} TimerOwnerWnd.fIsControl := TRUE; {$ENDIF} - end; - fHandle := SetTimer( TimerOwnerWnd.GetWindowHandle, Integer( @Self ), - fInterval, @TimerProc ); - {$ENDIF} - end - else - begin - if fHandle <> 0 then - begin - KillTimer( {$IFDEF TIMER_APPLETWND} Applet.fHandle - {$ELSE} TimerOwnerWnd.fHandle {$ENDIF}, fHandle ); - fHandle := 0; - end; - end; -end; -{$ENDIF PAS_VERSION} -{$ENDIF WIN_GDI} - -{$IFDEF _X_} -{$IFDEF GTK} -FUNCTION TimerGTKTick( Sender: Pointer ): LONGBOOL; cdecl; -BEGIN - IF NOT PTimer( Sender ).fEnabled THEN Result := FALSE - ELSE - BEGIN - IF Assigned( PTimer( Sender ).fOnTimer ) THEN - Ptimer( Sender ).fOnTimer( Sender ); - Result := PTimer( Sender ).fEnabled; - END; - IF Result THEN - PTimer( Sender ).RefDec; -END; - -PROCEDURE TTimer.SetEnabled(const Value: Boolean); -BEGIN - IF FEnabled = Value THEN Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fEnabled := Value; - IF Value THEN - BEGIN - RefInc; - fHandle := gtk_timeout_add( fInterval, TimerGTKTick, @ Self ); - END ELSE - BEGIN - IF AppletTerminated THEN - BEGIN - gtk_timeout_remove( fHandle ); - RefDec; - END; - END; -END; -{$ELSE not GTK} -VAR fActiveTimerList: PTimer; - fClockPerSecond: Integer; - fAlarmHandling: Boolean; - -PROCEDURE SetAlarm; FORWARD; - -PROCEDURE AlarmHandler(SigNum: Integer); CDECL; -VAR T, NT: PTimer; - c: Integer; - count_handled: Integer; -BEGIN - c := clock; - fAlarmHandling := TRUE; // to prevent SetAlarm working while timers are handling - TRY - //--- 1. Clear fTimerHandled flag for all active timers - T := fActiveTimerList; - WHILE T <> nil DO - BEGIN - T.fTimerHandled := FALSE; - T := T.fNext; - END; - //--- 2. Handle all expired timers - count_handled := 0; - WHILE not AppletTerminated DO // until all timers expired are handled or - BEGIN // until the application is terminated - //--- 2.A. Search a timer which was expired before all others - T := fActiveTimerList; - NT := nil; - WHILE T <> nil do - BEGIN - IF not T.fTimerHandled and ( - (NT = nil) or ((T.fExpireNext - c) < (NT.fExpireNext - c)) - ) THEN - NT := T; - T := T.fNext; - END; - IF NT = nil then break; // there are no more timers expired - IF (count_handled > 0) and - ((NT.fExpireNext - c > 0) or (NT.fExpireNext < 0) and (c > 0)) then break; - //--- 2.B. Handle found timer (NT) - inc( count_handled ); // count handled timer to ensure that at least 1 timer - // was handled in result of alarm call - {$IFDEF SUPPORT_LONG_TIMER} - NT.fExpireTotal := NT.fExpireTotal - (c - NT.fTimeStart); - IF NT.fExpireTotal > 30 * 60 * fClockPerSecond then - NT.fExpireNext := c + 30 * 60 * fClockPerSecond - ELSE - NT.fExpireNext := c + NT.fExpireTotal; - {$ELSE not SUPPORT_LONG_TIMER} - NT.fExpireNext := // next time to expire this timer - NT.fExpireNext + fClockPerSecond * NT.fInterval; - {$ENDIF SUPPORT_LONG_TIMER} - NT.fTimerHandled := TRUE; // do not handle that timer again in that loop - {$IFDEF SUPPORT_LONG_TIMER} - IF NT.fExpireTotal <= 0 then - {$ENDIF SUPPORT_LONG_TIMER} - BEGIN IF NT.fMultimedia and not NT.fPeriodic then - NT.Enabled := FALSE; // one-shot timer, disable it now - IF Assigned( NT.fOnTimer ) then - NT.fOnTimer( NT ); // in result of this action, timer NT or any - // other active timer can be disabled and dropped from - // fActiveTimerList and any amount of previously disabled timers - // can be added - END; - END; - FINALLY - fAlarmHandling := FALSE; - END; - // 3. finally, install the next alarm to the nearest expirating timer if any - SetAlarm; -END; - -PROCEDURE SetAlarm; -VAR i: Integer; - T, NT: PTimer; - TV: itimerval; - c: clock_t; -BEGIN - IF AppletTerminated then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // if the application is terminated we do not install alarms - IF fAlarmHandling then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - // while alarm is handling do not reinstall alarms - c := clock; - T := fActiveTimerList; - NT := T; - WHILE T <> nil do - BEGIN - if (T.fExpireNext - c) < (NT.fExpireNext - c) then - NT := T; - T := T.fNext; - END; - IF NT = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - i := (NT.fExpireNext - c) * 1000 div fClockPerSecond; - IF i < 0 then i := 10; // 10 milliseconds as minimum time to alarm - TV.it_interval.tv_sec := 0; // set interval to alarm once - TV.it_interval.tv_usec := 0; - TV.it_value.tv_sec := i div 1000; // set time to alarm next time - TV.it_value.tv_usec := (i mod 1000) * 1000; - signal( SIGALRM, AlarmHandler ); - setitimer( ITIMER_REAL, TV, nil ); -END; - -PROCEDURE TTimer.SetEnabled(const Value: Boolean); -BEGIN - IF FEnabled = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fEnabled := Value; - IF Value then - BEGIN - IF fClockPerSecond = 0 then - fClockPerSecond := CLK_TCK; - fExpireTotal := Int64( fClockPerSecond ) * fInterval; - {$IFDEF SUPPORT_LONG_TIMER} - IF fExpireTotal > 30 * 60 * fClockPerSecond then - fExpireNext := clock + 30 * 60 * fClockPerSecond - ELSE - fExpireNext := clock + fExpireTotal; - {$ELSE} - fExpireNext := clock + fExpireTotal; - {$ENDIF SUPPORT_LONG_TIMER} - IF fActiveTimerList <> nil then - BEGIN - fNext := fActiveTimerList; - fActiveTimerList.fPrev := @ Self; - END; - fActiveTimerList := @ Self; - END ELSE - BEGIN - IF fPrev <> nil then fPrev.fNext := fNext; - IF fNext <> nil then fNext.fPrev := fPrev; - IF fActiveTimerList = @ Self then - fActiveTimerList := fNext; - fPrev := nil; - fNext := nil; - end; - if fActiveTimerList <> nil then - SetAlarm; // set alarm to the nearest expiring timer -END; -{$ENDIF not GTK} -{$ENDIF _X_} - -procedure TTimer.SetInterval(const Value: Integer); -var WasEnabled : Boolean; -begin - if fInterval = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fInterval := Value; - WasEnabled := Enabled; - Enabled := False; - Enabled := WasEnabled {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED} - and not AppletTerminated - {$ENDIF}; -end; - -{$IFDEF WIN} -{ TMMTimer } - -{ ------------ declarations moved here from MMSystem -------------------- } -const - TIME_ONESHOT = 0; { program timer for single event } - TIME_PERIODIC = 1; { program for continuous periodic event } - TIME_CALLBACK_FUNCTION = $0000; { callback is function } - TIME_CALLBACK_EVENT_SET = $0010; { callback is event - use SetEvent } - TIME_CALLBACK_EVENT_PULSE = $0020; { callback is event - use PulseEvent } - -type - TFNTimeCallBack = procedure(uTimerID, uMessage: UINT; - dwUser, dw1, dw2: DWORD) stdcall; -function timeSetEvent(uDelay, uResolution: UINT; - lpFunction: TFNTimeCallBack; dwUser: DWORD; uFlags: UINT): THandle; stdcall; - external 'winmm.dll' name 'timeSetEvent'; -function timeKillEvent(uTimerID: UINT): Integer; stdcall; - external 'winmm.dll' name 'timeKillEvent'; -{ ----------------------------------------------------------------------- } - -procedure MMTimerCallback(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD); - stdcall; -var MMTimer: PMMTimer; -begin - MMTimer := Pointer( dwUser ); - if Assigned( MMTimer.FOnTimer ) then - MMTimer.fOnTimer( MMTimer ); -end; - -function NewMMTimer( Interval: Integer ): PMMTimer; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TMMTimer'; - {$ENDIF} - Result.fInterval := Interval; - Result.FPeriodic := TRUE; -end; - -destructor TMMTimer.Destroy; -begin - Enabled := FALSE; - Inc( TimerCount ); - inherited; -end; - -procedure TMMTimer.SetEnabled(const Value: Boolean); -begin - if Value xor (fHandle <> 0) then - begin - if fHandle = 0 then - fHandle := timeSetEvent( Interval, Resolution, MMTimerCallback, DWORD( @ Self ), - Integer( Periodic ) or TIME_CALLBACK_FUNCTION ) - else - begin - timeKillEvent( fHandle ); - fHandle := 0; - end; - end; - fEnabled := Value; -end; -{$ENDIF WIN} -{$IFDEF LIN} -function NewMMTimer( Interval: Integer ): PTimer; -begin - Result := NewTimer( Interval ); - {$IFNDEF GTK} - {$IFNDEF QT} - Result.fMultimedia := TRUE; - Result.fPeriodic := TRUE; - Result.fResolution := 1; - {$ENDIF QT} - {$ENDIF GTK} -end; -{$ENDIF LIN} - -{$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -//////////////////////////////////////////////////////////////////////// -// t B I T M A P -/////////////////////////////////////////////////////////////////////// - -{ -- bitmap -- } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo; -begin - {$IFDEF KOL_ASSERTIONS} - Assert( W > 0, 'Width must be >0' ); - Assert( H > 0, 'Height must be >0' ); - {$ENDIF KOL_ASSERTIONS} - Result := AllocMem( 256*Sizeof(TRGBQuad)+Sizeof(TBitmapInfoHeader) ); - {$IFDEF KOL_ASSERTIONS} - Assert( Result <> nil, 'No memory' ); - {$ENDIF KOL_ASSERTIONS} - Result.bmiHeader.biSize := Sizeof( TBitmapInfoHeader ); - Result.bmiHeader.biWidth := W; - Result.bmiHeader.biHeight := H; // may be, -H ? - Result.bmiHeader.biPlanes := 1; - Result.bmiHeader.biBitCount := BitsPerPixel; -end; -{$ENDIF PAS_VERSION} - -const - BitsPerPixel_By_PixelFormat: array[ TPixelFormat ] of Byte = - ( 0, 1, 4, 8, 16, 16, 24, 32, 0 ); - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat; -var I: TPixelFormat; -begin - for I := High(I) downto Low(I) do - if BitsPerPixel = BitsPerPixel_By_PixelFormat[ I ] then - begin - Result := I; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := pfDevice; -end; -{$ENDIF PAS_VERSION} - -procedure DummyDetachCanvas( Sender: PBitmap ); -begin -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewBitmap( W, H: Integer ): PBitmap; -var DC: HDC; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TBitmap'; - {$ENDIF} - Result.fHandleType := bmDDB; - Result.fDetachCanvas := DummyDetachCanvas; - Result.fWidth := W; - Result.fHeight := H; - if (W <> 0) and (H <> 0) then - begin - DC := GetDC( 0 ); - Result.fHandle := CreateCompatibleBitmap( DC, W, H ); - {$IFDEF KOL_ASSERTIONS} - Assert( Result.fHandle <> 0, 'Can not create bitmap handle' ); - {$ENDIF KOL_ASSERTIONS} - ReleaseDC( 0, DC ); - end; -end; -{$ENDIF PAS_VERSION} - -const InitColors: array[ 0..17 ] of DWORD = ( $F800, $7E0, $1F, 0, $800000, $8000, - $808000, $80, $800080, $8080, $808080, $C0C0C0, $FF0000, $FF00, $FFFF00, $FF, - $FF00FF, $FFFF ); -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure PreparePF16bit( DIBHeader: PBitmapInfo ); -begin - DIBHeader.bmiHeader.biCompression := BI_BITFIELDS; - Move( InitColors[ 0 ], DIBHeader.bmiColors[ 0 ], 19*Sizeof(TRGBQUAD) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap; -const BitsPerPixel: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 ); -var BitsPixel: Integer; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TBitmap:DIBBitmap'; - {$ENDIF} - Result.fDetachCanvas := DummyDetachCanvas; - Result.fWidth := W; - Result.fHeight := H; - if (W <> 0) and (H <> 0) then - begin - BitsPixel := BitsPerPixel[ PixelFormat ]; - if BitsPixel = 0 then - begin - Result.fNewPixelFormat := DefaultPixelFormat; - BitsPixel := BitsPerPixel[DefaultPixelFormat]; - end - else - Result.fNewPixelFormat := PixelFormat; - {$IFDEF KOL_ASSERTIONS} - ASSERT( Result.fNewPixelFormat in [ pf1bit..pf32bit ], 'Strange pixel format' ); - {$ENDIF KOL_ASSERTIONS} - Result.fDIBHeader := PrepareBitmapHeader( W, H, BitsPixel ); - if PixelFormat = pf16bit then - begin - PreparePF16bit( Result.fDIBHeader ); - end; - - Result.fDIBSize := Result.ScanLineSize * H; - Result.fDIBBits := - Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, Result.fDIBSize + 16 ) ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( Result.fDIBBits <> nil, 'No memory' ); - {$ENDIF KOL_ASSERTIONS} - end; -end; -{$ENDIF PAS_VERSION} - -{ TBitmap } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.ClearData; -begin - fDetachCanvas( @Self ); - if fHandle <> 0 then - begin - DeleteObject( fHandle ); - fHandle := 0; - fDIBBits := nil; - end; - if fDIBBits <> nil then - begin - if not fDIBAutoFree then - GlobalFree( THandle( fDIBBits ) ); - fDIBBits := nil; - end; - if fDIBHeader <> nil then - begin - FreeMem( fDIBHeader ); - fDIBHeader := nil; - end; - fScanLineSize := 0; - fGetDIBPixels := nil; - fSetDIBPixels := nil; - ClearTransImage; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.Clear; -begin - RemoveCanvas; - ClearData; - fWidth := 0; - fHeight := 0; - fDIBAutoFree := FALSE; -end; -{$ENDIF PAS_VERSION} - -function TBitmap.GetBoundsRect: TRect; -begin - Result := MakeRect( 0, 0, Width, Height ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TBitmap.Destroy; -begin - Clear; - inherited; -end; -{$ENDIF PAS_VERSION} - -function TBitmap.BitsPerPixel: Integer; -var B: tagBitmap; -begin - CASE PixelFormat OF - pf1bit: Result := 1; - pf4bit: Result := 4; - pf8bit: Result := 8; - pf15bit: Result := 15; - pf16bit: Result := 16; - pf24bit: Result := 24; - pf32bit: Result := 32; - else begin - Result := 0; - if fHandle <> 0 then - if GetObject( fHandle, Sizeof( B ), @B ) > 0 then - Result := B.bmBitsPixel * B.bmPlanes; - end; - END; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.Draw(DC: HDC; X, Y: Integer); -var - DCfrom, DC0: HDC; - oldBmp: HBitmap; - oldHeight: Integer; - B: tagBitmap; -label - TRYAgain; -begin -TRYAgain: - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fHandle <> 0 then - begin - fDetachCanvas( @Self ); - oldHeight := fHeight; - if GetObject( fHandle, sizeof( B ), @B ) <> 0 then - oldHeight := B.bmHeight; - {$IFDEF KOL_ASSERTIONS} - ASSERT( oldHeight > 0, 'oldHeight must be > 0' ); - {$ENDIF KOL_ASSERTIONS} - - DC0 := GetDC( 0 ); - DCfrom := CreateCompatibleDC( DC0 ); - ReleaseDC( 0, DC0 ); - - oldBmp := SelectObject( DCfrom, fHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - - BitBlt( DC, X, Y, fWidth, oldHeight, DCfrom, 0, 0, SRCCOPY ); - {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF} - - SelectObject( DCfrom, oldBmp ); - DeleteDC( DCfrom ); - end - else - if fDIBBits <> nil then - begin - oldHeight := Abs(fDIBHeader.bmiHeader.biHeight); - {$IFDEF KOL_ASSERTIONS} - ASSERT( oldHeight > 0, 'oldHeight must be > 0' ); - ASSERT( fWidth > 0, 'Width must be > 0' ); - {$ENDIF KOL_ASSERTIONS} - if StretchDIBits( DC, X, Y, fWidth, oldHeight, 0, 0, fWidth, oldHeight, - fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY ) = 0 then - begin - if GetHandle <> 0 then - goto TRYAgain; - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.StretchDraw(DC: HDC; const Rect: TRect); -var DCfrom: HDC; - oldBmp: HBitmap; -label DrawHandle; -begin - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} -DrawHandle: - if fHandle <> 0 then - begin - fDetachCanvas( @Self ); - DCfrom := CreateCompatibleDC( 0 ); - oldBmp := SelectObject( DCfrom, fHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, - Rect.Bottom - Rect.Top, DCfrom, 0, 0, fWidth, fHeight, - SRCCOPY ); - SelectObject( DCfrom, oldBmp ); - DeleteDC( DCfrom ); - end - else - if fDIBBits <> nil then - begin - if StretchDIBits( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, - Rect.Bottom - Rect.Top, 0, 0, fWidth, fHeight, - fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY )<=0 then - begin - if GetHandle <> 0 then - goto DrawHandle; - end; - end; -end; -{$ENDIF PAS_VERSION} - -procedure TBitmap.DrawMasked(DC: HDC; X, Y: Integer; Mask: HBitmap); -begin - StretchDrawMasked( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ), Mask ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor); -begin - if TranspColor = clNone then - Draw( DC, X, Y ) - else - StretchDrawTransparent( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ), - TranspColor ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.StretchDrawTransparent(DC: HDC; const Rect: TRect; TranspColor: TColor); -begin - if TranspColor = clNone then - StretchDraw( DC, Rect ) - else - begin - if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - TranspColor := Color2RGB( TranspColor ); - if (fTransMaskBmp = nil) or (fTransColor <> TranspColor) then - begin - if fTransMaskBmp = nil then - fTransMaskBmp := NewBitmap( 0, 0 {fWidth, fHeight} ); - fTransColor := TranspColor; - // Create here mask bitmap: - fTransMaskBmp.Assign( @Self ); - fTransMaskBmp.Convert2Mask( TranspColor ); - end; - StretchDrawMasked( DC, Rect, fTransMaskBmp.Handle ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF DEBUG_DRAWTRANSPARENT} -procedure DebugDrawTransparent( DC: HDC; X, Y, W, H: Integer; PF: TPixelFormat; - const Note: AnsiString ); -const PixelFormatAsStr: array[ TPixelFormat ] of String = ( 'pfDevice', 'pf1bit', - 'pf4bit', 'pf8bit', 'pf15bit', 'pf16bit', 'pf24bit', 'pf32bit', 'pfCustom' ); -var Bmp: PBitmap; -begin - Bmp := NewDibBitmap( W, H, pf32bit ); - BitBlt( Bmp.Canvas.Handle, 0, 0, W, H, DC, X, Y, SrcCopy ); - Bmp.SaveToFile( GetStartDir + PixelFormatAsStr[ PF ] + Note ); - Bmp.Free; -end; -{$ENDIF DEBUG_DRAWTRANSPARENT} - -const - ROP_DstCopy = $00AA0029; -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.StretchDrawMasked(DC: HDC; const Rect: TRect; Mask: HBitmap); -var - DCfrom, MemDC, MaskDC: HDC; - MemBmp: HBITMAP; - //Save4From, - Save4Mem, Save4Mask: THandle; - crText, crBack: TColorRef; - {$IFDEF FIX_TRANSPBMPPALETTE} - FixBmp: PBitmap; - {$ENDIF FIX_TRANSPBMPPALETTE} -begin - {$IFDEF FIX_TRANSPBMPPALETTE} - if PixelFormat in [ pf4bit, pf8bit ] then - begin - FixBmp := NewBitmap( 0, 0 ); - FixBmp.Assign( @ Self ); - FixBmp.PixelFormat := pf32bit; - FixBmp.StretchDrawMasked( DC, Rect, Mask ); - FixBmp.Free; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - {$ENDIF FIX_TRANSPBMPPALETTE} - if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DCFrom := Canvas.Handle; - MaskDC := CreateCompatibleDC( 0 ); - Save4Mask := SelectObject( MaskDC, Mask ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( Save4Mask <> 0, 'Can not select mask bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - MemDC := CreateCompatibleDC( 0 ); - MemBmp := CreateCompatibleBitmap( DCfrom, fWidth, fHeight ); - Save4Mem := SelectObject( MemDC, MemBmp ); if Save4Mem <> 0 then; - {$IFDEF KOL_ASSERTIONS} - ASSERT( Save4Mem <> 0, 'Can not select memory bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - StretchBlt( MemDC, 0, 0, fWidth, fHeight, MaskDC, 0, 0, fWidth, fHeight, SrcCopy); - {$IFDEF DEBUG_DRAWTRANSPARENT} - DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '1SrcCopy.bmp' ); - {$ENDIF} - StretchBlt( MemDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, fWidth, fHeight, SrcErase); - {$IFDEF DEBUG_DRAWTRANSPARENT} - DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '2SrcErase.bmp' ); - {$ENDIF} - crText := SetTextColor(DC, $0); - crBack := Windows.SetBkColor(DC, $FFFFFF); - StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, - MaskDC, 0, 0, fWidth, fHeight, SrcAnd); - {$IFDEF DEBUG_DRAWTRANSPARENT} - DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '3SrcAnd.bmp' ); - {$ENDIF} - StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, - MemDC, 0, 0, fWidth, fHeight, SrcInvert); - {$IFDEF DEBUG_DRAWTRANSPARENT} - DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '4SrcInvert.bmp' ); - {$ENDIF} - Windows.SetBkColor( DC, crBack); - SetTextColor( DC, crText); - DeleteObject(MemBmp); - DeleteDC(MemDC); - SelectObject( MaskDC, Save4Mask ); - DeleteDC( MaskDC ); -end; -{$ENDIF PAS_VERSION} - -procedure ApplyBitmapBkColor2Canvas( Sender: PBitmap ); -begin - if Sender.fCanvas = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Sender.fCanvas.Brush.Color := Sender.BkColor; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure DetachBitmapFromCanvas( Sender: PBitmap ); -begin - if Sender.fCanvasAttached = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - SelectObject( Sender.fCanvas.fHandle, Sender.fCanvasAttached ); - Sender.fCanvasAttached := 0; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.GetCanvas: PCanvas; -var DC: HDC; -begin - Result := nil; - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fCanvas = nil then - begin - fApplyBkColor2Canvas := ApplyBitmapBkColor2Canvas; - fCanvas := NewCanvas( 0 ); - fCanvas.OnChange := CanvasChanged; - if fBkColor <> 0 then - fCanvas.Brush.Color := fBkColor; - end; - Result := fCanvas; - - if fCanvas.fHandle = 0 then - begin - DC := CreateCompatibleDC( 0 ); - fCanvas.Handle := DC; - fCanvasAttached := 0; - end; - - if fCanvasAttached = 0 then - begin - fCanvasAttached := SelectObject( fCanvas.Handle, fHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( fCanvasAttached <> 0, 'Can not select bitmap to DC of Canvas' ); - {$ENDIF KOL_ASSERTIONS} - end; - fDetachCanvas := DetachBitmapFromCanvas; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.GetEmpty: Boolean; -begin - Result := (fWidth = 0) or (fHeight = 0); - {$IFDEF KOL_ASSERTIONS} - ASSERT( (fWidth >= 0) and (fHeight >= 0), 'Bitmap dimensions can be negative' ); - {$ENDIF KOL_ASSERTIONS} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_noVERSION} -function TBitmap.GetHandle: HBitmap; -asm - PUSH EBX - MOV EBX, EAX - CALL GetEmpty - JZ @@exit - MOV EAX, EBX - CALL [EAX].fDetachCanvas - MOV ECX, [EBX].fHandle - INC ECX - LOOP @@exit - MOV ECX, [EBX].fDIBBits - JECXZ @@exit - PUSH ECX - PUSH 0 - CALL GetDC - PUSH EAX - PUSH 0 - PUSH 0 - LEA EDX, [EBX].fDIBBits - PUSH EDX - PUSH DIB_RGB_COLORS - PUSH [EBX].fDIBHeader - PUSH EAX - CALL CreateDIBSection - MOV [EBX].fHandle, EAX - PUSH 0 - CALL ReleaseDC - POP EAX - PUSH EAX - MOV EDX, [EBX].fDIBBits - MOV ECX, [EBX].fDIBSize - CALL System.Move - POP EAX - CMP [EBX].fDIBAutoFree, 0 - JNZ @@freed - PUSH EAX - CALL GlobalFree -@@freed:MOV [EBX].fDIBAutoFree, 1 - XOR EAX, EAX - MOV [EBX].fGetDIBPixels, EAX - MOV [EBX].fSetDIBPixels, EAX -@@exit: MOV EAX, [EBX].fHandle - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -function TBitmap.GetHandle: HBitmap; -var OldBits: Pointer; - DC0: HDC; -begin - Result := 0; - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fDetachCanvas( @ Self ); - if fHandle = 0 then - begin - if fDIBBits <> nil then - begin - OldBits := fDIBBits; - DC0 := GetDC( 0 ); - fDIBBits := nil; - fHandle := CreateDIBSection( DC0, fDIBHeader^, DIB_RGB_COLORS, - fDIBBits, 0, 0 ); - {$IFDEF DEBUG_ANY} - if fHandle = 0 then - ShowMessage( 'Can not create DIB section, error: ' + Int2Str( GetLastError ) + - ', ' + SysErrorMessage( GetLastError ) ); - {$ELSE} - {$IFDEF KOL_ASSERTIONS} - ASSERT( fHandle <> 0, 'Can not create DIB section, error: ' + Int2Str( GetLastError ) + - ', ' + SysErrorMessage( GetLastError ) ); - {$ENDIF KOL_ASSERTIONS} - {$ENDIF DEBUG_ANY} - ReleaseDC( 0, DC0 ); - if fHandle <> 0 then - begin - Move( OldBits^, fDIBBits^, fDIBSize ); - if not fDIBAutoFree then - GlobalFree( THandle( OldBits ) ); - fDIBAutoFree := TRUE; - - fGetDIBPixels := nil; - fSetDIBPixels := nil; - end - else - fDIBBits := OldBits; - end; - end; - Result := fHandle; -end; -{$ENDIF PAS_VERSION} - -function TBitmap.GetHandleAllocated: Boolean; -begin - Result := fHandle <> 0; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.LoadFromFile(const Filename: KOLString); -var Strm: PStream; -begin - Strm := NewReadFileStream( Filename ); - LoadFromStream( Strm ); - Strm.Free; -end; -{$ENDIF PAS_VERSION} - -procedure TBitmap.LoadFromResourceID(Inst: DWORD; ResID: Integer); -begin - LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ) ); -end; - -{$IFDEF ASM_UNICODE}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.LoadFromResourceName(Inst: DWORD; ResName: PKOLChar); -var ResHandle: HBitmap; - Flg: DWORD; -begin - Clear; - Flg := 0; - if fHandleType = bmDIB then - Flg := LR_CREATEDIBSECTION; - ResHandle := LoadImage( Inst, ResName, IMAGE_BITMAP, 0, 0, LR_DEFAULTSIZE or Flg ); - if ResHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Handle := ResHandle; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF F_P} -type - TBITMAPFILEHEADER = packed record - bfType: Word; - bfSize: DWORD; - bfReserved1: Word; - bfReserved2: Word; - bfOffBits: DWORD; - end; -{$ENDIF} - -{$IFDEF ASM_noVERSION} // error + 16Colors->swap(Gray,Silver) + Core -procedure TBitmap.LoadFromStream(Strm: PStream); -type tBFH = TBitmapFileHeader; - tBIH = TBitmapInfoHeader; -const szBIH = Sizeof( tBIH ); - szBFH = Sizeof( tBFH ); -asm - PUSH EBX - PUSH ESI - MOV EBX, EAX - PUSH EDX - CALL Clear - POP ESI - MOV EAX, ESI - CALL TStream.GetPosition - PUSH EAX // [EBP+4] = Strm.Pos (starting pos) - PUSH EBP - MOV EBP, ESP - ADD ESP, -(szBIH + szBFH) - // reading bitmap - XOR ECX, ECX - MOV [EBX].fHandleType, CL - MOV CL, szBFH - MOV EDX, ESP - PUSH ECX - MOV EAX, ESI - CALL TStream.Read - POP ECX - SUB ECX, EAX - JNZ @@eread1 - CMP [ESP].tBFH.bfType, $4D42 - JE @@1 - MOV EDX, [EBP+4] - MOV EAX, ESI - CALL TStream.Seek - XOR EAX, EAX - XOR EDX, EDX - JMP @@2 -@@1: - MOV EDX, [ESP].tBFH.bfSize - MOV EAX, [ESP].tBFH.bfOffBits -@@2: - PUSH EDX // Push Size - PUSH EAX // Push Off - XOR ECX, ECX - MOV CL, szBIH - LEA EDX, [EBP-szBIH] - MOV EAX, ESI - PUSH ECX - CALL TStream.Read // read BIH - POP ECX -@@eread1: - XOR ECX, EAX - JNZ @@eread - MOVZX EAX, [EBP-szBIH].tBIH.biBitCount - MOVZX EDX, [EBP-szBIH].tBIH.biPlanes - MUL EDX - CALL Bits2PixelFormat - {$IFDEF PARANOIA} DB $3C, pf15bit {$ELSE} CMP AL, pf15bit {$ENDIF} - JNZ @@no15bit - CMP [EBP-szBIH].tBIH.biCompression, 0 - JZ @@no15bit - INC AL // AL = pf16bit -@@no15bit: - MOV [EBX].fNewPixelFormat, AL - MOV EAX, szBIH + 1024 - CALL System.@GetMem - MOV [EBX].fDIBHeader, EAX - XCHG EDX, EAX - LEA EAX, [EBP-szBIH] - XOR ECX, ECX - MOV CL, szBIH - CALL System.Move - MOV EAX, [EBP-szBIH].tBIH.biWidth - MOV [EBX].fWidth, EAX - MOV EAX, [EBP-szBIH].tBIH.biHeight - TEST EAX, EAX - JGE @@20 - NEG EAX -@@20: MOV [EBX].fHeight, EAX - MOV EAX, EBX - CALL GetScanLineSize - MOV EDX, [EBX].fHeight - MUL EDX - MOV [EBX].fDIBSize, EAX - PUSH EAX - PUSH GMEM_FIXED or GMEM_ZEROINIT - CALL GlobalAlloc - MOV [EBX].fDIBBits, EAX - MOVZX EAX, [EBP-szBIH].tBIH.biBitCount - {$IFDEF PARANOIA} DB $3C, 8 {$ELSE} CMP AL, 8 {$ENDIF} - JA @@3 - MOV AL, 4 - MOVZX ECX, [EBP-szBIH].tBIH.biBitCount - SAL EAX, CL - XCHG ECX, EAX -@@3: - CMP [EBX].TBitmap.fNewPixelFormat, pf16bit - JNE @@30 - XOR ECX, ECX - MOV CL, 12 // ColorCount = 12 -@@30: - POP EAX // EAX = off - TEST EAX, EAX - JLE @@4 - SUB EAX, szBFH + szBIH - CMP EAX, ECX - JZ @@4 - XCHG ECX, EAX -@@4: - JECXZ @@5 - PUSH ECX - MOV EDX, [EBX].fDIBHeader - ADD EDX, szBIH - MOV EAX, ESI - CALL TStream.Read - POP ECX - XOR EAX, ECX - JNZ @@eread -@@5: - MOV ECX, [EBX].fDIBSize -@@7: - PUSH ECX - MOV EAX, ESI - CALL TStream.GetPosition - PUSH EAX - MOV EAX, ESI - CALL TStream.GetSize - POP EDX - SUB EAX, EDX - POP ECX // Size = fDIBSize - CMP EAX, ECX // Strm.Size - Strm.Position > Size ? - JL @@8 - XCHG ECX, EAX -@@8: // ++++++++++++++ 26-Oct-2003 VK see comment in Pascal - MOV EAX, [EBX].fDIBSize - CMP ECX, EAX - JGE @@9 - SUB EAX, ECX - PUSH EAX - MOV EAX, ESI - PUSH ECX - CALL TStream.GetPosition - POP ECX - POP EDX - CMP EDX, EAX - JG @@9 - MOV EAX, ESI - NEG EDX - XOR ECX, ECX - INC ECX - CALL TStream.Seek - MOV ECX, [EBX].fDIBSize -@@9: // ++++++++++++++ - PUSH ECX - MOV EDX, [EBX].fDIBBits - MOV EAX, ESI - CALL TStream.Read - POP ECX - XOR EAX, ECX - POP EAX // Strm.Size - Position - POP ECX // fDIBSize - // end of reading bitmap -@@eread: - MOV ESP, EBP - POP EBP - POP EDX - JZ @@exit - // not success: - XCHG EAX, ESI - XOR ECX, ECX // ECX = spBegin - CALL TStream.Seek - XCHG EAX, EBX - CALL Clear -@@exit: POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.LoadFromStream(Strm: PStream); -type - TColorsArray = array[ 0..15 ] of TColor; - PColorsArray = ^TColorsArray; - PColor = ^TColor; -var Pos : DWORD; - BFH : TBitmapFileHeader; - - function ReadBitmap : Boolean; - var Size, Size1: Integer; - BCH: TBitmapCoreHeader; - RGBSize: DWORD; - C: PColor; - Off, HdSz, ColorCount: DWORD; - begin - fHandleType := bmDIB; - Result := False; - if Strm.Read( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit; {>>>>>>>>>} - Off := 0; Size := 0; - if BFH.bfType <> $4D42 then - Strm.Seek( Pos, spBegin ) - else - begin - Off := BFH.bfOffBits - Sizeof( BFH ); - Size := BFH.bfSize; // don't matter, just <> 0 is good - end; - RGBSize := 4; - HdSz := Sizeof( TBitmapInfoHeader ); - fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + HdSz ); - if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( DWORD ) ) <> Sizeof( DWORD ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fDIBHeader.bmiHeader.biSize = HdSz then - begin - if Strm.Read( fDIBHeader.bmiHeader.biWidth, HdSz - Sizeof( DWORD ) ) <> - HdSz - Sizeof( DWORD ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end - else - if fDIBHeader.bmiHeader.biSize = Sizeof( TBitmapCoreHeader ) then - begin - RGBSize := 3; - HdSz := Sizeof( TBitmapCoreHeader ); - if Strm.Read( BCH.bcWidth, HdSz - Sizeof( DWORD ) ) <> - HdSz - Sizeof( DWORD ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader ); - fDIBHeader.bmiHeader.biWidth := BCH.bcWidth; - fDIBHeader.bmiHeader.biHeight := BCH.bcHeight; - fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes; - fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount; - end else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount - * fDIBHeader.bmiHeader.biPlanes ); - {$IFDEF KOL_ASSERTIONS} - if (fNewPixelFormat = pf15bit) and (fDIBHeader.bmiHeader.biCompression <> BI_RGB) then - begin - ASSERT( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' ); - end; - {$ENDIF KOL_ASSERTIONS} - fWidth := fDIBHeader.bmiHeader.biWidth; - {$IFDEF KOL_ASSERTIONS} - ASSERT( fWidth > 0, 'Bitmap width must be > 0' ); - {$ENDIF KOL_ASSERTIONS} - fHeight := Abs(fDIBHeader.bmiHeader.biHeight); - {$IFDEF KOL_ASSERTIONS} - ASSERT( fHeight > 0, 'Bitmap height must be > 0' ); - {$ENDIF KOL_ASSERTIONS} - - fDIBSize := ScanLineSize * fHeight; - fDIBBits := - Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, fDIBSize ) ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( fDIBBits <> nil, 'No memory' ); - {$ENDIF KOL_ASSERTIONS} - - ColorCount := 0; - if fDIBHeader.bmiHeader.biBitCount <= 8 then - begin - if fDIBHeader.bmiHeader.biClrUsed > 0 then - ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad ) - else - ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad ) - end - else if (fNewPixelFormat in [ pf16bit ]) or - (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then - ColorCount := 12; - - if Off > 0 then - begin - Off := Off - HdSz; - if (Off <> ColorCount) then - if not(fNewPixelFormat in [pf15bit,pf16bit]) - or (Off = 0) //+++ to fix loading 15- and 16-bit bmps with mask omitted - then - ColorCount := Min( 1024, Off ); - end; - if ColorCount <> 0 then - begin - if Off >= ColorCount then - Off := Off - ColorCount; - if RGBSize = 4 then - begin - if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount ) - <> DWORD( ColorCount ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end - else - begin - C := @ fDIBHeader.bmiColors[ 0 ]; - while ColorCount > 0 do - begin - if Strm.Read( C^, RGBSize ) <> RGBSize then Exit; {>>>>>>>>>>>>>>>} - Dec( ColorCount, RGBSize ); - Inc( C ); - end; - end; - end; - if Off > 0 then - Strm.Seek( Off, spCurrent ); - if (Size = 0) or (Strm.Size <= 0) then - Size := fDIBSize - else - Size := Min( fDIBSize, Strm.Size - Strm.Position ); - Size1 := Min( Size, fDIBSize ); - - if (Size1 < fDIBSize) - and (DWORD( fDIBSize - Size1 ) <= Strm.Position) then - begin - Strm.Seek( Size1 - fDIBSize, spCurrent ); - Size1 := fDIBSize; - end; - if Size1 > fDIBSize then Size1 := fDIBSize; - // +++++++++++++++++++ to fix some "incorrect" bitmaps while loading - if Strm.Read( fDIBBits^, Size1 ) <> DWORD( Size1 ) then Exit; {>>>>>>>>>>} - if Size > Size1 then - Strm.Seek( Size - Size1, spCurrent ); - Result := True; - end; -begin - Clear; - Pos := Strm.Position; - if not ReadBitmap then - begin - Strm.Seek( Pos, spBegin ); - Clear; - end; -end; -{$ENDIF PAS_VERSION} - -////////////////// bitmap RLE-decoding and loading - by Vyacheslav A. Gavrik - -// by Vyacheslav A. Gavrik -procedure DecodeRLE4(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD); - procedure OddMove(Src,Dst:PByte;Size:Integer); - begin - if Size=0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - repeat - Dst^:=(Dst^ and $F0)or(Src^ shr 4); - Inc(Dst); - Dst^:=(Dst^ and $0F)or(Src^ shl 4); - Inc(Src); - Dec(Size); - until Size=0; - end; - procedure OddFill(Mem:PByte;Size,Value:Integer); - begin - Value:=(Value shr 4)or(Value shl 4); - Mem^:=(Mem^ and $F0)or(Value and $0F); - Inc(Mem); - if Size>1 then FillChar(Mem^,Size,Char( Value )) - else Mem^:=(Mem^ and $0F)or(Value and $F0); - end; -var - pb: PByte; - x,y,z,i: Integer; -begin - pb:=Data; x:=0; y:=0; - if Bmp.fScanLineSize = 0 then - Bmp.ScanLineSize; - while (y Sizeof( BFH ) then Exit; {>>>>>>>>>} - Off := 0; Size := 0; - ColorTriples := FALSE; - if BFH.bfType <> $4D42 then - begin - Strm.Seek( Pos, spBegin ); - BFH.bfOffBits := 0; - BFH.bfSize := 0; - end - else - begin - BFHValid := TRUE; - Off := BFH.bfOffBits; - Size := BFH.bfSize; - end; - fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + sizeof(TBitmapInfoHeader) ); - if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( fDIBHeader.bmiHeader.biSize ) ) <> - Sizeof( fDIBHeader.bmiHeader.biSize ) then Exit; {>>>>>>>>>>>>>>>>>>>>>} - if (fDIBHeader.bmiHeader.biSize <> Sizeof( TBITMAPCOREHEADER )) and - (fDIBHeader.bmiHeader.biSize <> Sizeof( TBitmapInfoHeader )) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - L := fDIBHeader.bmiHeader.biSize - Sizeof( fDIBHeader.bmiHeader.biSize ); - if (fDIBHeader.bmiHeader.biSize = Sizeof( TBITMAPCOREHEADER )) then - begin - if Strm.Read( BCH.bcWidth, L ) <> L then Exit; {>>>>>>>>>>>>>>>>>>>>>>>} - fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader ); - fDIBHeader.bmiHeader.biWidth := BCH.bcWidth; - fDIBHeader.bmiHeader.biHeight := BCH.bcHeight; - fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes; - fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount; - ColorTriples := TRUE; - end - else - begin - if Strm.Read( fDIBHeader.bmiHeader.biWidth, L) <> L then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount - * fDIBHeader.bmiHeader.biPlanes ); - fWidth := fDIBHeader.bmiHeader.biWidth; - {$IFDEF KOL_ASSERTIONS} - ASSERT( fWidth > 0, 'Bitmap width must be > 0' ); - {$ENDIF KOL_ASSERTIONS} - fHeight := Abs(fDIBHeader.bmiHeader.biHeight); - {$IFDEF KOL_ASSERTIONS} - ASSERT( fHeight > 0, 'Bitmap height must be > 0' ); - {$ENDIF KOL_ASSERTIONS} - - fDIBSize := ScanLineSize * fHeight; - ZI := 0; - if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or - (fDIBHeader.bmiHeader.biCompression = BI_RLE4) then - ZI := GMEM_ZEROINIT; - fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED or ZI, fDIBSize + 4 ) ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( fDIBBits <> nil, 'No memory' ); - ASSERT( (fDIBHeader.bmiHeader.biCompression and - (BI_RLE8 or BI_RLE4 or BI_RLE8 or BI_BITFIELDS) <> 0) or - (fDIBHeader.bmiHeader.biCompression = BI_RGB), - 'Unknown compression algorithm'); - {$ENDIF KOL_ASSERTIONS} - - ColorCount := 0; - if fDIBHeader.bmiHeader.biBitCount <= 8 then - begin - if fDIBHeader.bmiHeader.biClrUsed > 0 then - ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad ) - else - ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad ) - end - else if (fNewPixelFormat in [ pf15bit, pf16bit ]) or - (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then - begin - if (Strm.Size = 0) or (Strm.Size - Strm.Position - DWORD( Size ) >= 12) then - ColorCount := 12; - end; - - if ColorTriples then - ColorCount := ColorCount div 4 * 3; - - if Off > 0 then - begin - if ColorTriples then - Off := Off - SizeOf( TBitmapFileHeader ) - Sizeof( TBitmapCoreHeader ) - else Off := Off - SizeOf( TBitmapFileHeader ) - Sizeof( TBitmapInfoHeader ); - if (Off <> ColorCount) and (fNewPixelFormat <= pf8bit) then - if ColorTriples then - ColorCount := min( Off, 3 * 256 ) - else - ColorCount := min( Off, 4 * 256 ); - end; - if (fNewPixelFormat in [ pf15bit, pf16bit ]) then - if (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then - begin - PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := ( $00001F ); - PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := ( $0007E0 ); - TColor( fDIBHeader.bmiColors[ 0 ] ) := ( $00F800 ); - end else - ColorCount := 0; - - if ColorCount <> 0 then - if ColorTriples then - begin - PColr := @ fDIBheader.bmiColors[ 0 ]; - while ColorCount >= 3 do - begin - if strm.Read( PColr^, 3 ) <> 3 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>} - Inc( PColr ); - Dec( ColorCount, 3 ); - end; - end else - begin - if (Integer( Strm.Size - Strm.Position ) > fDIBSize) or - (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or - (fDIBHeader.bmiHeader.biCompression = BI_RLE4) then - begin - if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount ) - <> DWORD( ColorCount ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Off - ColorCount > 0 then - Strm.Position := Integer( Strm.Position ) + Off - ColorCount; - end; - end; - - if not BFHValid then - Size := fDIBSize - else - if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or - (fDIBHeader.bmiHeader.biCompression = BI_RLE4) then - begin - //if BFHValid then //-- already TRUE here - Size := BFH.bfSize - BFH.bfOffBits; - end - else - begin - if (Strm.Size = 0) or - (Integer( Strm.Size - BFH.bfOffBits - Pos ) > Integer(Size)) then - Size := fDIBSize - else - Size := Strm.Size - BFH.bfOffBits - DWORD( Pos ); - if Size > fDIBSize then Size := fDIBSize - else if (Size < fDIBSize) and (fDIBheader.bmiHeader.biClrUsed <> 0) then - begin - BFHValid := FALSE; - Strm.Position := Strm.Position + fDIBheader.bmiHeader.biClrUsed * 4; - Size := Strm.Size - Strm.Position; - end; - end; - - if (fDIBHeader.bmiHeader.biCompression = BI_RGB) or - (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then - begin - if BFHValid and - ( (Strm.Size > 0) and - (Integer( Strm.Size - BFH.bfOffBits - Pos) > Integer(Size)) - or - (Strm.Size = 0) and - (Off > 0) - ) then - if Integer( Strm.Position - Pos ) <= Integer( BFH.bfOffbits ) then - Strm.Position := Pos + BFH.bfOffbits; - i := Strm.Read( fDIBBits^, Size ); - if i <> Size then - begin - {$IFDEF FILL_BROKEN_BITMAP} - ZeroMemory( Pointer( Integer( fDIBBits ) + i ), Size - i ); - {$ENDIF FILL_BROKEN_BITMAP} - end; - end - else - begin - if (Integer( fDIBHeader.bmiHeader.biSizeImage ) > 0) and - (Integer( fDIBHeader.bmiHeader.biSizeImage ) < Size) then - Size := Integer( fDIBHeader.bmiHeader.biSizeImage ); // - ColorCount; - // it is possible that bitmap "compressed" with RLE has size - // greater then non-compressed one: - FinalPos := Strm.Position + DWORD( Size ); - L := Strm.Size - Strm.Position; - if L > DWORD( Size ) then - L := Size; - Buffer := AllocMem( Size * 3 ); - if Strm.Read(Buffer^,L) <> DWORD( L ) then ; - if fDIBHeader.bmiHeader.biCompression=BI_RLE8 then - DecodeRLE8(@Self,Buffer,Size * 3) - else - DecodeRLE4(@Self,Buffer,Size * 3); - Strm.Position := FinalPos; - fDIBHeader.bmiHeader.biCompression := BI_RGB; - FreeMem(Buffer); - end; - - Result := True; - end; -begin - Clear; - Pos := Strm.Position; - result := ReadBitmap; - if not result then - begin - Strm.Seek( Pos, spBegin ); - Clear; - end; -end; - -/////////////////////////// - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.ReleaseHandle: HBitmap; -var OldBits: Pointer; -begin - HandleType := bmDIB; - Result := GetHandle; - if Result = 0 then Exit; // only when bitmap is empty {>>>>>>>>>>>>>>>>>>>>>>} - if fDIBAutoFree then - begin - OldBits := fDIBBits; - fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) ); - Move( OldBits^, fDIBBits^, fDIBSize ); - fDIBAutoFree := FALSE; - end; - fHandle := 0; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.SaveToFile(const Filename: KOLString); -var Strm: PStream; -begin - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Strm := NewWritefileStream( Filename ); - SaveToStream( Strm ); - Strm.Free; -end; -{$ENDIF PAS_VERSION} - -procedure TBitmap.CoreSaveToFile(const Filename: KOLString); -var Strm: PStream; -begin - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Strm := NewWritefileStream( Filename ); - CoreSaveToStream( Strm ); - Strm.Free; -end; - -procedure TBitmap.RLESaveToFile(const Filename: KOLString); -var Strm: PStream; -begin - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Strm := NewWritefileStream( Filename ); - RLESaveToStream( Strm ); - Strm.Free; -end; - -{$IFDEF ASM_STREAM} -procedure TBitmap.SaveToStream(Strm: PStream); -type tBFH = TBitmapFileHeader; - tBIH = TBitmapInfoHeader; -const szBIH = Sizeof( tBIH ); - szBFH = Sizeof( tBFH ); -asm - PUSH EBX - PUSH ESI - MOV EBX, EAX - MOV ESI, EDX - CALL GetEmpty - JZ @@exit - MOV EAX, ESI - CALL TStream.GetPosition - PUSH EAX - - MOV EAX, EBX - XOR EDX, EDX // EDX = bmDIB - CALL SetHandleType - XOR EAX, EAX - MOV EDX, [EBX].fDIBHeader - MOVZX ECX, [EDX].TBitmapInfoHeader.biBitCount - CMP CL, 8 - JG @@1 - MOV AL, 4 - SHL EAX, CL -@@1: - PUSH EAX // ColorsSize - LEA ECX, [EAX + szBFH + szBIH] - CMP [EDX].TBitmapInfoHeader.biCompression, 0 - JZ @@10 - ADD ECX, 74 -@@10: - PUSH ECX // BFH.bfOffBits - PUSH 0 - ADD ECX, [EBX].fDIBSize - PUSH ECX - MOV CX, $4D42 - PUSH CX - XOR ECX, ECX - MOV EDX, ESP - MOV CL, szBFH - PUSH ECX - MOV EAX, ESI - CALL TStream.Write - POP ECX - ADD ESP, szBFH - XOR EAX, ECX - POP ECX // ColorsSize - JNZ @@ewrite - MOV EDX, [EBX].fDIBHeader - CMP [EDX].TBitmapInfoHeader.biCompression, 0 - JZ @@11 - ADD ECX, 74 -@@11: - ADD ECX, szBIH - PUSH ECX - MOV EAX, ESI - CALL TStream.Write - POP ECX - XOR EAX, ECX - JNZ @@ewrite - - MOV ECX, [EBX].fDIBSize - MOV EDX, [EBX].fDIBBits - MOV EAX, ESI - PUSH ECX - CALL TStream.Write - POP ECX - XOR EAX, ECX -@@ewrite: - POP EDX - JZ @@exit - XCHG EAX, ESI - XOR ECX, ECX - CALL TStream.Seek -@@exit: - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.SaveToStream(Strm: PStream); -var BFH : TBitmapFileHeader; - Pos : Integer; - function WriteBitmap : Boolean; - var ColorsSize, BitsSize, Size : Integer; - begin - Result := False; - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - HandleType := bmDIB; // convert to DIB if DDB - ZeroMemory( @BFH, Sizeof( BFH ) ); - ColorsSize := 0; - with fDIBHeader.bmiHeader do - if biBitCount <= 8 then - ColorsSize := (1 shl biBitCount) * Sizeof( TRGBQuad ); - BFH.bfOffBits := Sizeof( BFH ) + Sizeof( TBitmapInfoHeader ) + ColorsSize; - BitsSize := fDIBSize; //ScanLineSize * fHeight; - BFH.bfSize := BFH.bfOffBits + DWord( BitsSize ); - BFH.bfType := $4D42; // 'BM'; - if fDIBHeader.bmiHeader.biCompression <> 0 then - begin - ColorsSize := 12 + 16*sizeof(TRGBQuad); - Inc( BFH.bfOffBits, ColorsSize ); - end; - if Strm.Write( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit; {>>>>>>>>} - Size := Sizeof( TBitmapInfoHeader ) + ColorsSize; - if Strm.Write( fDIBHeader^, Size ) <> DWORD(Size) then Exit; {>>>>>>>>>>>} - if Strm.Write( fDIBBits^, BitsSize ) <> DWord( BitsSize ) then Exit; {>>>} - Result := True; - end; -begin - Pos := Strm.Position; - if not WriteBitmap then - Strm.Seek( Pos, spBegin ); -end; -{$ENDIF PAS_VERSION} - -procedure TBitmap.CoreSaveToStream(Strm: PStream); -type TRGBTriple = packed record - bRed, bGreen, bBlue: Byte; - end; -var BFH : TBitmapFileHeader; - Pos : Integer; - function WriteCoreBitmap : Boolean; - var ColorsSize, ColorsCount, BitsSize, i: Integer; - CH: TBitmapCoreHeader; - begin - Result := False; - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - HandleType := bmDIB; // convert to DIB if DDB - ZeroMemory( @BFH, Sizeof( BFH ) ); - ColorsSize := 0; - ColorsCount := 1 shl fDIBHeader.bmiHeader.biBitCount; - with fDIBHeader.bmiHeader do - if biBitCount <= 8 then - ColorsSize := ColorsCount * Sizeof( TRGBTriple ); - BFH.bfOffBits := Sizeof( BFH ) + Sizeof( CH ) + ColorsSize; - BitsSize := fDIBSize; //ScanLineSize * fHeight; - BFH.bfSize := BFH.bfOffBits + DWord( BitsSize ); - BFH.bfType := $4D42; // 'BM'; - - if Strm.Write( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit; {>>>>>>>>} - CH.bcSize := Sizeof( CH ); - CH.bcWidth := Width; - CH.bcHeight := Height; - CH.bcPlanes := 1; - CH.bcBitCount := fDIBHeader.bmiHeader.biBitCount; - if Strm.Write( CH, Sizeof( CH ) ) <> Sizeof(CH) then Exit; {>>>>>>>>>>>>>} - for i := 0 to ColorsCount-1 do - begin - if Strm.Write( fDIBHeader.bmiColors[i], 3 ) <> 3 then Exit; {>>>>>>>} - end; - if Strm.Write( fDIBBits^, BitsSize ) <> DWord( BitsSize ) then Exit; {>>>} - Result := True; - end; -begin - if (fDIBHeader.bmiHeader.biBitCount > 8) - or (fDIBHeader.bmiHeader.biCompression <> 0) then - begin - SaveToStream( Strm ); Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Pos := Strm.Position; - if not WriteCoreBitmap then - Strm.Seek( Pos, spBegin ); -end; - -procedure TBitmap.RLESaveToStream(Strm: PStream); -var BFH : TBitmapFileHeader; - Pos : Integer; - MS: PStream; - function CountZeroes( P: PByte; maxBytes: Integer ): Integer; - begin - Result := 0; - while (P^ = 0) and (Result < maxBytes) do - begin - inc( P ); - inc( Result ); - end; - end; - function CountSame( P: PByte; maxBytes: Integer ): Integer; - var B: Byte; - begin - Result := 1; - B := P^; - while maxBytes > 1 do - begin - inc(P); - if P^ <> B then break; - inc(Result); - dec(maxBytes); - end; - end; - function CountSame2( P: PByteArray; maxPixels: Integer ): Integer; - var B1, B2: Byte; - i: Integer; - begin - Result := 2; - B1 := P[0]; - B2 := P[1]; - i := 0; - dec( maxPixels, 2 ); - while maxPixels > 0 do - begin - inc(i, 2); - if P[i] <> B1 then break; - inc(Result); - dec(maxPixels); - if maxPixels = 0 then break; - if P[i+1] <> B2 then break; - inc(Result); - dec(maxPixels); - end; - end; - function CountDiff( P: PByte; maxBytes: Integer; minSame: Integer ): Integer; - var Cnt: Integer; - begin - Result := 1; - while (maxBytes > 1) do - begin - inc(P); - dec(maxBytes); - Cnt := CountSame( P, maxBytes ); - if Cnt >= minSame then - break; - inc( Result ); - end; - end; - function CountDiff2( P: PByte; maxPixels: Integer; minSame: Integer ): Integer; - var Cnt: Integer; - begin - Result := 1; - while (maxPixels > 1) do - begin - inc(P); - dec(maxPixels); - Cnt := CountSame2( Pointer( P ), maxPixels ); - if Cnt >= minSame then - break; - inc( Result ); - end; - end; - procedure WriteOffset( dx, dy: Integer ); - var b: Byte; - begin - while (dx > 0) or (dy > 0) do - begin - Strm.WriteVal( 0, 1 ); - Strm.WriteVal( 2, 1 ); - b := min( dx, 255 ); - Strm.WriteVal( b, 1 ); - dec( dx, b ); - b := min( dy, 255 ); - Strm.WriteVal( b, 1 ); - dec( dy, b ); - end; - end; - procedure WriteRep( cnt: Integer; Value: Byte ); - var n: Integer; - begin - while cnt > 0 do - begin - n := min( cnt, 255 ); - dec( cnt, n ); - while (cnt > 0) and (cnt < 3) do - begin - inc( cnt ); - dec( n ); - end; - Strm.WriteVal( n, 1 ); - Strm.WriteVal( Value, 1 ); - end; - end; - procedure WriteRun( P: PByte; cnt: Integer ); - var n: Integer; - begin - while cnt > 0 do - begin - n := min( cnt, 255 ); - dec( cnt, n ); - if (cnt < 3) and (n = 255) then - begin - inc( cnt, 2 ); - dec( n, 2 ); - end; - if n > 2 then - begin - Strm.WriteVal( 00, 1 ); - Strm.WriteVal( n, 1 ); - Strm.Write( P^, n ); - inc( P, n ); - if n and 1 <> 0 then - Strm.WriteVal( 00, 1 ); - end else - while n > 0 do - begin - Strm.WriteVal( 01, 1 ); - Strm.Write( P^, 1 ); - inc( P ); - dec( n ); - end; - end; - end; - procedure WriteRun2( P: PByteArray; cnt: Integer ); - var n, i, L: Integer; - begin - i := 0; - while cnt > 0 do - begin - n := min( cnt, 252 ); - dec( cnt, n ); - if (cnt < 3) and (n = 252) then - begin - inc( n, cnt ); - cnt := 0; - end; - if n > 2 then - begin - Strm.WriteVal( 00, 1 ); - Strm.WriteVal( n, 1 ); - L := 0; - while n > 0 do - begin - Strm.WriteVal( P[i] shl 4 or P[i+1], 1 ); - inc( i, 2 ); - dec( n, 2 ); - inc( L ); - end; - if L and 1 <> 0 then - Strm.WriteVal( 0, 1 ); - end else - while n > 0 do - begin - if n = 1 then - Strm.WriteVal( 01, 1 ) - else - Strm.WriteVal( 02, 1 ); - Strm.WriteVal( P[i] shl 4 or P[i+1], 1 ); - inc( i, 2 ); - dec( n, 2 ); - end; - end; - end; - function WriteRLE4: Boolean; - var line_len_left, y, cnt: Integer; - P, Pnext: PByte; - PnextLine: PByte; - offX, offY: Integer; - begin - y := 0; - P := MS.Memory; - while y < Height do - begin - line_len_left := Width; - PnextLine := P; inc( PnextLine, line_len_left ); - while line_len_left > 0 do - begin - if P^ = 0 then - begin - cnt := CountZeroes( P, line_len_left + (Height-y-1)*Width ); - if cnt > 3 then - begin // generate offset - offY := cnt div Width; - offX := cnt - offY * Width; - if (offX < 0) - or (offY = 0) and (offX >= line_len_left) - or (line_len_left < offX) then - begin - inc( P, line_len_left ); - break; - end; - if offY > 0 then - begin - WriteOffset( offX, offY ); - inc( P, cnt ); - dec( line_len_left, offX ); - inc( Y, offY ); - continue; - end; - end; - end; - cnt := CountSame2( Pointer( P ), line_len_left ); - if cnt >= 3 then - begin - Pnext := P; inc( Pnext ); - WriteRep( cnt, (P^ shl 4) or (Pnext^) ); - inc( P, cnt ); - dec( line_len_left, cnt ); - end else - begin - cnt := CountDiff2( P, line_len_left, 3 ); - WriteRun2( Pointer( P ), cnt ); - inc( P, cnt ); - dec( line_len_left, cnt ); - end; - end; - Strm.WriteVal( 0, 1 ); - if y < Height-1 then - Strm.WriteVal( 0, 1 ) // EOL - else Strm.WriteVal( 1, 1 ); // EOB - inc(y); - if ( Integer( P ) - Integer( PnextLine ) ) mod Width <> 0 then - begin {$IFNDEF PAS_ONLY} - asm - nop - end;{$ENDIF} - end; - end; - Result := TRUE; - end; - function WriteRLE8: Boolean; - var line_len_left, y, cnt: Integer; - P: PByte; - //Pnext: PByte; - offX, offY: Integer; - begin - y := 0; - P := MS.Memory; - while y < Height do - begin - line_len_left := Width; - //Pnext := P; inc( Pnext, line_len_left ); - while line_len_left > 0 do - begin - if P^ = 0 then - begin - cnt := CountZeroes( P, line_len_left + (Height-y-1)*Width ); - if cnt > 3 then - begin // generate offset - offY := cnt div Width; - offX := cnt - offY * Width; - if (offX < 0) - or (offY = 0) and (offX >= line_len_left) - or (line_len_left < offX) then - begin - inc( P, line_len_left ); - break; - end; - if offY > 0 then - begin - WriteOffset( offX, offY ); - inc( P, cnt ); - dec( line_len_left, offX ); - inc( Y, offY ); - continue; - end; - end; - end; - cnt := CountSame( P, line_len_left ); - if cnt >= 2 then - begin - WriteRep( cnt, P^ ); - inc( P, cnt ); - dec( line_len_left, cnt ); - end else - begin - cnt := CountDiff( P, line_len_left, 2 ); - WriteRun( P, cnt ); - inc( P, cnt ); - dec( line_len_left, cnt ); - end; - end; - Strm.WriteVal( 00, 1 ); - if y < Height-1 then - Strm.WriteVal( 00, 1 ) // EOL - else Strm.WriteVal( 01, 1 ); // EOB - inc(y); - {if P <> Pnext then - asm - nop - end;} - end; - Result := TRUE; - end; - function WriteBitmap : Boolean; - var ColorsSize, BitsSize : Integer; - BIH: TBitmapInfoHeader; - x, y: Integer; - Line: PByte; - Buffer: PByteArray; - begin - Result := False; - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - HandleType := bmDIB; // convert to DIB if DDB - ZeroMemory( @BFH, Sizeof( BFH ) ); - ColorsSize := 0; - with fDIBHeader.bmiHeader do - if biBitCount <= 8 then - ColorsSize := (1 shl biBitCount) * Sizeof( TRGBQuad ); - BFH.bfOffBits := Sizeof( BFH ) + Sizeof( TBitmapInfoHeader ) + ColorsSize; - BitsSize := fDIBSize; //ScanLineSize * fHeight; - BFH.bfSize := BFH.bfOffBits + DWord( BitsSize ); - BFH.bfType := $4D42; // 'BM'; - if fDIBHeader.bmiHeader.biCompression <> 0 then - begin - ColorsSize := 12 + 16*sizeof(TRGBQuad); - Inc( BFH.bfOffBits, ColorsSize ); - end; - if Strm.Write( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit; {>>>>>>>>} - BIH := fDIBHeader.bmiHeader; - MS := NewMemoryStream; - if fDIBHeader.bmiHeader.biBitCount = 8 then - begin - for y := Height-1 downto 0 do - begin - Line := ScanLine[y]; - MS.Write( Line^, Width ); - end; - end else - begin - Buffer := AllocMem( Width ); - for y := Height-1 downto 0 do - begin - Line := ScanLine[y]; - x := 0; - while x < Width do - begin - Buffer[x] := Line^ shr 4; - inc( x ); - if x >= Width then break; - Buffer[x] := Line^ and 15; - inc( x ); - inc( Line ); - end; - MS.Write( Buffer^, Width ); - end; - MS.WriteVal( 0, 2 ); - end; - if fDIBHeader.bmiHeader.biBitCount = 8 then - BIH.biCompression := BI_RLE8 - else BIH.biCompression := BI_RLE4; - if Strm.Write( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit; {>>>>>>>} - if Strm.Write( fDIBHeader.bmiColors, ColorsSize ) <> DWORD(ColorsSize) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fDIBHeader.bmiHeader.biBitCount = 8 then - Result := WriteRLE8 - else Result := WriteRLE4; - MS.Free; - end; -begin - Pos := Strm.Position; - if (fDIBHeader.bmiHeader.biBitCount <> 4) - and (fDIBHeader.bmiHeader.biBitCount <> 8) then - begin - SaveToStream( Strm ); Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if not WriteBitmap then - Strm.Seek( Pos, spBegin ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.SetHandle(const Value: HBitmap); -var B: tagBitmap; - Dib: TDIBSection; -begin - Clear; - if Value = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (WinVer >= wvNT) and - (GetObject( Value, Sizeof( Dib ), @ Dib ) = Sizeof( Dib )) - and (Dib.dsBmih.biBitCount > 8) then - begin - fHandle := Value; - fHandleType := bmDIB; - fDIBHeader := PrepareBitmapHeader( Dib.dsBm.bmWidth, Dib.dsBm.bmHeight, - Dib.dsBm.bmBitsPixel ); - Move( Dib.dsBitfields, fDIBHeader.bmiColors, 3 * 4 ); - fWidth := Dib.dsBm.bmWidth; - fHeight := Dib.dsBm.bmHeight; - fDIBBits := Dib.dsBm.bmBits; - fDIBSize := Dib.dsBmih.biSizeImage; - fDIBAutoFree := true; - end - else - begin - if GetObject( Value, Sizeof( B ), @B ) = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>} - fHandle := Value; - fWidth := B.bmWidth; - fHeight := B.bmHeight; - fHandleType := bmDDB; - end; -end; -{$ENDIF PAS_VERSION} - -procedure TBitmap.SetWidth(const Value: Integer); -begin - if fWidth = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fWidth := Value; - FormatChanged; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.SetHeight(const Value: Integer); -{$IFNDEF SMALLER_CODE} -var - pf : TPixelFormat; -{$ENDIF SMALLER_CODE} -begin - if fHeight = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} -{$IFNDEF SMALLER_CODE} - pf := PixelFormat; -{$ENDIF SMALLER_CODE} - HandleType := bmDDB; - // Not too good, but provides correct changing of height - // preserving previous image - fHeight := Value; - FormatChanged; -{$IFNDEF SMALLER_CODE} - PixelFormat := pf; -{$ENDIF SMALLER_CODE} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.SetPixelFormat(Value: TPixelFormat); -begin - if PixelFormat = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Value = pfDevice then - HandleType := bmDDB - else - begin - fNewPixelFormat := Value; - HandleType := bmDIB; - FormatChanged; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer; -begin - Result := ((Header.biBitCount * Header.biWidth + 31) shr 3) and $FFFFFFFC; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer ); -var oldBmp: HBitmap; - R: TRect; - Br: HBrush; -begin - with Bmp^ do - if Color2RGB( fBkColor ) <> 0 then - if (oldWidth < fWidth) or (oldHeight < fHeight) then - if GetHandle <> 0 then - begin - oldBmp := SelectObject( DC2, fHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - Br := CreateSolidBrush( Color2RGB( fBkColor ) ); - R := MakeRect( oldWidth, oldHeight, fWidth, fHeight ); - if oldWidth = fWidth then - R.Left := 0; - if oldHeight = fHeight then - R.Top := 0; - Windows.FillRect( DC2, R, Br ); - DeleteObject( Br ); - SelectObject( DC2, oldBmp ); - end; -end; -{$ENDIF PAS_VERSION} - -const BitCounts: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 ); -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.FormatChanged; -// This method is used whenever Width, Height, PixelFormat or HandleType -// properties are changed. -// Old image will be drawn here to a new one (excluding cases when -// old width or height was 0, and / or new width or height is 0). -// To avoid inserting this code into executable, try not to change -// properties Width / Height of bitmat after it is created using -// NewBitmap( W, H ) function or after it is loaded from file, stream or resource. -var B: tagBitmap; - oldBmp, NewHandle: HBitmap; - DC0, DC2: HDC; - NewHeader: PBitmapInfo; - NewBits: Pointer; - oldHeight, oldWidth, sizeBits, bitsPixel: Integer; - Br: HBrush; - N: Integer; - NewDIBAutoFree: Boolean; - Hndl: THandle; -begin - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - NewDIBAutoFree := FALSE; - fDetachCanvas( @Self ); - fScanLineSize := 0; - fGetDIBPixels := nil; - fSetDIBPixels := nil; - - oldWidth := fWidth; - oldHeight := fHeight; - if fDIBBits <> nil then - begin - oldWidth := fDIBHeader.bmiHeader.biWidth; - oldHeight := Abs(fDIBHeader.bmiHeader.biHeight); - end - else - if fHandle <> 0 then - begin - if GetObject( fHandle, Sizeof( B ), @ B ) <> 0 then - begin - oldWidth := B.bmWidth; - oldHeight := B.bmHeight; - end; - end; - - DC2 := CreateCompatibleDC( 0 ); - - if fHandleType = bmDDB then - begin - // New HandleType is bmDDB: old bitmap can be copied using Draw method - DC0 := GetDC( 0 ); - NewHandle := CreateCompatibleBitmap( DC0, fWidth, fHeight ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( NewHandle <> 0, 'Can not create DDB' ); - {$ENDIF KOL_ASSERTIONS} - ReleaseDC( 0, DC0 ); - - oldBmp := SelectObject( DC2, NewHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - - Br := CreateSolidBrush( Color2RGB( fBkColor ) ); - FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br ); - DeleteObject( Br ); - - if fDIBBits <> nil then - begin - SelectObject( DC2, oldBmp ); - SetDIBits( DC2, NewHandle, 0, fHeight, fDIBBits, fDIBHeader^, DIB_RGB_COLORS ); - end - else - begin - Draw( DC2, 0, 0 ); - SelectObject( DC2, oldBmp ); - end; - - ClearData; // Image is cleared but fWidth and fHeight are preserved - fHandle := NewHandle; - end - else - begin - // New format is DIB. GetDIBits applied to transform old data to new one. - bitsPixel := BitCounts[ fNewPixelFormat ]; - if bitsPixel = 0 then - begin - bitsPixel := BitCounts[DefaultPixelFormat]; - end; - - NewHandle := 0; - NewHeader := PrepareBitmapHeader( fWidth, fHeight, bitsPixel ); - if fNewPixelFormat = pf16bit then - PreparePF16bit( NewHeader ); - - sizeBits := CalcScanLineSize( @NewHeader.bmiHeader ) * fHeight; - - NewBits := Pointer( GlobalAlloc( GMEM_FIXED, sizeBits ) ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( NewBits <> nil, 'No memory' ); - {$ENDIF KOL_ASSERTIONS} - - Hndl := GetHandle; - if Hndl = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - N := - GetDIBits( DC2, Hndl, 0, Min( fHeight, oldHeight ), - NewBits, NewHeader^, DIB_RGB_COLORS ); - if N <> Min( fHeight, oldHeight ) then - begin - GlobalFree( DWORD( NewBits ) ); - NewBits := nil; - NewHandle := CreateDIBSection( DC2, NewHeader^, DIB_RGB_COLORS, NewBits, 0, 0 ); - NewDIBAutoFree := TRUE; - {$IFDEF KOL_ASSERTIONS} - ASSERT( NewHandle <> 0, 'Can not create DIB secion for pf16bit bitmap' ); - {$ENDIF KOL_ASSERTIONS} - oldBmp := SelectObject( DC2, NewHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( oldBmp <> 0, 'Can not select pf16bit to DC' ); - {$ENDIF KOL_ASSERTIONS} - Draw( DC2, 0, 0 ); - SelectObject( DC2, oldBmp ); - end; - - ClearData; - fDIBSize := sizeBits; - fDIBBits := NewBits; - fDIBHeader := NewHeader; - fHandle := NewHandle; - fDIBAutoFree := NewDIBAutoFree; - - end; - - if Assigned( fFillWithBkColor ) then - fFillWithBkColor( @Self, DC2, oldWidth, oldHeight ); - - DeleteDC( DC2 ); - -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.GetScanLine(Y: Integer): Pointer; -begin - {$IFDEF KOL_ASSERTIONS} - ASSERT( (Y >= 0) {and (Y < fHeight)}, 'ScanLine index out of bounds' ); - ASSERT( fDIBBits <> nil, 'No bits available' ); - {$ENDIF KOL_ASSERTIONS} - Result := nil; - if fDIBHeader = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fDIBHeader.bmiHeader.biHeight > 0 then - Y := fHeight - 1 - Y; - if fScanLineSize = 0 then - ScanLineSize; - - Result := Pointer( Integer( fDIBBits ) + fScanLineSize * Y ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.GetScanLineSize: Integer; -begin - Result := 0; - if fDIBHeader = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FScanLineSize := CalcScanLineSize( @fDIBHeader.bmiHeader ); - Result := FScanLineSize; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.CanvasChanged( Sender : PObj ); -begin - fBkColor := PCanvas( Sender ).Brush.Color; - ClearTransImage; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.Dormant; -begin - RemoveCanvas; - if fHandle <> 0 then - DeleteObject( ReleaseHandle ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.SetBkColor(const Value: TColor); -begin - if fBkColor = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fBkColor := Value; - fFillWithBkColor := FillBmpWithBkColor; - if Assigned( fApplyBkColor2Canvas ) then - fApplyBkColor2Canvas( @Self ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.Assign(SrcBmp: PBitmap): Boolean; -begin - Clear; - Result := False; - if SrcBmp = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if SrcBmp.Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fWidth := SrcBmp.fWidth; - fHeight := SrcBmp.fHeight; - fHandleType := SrcBmp.fHandleType; - //fNewPixelFormat := SrcBmp.PixelFormat; - if SrcBmp.fHandleType = bmDDB then - begin - fHandle := CopyImage( SrcBmp.fHandle, IMAGE_BITMAP, 0, 0, 0 {LR_COPYRETURNORG} ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( fHandle <> 0, 'Can not copy bitmap image' ); - {$ENDIF KOL_ASSERTIONS} - Result := fHandle <> 0; - if not Result then Clear; - end - else - begin - GetMem( fDIBHeader, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( fDIBHeader <> nil, 'No memory' ); - {$ENDIF KOL_ASSERTIONS} - Move( SrcBmp.fDIBHeader^, fDIBHeader^, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) ); - fDIBSize := SrcBmp.fDIBSize; - fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( fDIBBits <> nil, 'No memory' ); - {$ENDIF KOL_ASSERTIONS} - Move( SrcBmp.fDIBBits^, fDIBBits^, fDIBSize ); - Result := True; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.RemoveCanvas; -begin - fDetachCanvas( @Self ); - fCanvas.Free; - fCanvas := nil; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.DIBPalNearestEntry(Color: TColor): Integer; -var I, Diff, D: Integer; - C : Integer; -begin - Color := TColor( Color2RGBQuad( Color ) ); - Result := 0; - Diff := MaxInt; - for I := 0 to DIBPalEntryCount - 1 do - begin - C := Color xor PInteger( Integer( @fDIBHeader.bmiColors[ 0 ] ) - + I * Sizeof( TRGBQuad ) )^; - D := TRGBQuad( C ).rgbBlue + TRGBQuad( C ).rgbGreen + TRGBQuad( C ).rgbRed; - if D < Diff then - begin - Diff := D; - Result := I; - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.GetDIBPalEntries(Idx: Integer): TColor; -begin - Result := TColor(-1); - if fDIBBits = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF KOL_ASSERTIONS} - ASSERT( PixelFormat in [pf1bit..pf8bit], 'Format has no DIB palette entries available' ); - ASSERT( (Idx >= 0) and (Idx < (1 shl fDIBHeader.bmiHeader.biBitCount)), - 'DIB palette index out of bounds' ); - {$ENDIF KOL_ASSERTIONS} - Result := PDWORD( Integer( @fDIBHeader.bmiColors[ 0 ] ) - + Idx * Sizeof( TRGBQuad ) )^; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.GetDIBPalEntryCount: Integer; -begin - Result := 0; - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - case PixelFormat of - pf1bit: Result := 2; - pf4bit: Result := 16; - pf8bit: Result := 256; - else; - end; -end; -{$ENDIF PAS_VERSION} - -procedure TBitmap.SetDIBPalEntries(Idx: Integer; const Value: TColor); -begin - if fDIBBits = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Dormant; - PDWORD( Integer( @fDIBHeader.bmiColors[ 0 ] ) - + Idx * Sizeof( TRGBQuad ) )^ := Color2RGB( Value ); -end; - -procedure TBitmap.SetHandleType(const Value: TBitmapHandleType); -begin - if fHandleType = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fHandleType := Value; - FormatChanged; -end; - -function TBitmap.GetPixelFormat: TPixelFormat; -begin - if (HandleType = bmDDB) or (fDIBBits = nil) then - Result := pfDevice - else - begin - Result := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount ); - if fDIBHeader.bmiHeader.biCompression <> 0 then - begin - {$IFDEF KOL_ASSERTIONS} - Assert( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' ); - {$ENDIF KOL_ASSERTIONS} - if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $F800) and - (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $7E0) and - (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then - Result := pf16bit - else - if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $7C00) and - (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $3E0) and - (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then - Result := pf15bit - else - Result := pfCustom; - end; - end; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.ClearTransImage; -begin - fTransColor := clNone; - fTransMaskBmp.Free; - fTransMaskBmp := nil; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -{$IFDEF USE_OLDCONVERT2MASK} -procedure TBitmap.Convert2Mask(TranspColor: TColor); -var MonoHandle: HBitmap; - SaveMono, SaveFrom: THandle; - MonoDC, DCfrom: HDC; - SaveBkColor: TColorRef; -begin - if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fDetachCanvas( @Self ); - MonoHandle := CreateBitmap( fWidth, fHeight, 1, 1, nil ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( MonoHandle <> 0, 'Can not create monochrome bitmap' ); - {$ENDIF KOL_ASSERTIONS} - MonoDC := CreateCompatibleDC( 0 ); - SaveMono := SelectObject( MonoDC, MonoHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( SaveMono <> 0, 'Can not select bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - DCfrom := CreateCompatibleDC( 0 ); - SaveFrom := SelectObject( DCfrom, fHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( SaveFrom <> 0, 'Can not select source bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - TranspColor := Color2RGB( TranspColor ); - SaveBkColor := Windows.SetBkColor( DCfrom, TranspColor ); - BitBlt( MonoDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, SRCCOPY ); - {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF} - Windows.SetBkColor( DCfrom, SaveBkColor ); - SelectObject( DCfrom, SaveFrom ); - DeleteDC( DCfrom ); - SelectObject( MonoDC, SaveMono ); - DeleteDC( MonoDC ); - ///ReleaseDC( 0, DC0 ); - ClearData; - fHandle := MonoHandle; - fHandleType := bmDDB; -end; -{$ELSE NOT USE_OLDCONVERT2MASK} //Pascal -procedure TBitmap.Convert2Mask(TranspColor: TColor); -var Y, X, i: Integer; - Src, Dst: PByte; - W: Word; - TmpMsk: PBitmap; - B, C: Byte; - TranspColor32: TColor; -begin - HandleType := bmDIB; - if PixelFormat < pf4bit then - PixelFormat := pf4bit; - if PixelFormat > pf32bit then - PixelFormat := pf32bit; - TranspColor := Color2RGB( TranspColor ) and $FFFFFF; - TranspColor32 := TColor( Color2RGBQuad( TranspColor ) ); - TmpMsk := NewDIBBitmap( fWidth, fHeight, pf1bit ); - TmpMsk.DIBPalEntries[ 1 ] := $FFFFFF; - for Y := 0 to fHeight-1 do - begin - Src := ScanLine[ Y ]; - Dst := TmpMsk.ScanLine[ Y ]; - B := 0; C := 8; - CASE PixelFormat OF - pf4bit: - begin - W := 16; - for i := 0 to 15 do - if DIBPalEntries[ i ] = TranspColor32 then - begin - W := i; break; - end; - for X := 0 to (fWidth div 2)-1 do - begin - B := B shl 1; - if Src^ shr 4 = W then inc( B ); - B := B shl 1; - if Src^ and $0F = W then inc( B ); - Inc( Src ); - Dec( C, 2 ); - if C = 0 then - begin - Dst^ := B; - Inc( Dst ); - C := 8; - end; - end; - end; - pf8bit: - begin - W := 256; - for i := 0 to 255 do - if DIBPalEntries[ i ] = TranspColor32 then - begin - W := i; break; - end; - for X := 0 to fWidth-1 do - begin - B := B shl 1; - if Src^ = W then inc( B ); - Inc( Src ); - Dec( C ); - if C = 0 then - begin - Dst^ := B; - Inc( Dst ); - C := 8; - end; - end; - end; - pf15bit: - begin - W := Color2Color15( TranspColor ); - for X := 0 to fWidth-1 do - begin - B := B shl 1; - if PWord( Src )^ = W then inc( B ); - Inc( Src, 2 ); - Dec( C ); - if C = 0 then - begin - Dst^ := B; - Inc( Dst ); - C := 8; - end; - end; - end; - pf16bit: - begin - W := Color2Color16( TranspColor ); - for X := 0 to fWidth-1 do - begin - B := B shl 1; - if PWord( Src )^ = W then inc( B ); - Inc( Src, 2 ); - Dec( C ); - if C = 0 then - begin - Dst^ := B; - Inc( Dst ); - C := 8; - end; - end; - end; - pf24bit: - begin - for X := 0 to fWidth-1 do - begin - B := B shl 1; - if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B ); - Inc( Src, 3 ); - Dec( C ); - if C = 0 then - begin - Dst^ := B; - Inc( Dst ); - C := 8; - end; - end; - end; - pf32bit: - begin - for X := 0 to fWidth-1 do - begin - B := B shl 1; - if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B ); - Inc( Src, 4 ); - Dec( C ); - if C = 0 then - begin - Dst^ := B; - Inc( Dst ); - C := 8; - end; - end; - end; - END; - if (C > 0) and (C < 8) then - begin - while C > 0 do - begin - B := B shl 1; - dec( C ); - end; - Dst^ := B; - end; - end; - Assign( TmpMsk ); - TmpMsk.Free; -end; -{$ENDIF USE_OLDCONVERT2MASK} //Pascal -{$ENDIF PAS_VERSION} - -procedure TBitmap.Invert; -var R: TRect; -begin - //BitBlt( Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, DSTINVERT ) - R := BoundsRect; - InvertRect(Canvas.Handle, R); -end; - -procedure TBitmap.DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect ); -begin - if fDIBBits = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - StretchDIBits( DC, X, Y, R.Right - R.Left, R.Bottom - R.Top, - R.Left, fHeight - R.Bottom, R.Right - R.Left, R.Bottom - R.Top, - fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap ); -var X, Y, Z, Shf, Wbytes, BytesPerDstLine: Integer; - Src, Dst, Dst1: PByte; - Tmp: Byte; -begin - - DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 7) and not 7, pf1bit ); - Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 2 * Sizeof( TRGBQuad ) ); - - // Calculate ones: - Dst := DstBmp.ScanLine[ 0 ]; - BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst ); - Wbytes := (SrcBmp.fWidth + 7) shr 3; - - Inc( Dst, (DstBmp.fWidth - 1) shr 3 ); - Shf := (DstBmp.fWidth - 1) and 7; - - // Rotating bits: - for Y := 0 to SrcBmp.fHeight - 1 do - begin - Src := SrcBmp.ScanLine[ Y ]; - Dst1 := Dst; - for X := Wbytes downto 1 do - begin - Tmp := Src^; - Inc( Src ); - for Z := 8 downto 1 do - begin - Dst1^ := Dst1^ or ( (Tmp and $80) shr Shf ); - Tmp := Tmp shl 1; - Inc( Dst1, BytesPerDstLine ); - end; - end; - Dec( Shf ); - if Shf < 0 then - begin - Shf := 7; - Dec( Dst ); - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); -var X, Y, Shf, Wbytes, BytesPerDstLine: Integer; - Src, Dst, Dst1: PByte; - Tmp: Byte; -begin - DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 1) and not 1, pf4bit ); - Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 16 * Sizeof( TRGBQuad ) ); - - // Calculate ones: - Dst := DstBmp.ScanLine[ 0 ]; - BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst ); - Wbytes := (SrcBmp.fWidth + 1) shr 1; - Inc( Dst, (DstBmp.fWidth - 1) shr 1 ); - Shf := ((DstBmp.fWidth - 1) and 1) shl 2; - - // Rotating bits: - for Y := 0 to SrcBmp.fHeight - 1 do - begin - Src := SrcBmp.ScanLine[ Y ]; - Dst1 := Dst; - for X := Wbytes downto 1 do - begin - Tmp := Src^; - Inc( Src ); - Dst1^ := Dst1^ or ( (Tmp and $F0) shr Shf ); - Inc( Dst1, BytesPerDstLine ); - Dst1^ := Dst1^ or ( ((Tmp shl 4) and $F0) shr Shf ); - Inc( Dst1, BytesPerDstLine ); - end; - Dec( Shf, 4 ); - if Shf < 0 then - begin - Shf := 4; - Dec( Dst ); - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); -var X, Y, Wbytes, BytesPerDstLine: Integer; - Src, Dst, Dst1: PByte; - Tmp: Byte; -begin - - DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat ); - Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 256 * Sizeof( TRGBQuad ) ); - - // Calculate ones: - Wbytes := SrcBmp.fWidth; - Dst := DstBmp.ScanLine[ 0 ]; - BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst ); - - Inc( Dst, DstBmp.fWidth - 1 ); - - // Rotating bits: - for Y := 0 to SrcBmp.fHeight - 1 do - begin - Src := SrcBmp.ScanLine[ Y ]; - Dst1 := Dst; - for X := Wbytes downto 1 do - begin - Tmp := Src^; - Inc( Src ); - Dst1^ := Tmp; - Inc( Dst1, BytesPerDstLine ); - end; - Dec( Dst ); - end; - -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); -var X, Y, Wwords, BytesPerDstLine: Integer; - Src, Dst, Dst1: PWord; - Tmp: Word; -begin - DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat ); - Wwords := SrcBmp.fWidth; - Dst := DstBmp.ScanLine[ 0 ]; - BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst ); - Inc( Dst, DstBmp.fWidth - 1 ); - - // Rotating bits: - for Y := 0 to SrcBmp.fHeight - 1 do - begin - Src := SrcBmp.ScanLine[ Y ]; - Dst1 := Dst; - for X := Wwords downto 1 do - begin - Tmp := Src^; - Inc( Src ); - Dst1^ := Tmp; - Inc( PByte(Dst1), BytesPerDstLine ); - end; - Dec( Dst ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); -var X, Y, Wwords, BytesPerDstLine, IncW: Integer; - Src, Dst, Dst1: PDWord; - Tmp: DWord; -begin - - DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat ); - - // Calculate ones: - IncW := 4; - if DstBmp.PixelFormat = pf24bit then - IncW := 3; - Wwords := SrcBmp.fWidth; - Dst := DstBmp.ScanLine[ 0 ]; - BytesPerDstLine := Integer( DstBmp.ScanLine[ 1 ]) - Integer( Dst ); - - Inc( PByte(Dst), (DstBmp.fWidth - 1) * IncW ); - - // Rotating bits: - for Y := 0 to SrcBmp.fHeight - 1 do - begin - Src := SrcBmp.ScanLine[ Y ]; - Dst1 := Dst; - for X := Wwords downto 1 do - begin - Tmp := Src^ and $FFFFFF; - Inc( PByte(Src), IncW ); - Dst1^ := Dst1^ or Tmp; - Inc( PByte(Dst1), BytesPerDstLine ); - end; - Dec( PByte(Dst), IncW ); - end; - -end; -{$ENDIF PAS_VERSION} - -type - TRotateBmpRefs = packed record - proc_RotateBitmapMono: procedure( var Dst: PBitmap; Src: PBitmap ); - proc_RotateBitmap4bit: procedure( var Dst: PBitmap; Src: PBitmap ); - proc_RotateBitmap8bit: procedure( var Dst: PBitmap; Src: PBitmap ); - proc_RotateBitmap16bit: procedure( var Dst: PBitmap; Src: PBitmap ); - proc_RotateBitmap2432bit: procedure( var Dst: PBitmap; Src: PBitmap ); - end; - -var - RotateProcs: TRotateBmpRefs; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _RotateBitmapRight( SrcBmp: PBitmap ); -var DstBmp: PBitmap; - RotateProc: procedure( var DstBmp: PBitmap; SrcBmp: PBitmap ); -begin - if SrcBmp.fHandleType <> bmDIB then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - case SrcBmp.PixelFormat of - pf1bit: RotateProc := RotateProcs.proc_RotateBitmapMono; - pf4bit: RotateProc := RotateProcs.proc_RotateBitmap4bit; - pf8bit: RotateProc := RotateProcs.proc_RotateBitmap8bit; - pf15bit, pf16bit: RotateProc := RotateProcs.proc_RotateBitmap16bit; - else RotateProc := RotateProcs.proc_RotateBitmap2432bit; - end; - if not Assigned( RotateProc ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RotateProc( DstBmp, SrcBmp ); - if DstBmp.fHeight > SrcBmp.fWidth then - begin - DstBmp.fDIBSize := DstBmp.fScanLineSize * SrcBmp.fWidth; - if DstBmp.fDIBHeader.bmiHeader.biHeight > 0 then - Move( DstBmp.ScanLine[ SrcBmp.fWidth - 1 ]^, DstBmp.ScanLine[ DstBmp.fHeight - 1 ]^, - DstBmp.fDIBSize ); - DstBmp.fHeight := SrcBmp.fWidth; - DstBmp.fDIBHeader.bmiHeader.biHeight := DstBmp.fHeight; - end; - - SrcBmp.ClearData; - - SrcBmp.fDIBHeader := DstBmp.fDIBHeader; - DstBmp.fDIBHeader := nil; - - SrcBmp.fDIBBits := DstBmp.fDIBBits; - DstBmp.fDIBBits := nil; - SrcBmp.fDIBAutoFree := DstBmp.fDIBAutoFree; - - SrcBmp.fDIBSize := DstBmp.fDIBSize; - - SrcBmp.fWidth := DstBmp.fWidth; - SrcBmp.fHeight := DstBmp.fHeight; - DstBmp.Free; -end; -{$ENDIF PAS_VERSION} - -procedure TBitmap.RotateRight; -const AllRotators: TRotateBmpRefs = ( - proc_RotateBitmapMono: _RotateBitmapMono; - proc_RotateBitmap4bit: _RotateBitmap4bit; - proc_RotateBitmap8bit: _RotateBitmap8bit; - proc_RotateBitmap16bit: _RotateBitmap16bit; - proc_RotateBitmap2432bit: _RotateBitmap2432bit ); -begin - RotateProcs := AllRotators; - _RotateBitmapRight( @Self ); -end; - -procedure _RotateBitmapLeft( Src: PBitmap ); -begin - _RotateBitmapRight( Src ); - _RotateBitmapRight( Src ); - _RotateBitmapRight( Src ); -end; - -procedure TBitmap.RotateLeft; -begin - RotateRight; - _RotateBitmapRight( @Self ); - _RotateBitmapRight( @Self ); -end; - -procedure TBitmap.RotateLeftMono; -begin - if PixelFormat <> pf1bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono; - _RotateBitmapRight( @Self ); -end; - -procedure TBitmap.RotateRightMono; -begin - if PixelFormat <> pf1bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono; - _RotateBitmapLeft( @Self ); -end; - -procedure TBitmap.RotateLeft16bit; -begin - if PixelFormat <> pf16bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit; - _RotateBitmapLeft( @Self ); -end; - -procedure TBitmap.RotateLeft4bit; -begin - if PixelFormat <> pf4bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit; - _RotateBitmapLeft( @Self ); -end; - -procedure TBitmap.RotateLeft8bit; -begin - if PixelFormat <> pf8bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit; - _RotateBitmapLeft( @Self ); -end; - -procedure TBitmap.RotateLeftTrueColor; -begin - if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit; {>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit; - _RotateBitmapLeft( @Self ); -end; - -procedure TBitmap.RotateRight16bit; -begin - if PixelFormat <> pf16bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit; - _RotateBitmapRight( @Self ); -end; - -procedure TBitmap.RotateRight4bit; -begin - if PixelFormat <> pf4bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit; - _RotateBitmapRight( @Self ); -end; - -procedure TBitmap.RotateRight8bit; -begin - if PixelFormat <> pf8bit then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit; - _RotateBitmapRight( @Self ); -end; - -procedure TBitmap.RotateRightTrueColor; -begin - if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit; {>>>>>>>>>>>>>>>>>>>>} - RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit; - _RotateBitmapRight( @Self ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.GetPixels(X, Y: Integer): TColor; -var DC: HDC; - Save: THandle; -begin - Result := clNone; - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fDetachCanvas( @Self ); - DC := CreateCompatibleDC( 0 ); - Save := SelectObject( DC, GetHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( Save <> 0, 'Can not select bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - Result := Windows.GetPixel( DC, X, Y ); - SelectObject( DC, Save ); - DeleteDC( DC ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.SetPixels(X, Y: Integer; const Value: TColor); -var DC: HDC; - Save: THandle; -begin - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fDetachCanvas( @Self ); - DC := CreateCompatibleDC( 0 ); - Save := SelectObject( DC, GetHandle ); - {$IFDEF KOL_ASSERTIONS} - ASSERT( Save <> 0, 'Can not select bitmap to DC' ); - {$ENDIF KOL_ASSERTIONS} - Windows.SetPixel( DC, X, Y, Color2RGB( Value ) ); - SelectObject( DC, Save ); - DeleteDC( DC ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function _GetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer ): TColor; -var Pixel: Byte; -begin - Pixel := PByte( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta - + (X div (Bmp.fPixelsPerByteMask + 1)) )^; - Pixel := ( Pixel shr ( (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask)) - * Bmp.fDIBHeader.bmiHeader.biBitCount ) ) - and Bmp.fPixelMask; - Result := TColor( Color2RGBQuad( TColor( PRGBQuad( DWORD(@Bmp.fDIBHeader.bmiColors[ 0 ]) - + Pixel * Sizeof( TRGBQuad ) )^ ) ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function _GetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer ): TColor; -var Pixel: Word; -begin - Pixel := PWord( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X * 2 )^; - if Bmp.fPixelMask = 15 then - Result := (Pixel shr 7) and $F8 or (Pixel shl 6) and $F800 - or (Pixel shl 19) and $F80000 - else - Result := (Pixel shr 8) and $F8 or (Pixel shl 5) and $FC00 - or (Pixel shl 19) and $F80000; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function _GetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer ): TColor; -var Pixel: DWORD; -begin - Pixel := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + - X * Bmp.fBytesPerPixel )^ and $FFFFFF; - Result := TColor( Color2RGBQuad( TColor( Pixel ) ) ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function _GetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer ): TColor; -var Pixel: DWORD; - RGB: TRGBQuad; - blue, red: Byte; -begin - Pixel := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + - X * Bmp.fBytesPerPixel )^; - RGB := TRGBQuad(Pixel); - blue := RGB.rgbRed; - red := RGB.rgbBlue; - RGB.rgbBlue := blue; - RGB.rgbRed := red; - Result := TColor( RGB ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TBitmap.GetDIBPixels(X, Y: Integer): TColor; -begin - if not Assigned( fGetDIBPixels ) then - begin - if fHandleType = bmDIB then - begin - fScanLine0 := ScanLine[ 0 ]; - fScanLineDelta := Integer(ScanLine[ 1 ]) - Integer(fScanLine0); - case PixelFormat of - pf1bit: - begin - fPixelMask := $01; - fPixelsPerByteMask := 7; - fGetDIBPixels := _GetDIBPixelsPalIdx; - end; - pf4bit: - begin - fPixelMask := $0F; - fPixelsPerByteMask := 1; - fGetDIBPixels := _GetDIBPixelsPalIdx; - end; - pf8bit: - begin - fPixelMask := $FF; - fPixelsPerByteMask := 0; - fGetDIBPixels := _GetDIBPixelsPalIdx; - end; - pf15bit: - begin - fPixelMask := 15; - fGetDIBPixels := _GetDIBPixels16bit; - end; - pf16bit: - begin - fPixelMask := 16; - fGetDIBPixels := _GetDIBPixels16bit; - end; - pf24bit: - begin - fPixelsPerByteMask := 0; - fBytesPerPixel := 3; - fGetDIBPixels := _GetDIBPixelsTrueColor; - end; - pf32bit: - begin - fPixelsPerByteMask := 1; - fBytesPerPixel := 4; - fGetDIBPixels := {$IFDEF DIBPixels32bitWithAlpha} _GetDIBPixelsTrueColorAlpha - {$ELSE} _GetDIBPixelsTrueColor {$ENDIF}; - end; - else; - end; - end; - if not Assigned( fGetDIBPixels ) then - begin - Result := Pixels[ X, Y ]; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := fGetDIBPixels( @Self, X, Y ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -var Pixel: Byte; - Pos: PByte; - Shf: Integer; -begin - Value := Color2RGB( Value ); - if ((Value shr 16) and $FF) + ((Value shr 8) and $FF) + (Value and $FF) - < 255 * 3 div 2 then Pixel := 0 else Pixel := $80; - Pos := PByte( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X div 8 ); - Shf := X and 7; - Pos^ := Pos^ and ($FF7F shr Shf) or (Pixel shr Shf); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -var Pixel: Byte; - Pos: PByte; - Shf: Integer; -begin - Pixel := Bmp.DIBPalNearestEntry( Value ); - Pos := PByte( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta - + X div (Bmp.fPixelsPerByteMask + 1) ); - Shf := (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask)) - * Bmp.fDIBHeader.bmiHeader.biBitCount; - Pos^ := Pos^ and not (Bmp.fPixelMask shl Shf) or (Pixel shl Shf); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -var RGB16: Word; - Pos: PWord; -begin - Value := Color2RGB( Value ); - if Bmp.fPixelMask = 15 then - RGB16 := (Value shr 19) and $001F or (Value shr 6) and $03E0 - or (Value shl 7) and $7C00 - else - RGB16 := (Value shr 19) and $001F or (Value shr 5) and $07E0 - or (Value shl 8) and $F800; - Pos := PWord( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta + X * 2 ); - Pos^ := RGB16; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -var RGB: TRGBQuad; - Pos: PDWord; -begin - RGB := Color2RGBQuad( Value ); - Pos := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta - + X * Bmp.fBytesPerPixel ); - Pos^ := Pos^ and $FF000000 or DWORD(RGB); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure _SetDIBPixelsTrueColorAlpha( Bmp: PBitmap; X, Y: Integer; Value: TColor ); -var RGB: TRGBQuad; - Pos: PDWord; - blue, red: Byte; -begin - RGB := TRGBQuad(Value); - blue := RGB.rgbRed; - red := RGB.rgbBlue; - RGB.rgbBlue := blue; - RGB.rgbRed := red; - Pos := PDWORD( Integer(Bmp.fScanLine0) + Y * Bmp.fScanLineDelta - + X * Bmp.fBytesPerPixel ); - Pos^ := Pos^ or DWORD(RGB); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.SetDIBPixels(X, Y: Integer; const Value: TColor); -begin - if not Assigned( fSetDIBPixels ) then - begin - if fHandleType = bmDIB then - begin - fScanLine0 := ScanLine[ 0 ]; - fScanLineDelta := Integer(ScanLine[ 1 ]) - Integer(fScanLine0); - case PixelFormat of - pf1bit: - begin - //fPixelMask := $01; - //fPixelsPerByteMask := 7; - fSetDIBPixels := _SetDIBPixels1bit; - end; - pf4bit: - begin - fPixelMask := $0F; - fPixelsPerByteMask := 1; - fSetDIBPixels := _SetDIBPixelsPalIdx; - end; - pf8bit: - begin - fPixelMask := $FF; - fPixelsPerByteMask := 0; - fSetDIBPixels := _SetDIBPixelsPalIdx; - end; - pf15bit: - begin - fPixelMask := 15; - fSetDIBPixels := _SetDIBPixels16bit; - end; - pf16bit: - begin - fPixelMask := 16; - fSetDIBPixels := _SetDIBPixels16bit; - end; - pf24bit: - begin - fPixelsPerByteMask := 0; - fBytesPerPixel := 3; - fSetDIBPixels := _SetDIBPixelsTrueColor; - end; - pf32bit: - begin - fPixelsPerByteMask := 1; - fBytesPerPixel := 4; - fSetDIBPixels := {$IFDEF DIBPixels32bitWithAlpha} _SetDIBPixelsTrueColorAlpha - {$ELSE} _SetDIBPixelsTrueColor {$ENDIF}; - end; - else; - end; - end; - if not Assigned( fSetDIBPixels ) then - begin - Pixels[ X, Y ] := Value; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - fSetDIBPixels( @Self, X, Y, Value ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.FlipVertical; -var DC: HDC; - Save: THandle; - TmpScan: PByte; - Y: Integer; -begin - if fHandle <> 0 then - begin - fDetachCanvas( @Self ); - DC := CreateCompatibleDC( 0 ); - Save := SelectObject( DC, fHandle ); - StretchBlt( DC, 0, fHeight - 1, fWidth, -fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY ); - SelectObject( DC, Save ); - DeleteDC( DC ); - end - else - if fDIBBits <> nil then - begin - GetMem( TmpScan, ScanLineSize ); - for Y := 0 to fHeight div 2-1 do - begin - Move( ScanLine[ Y ]^, TmpScan^, fScanLineSize ); - Move( ScanLine[ fHeight - Y - 1 ]^, ScanLine[ Y ]^, fScanLineSize ); - Move( TmpScan^, ScanLine[ fHeight - Y - 1 ]^, fScanLineSize ); - end; - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.FlipHorizontal; -var DC: HDC; - Save: THandle; -begin - if GetHandle <> 0 then - begin - fDetachCanvas( @Self ); - DC := CreateCompatibleDC( 0 ); - Save := SelectObject( DC, fHandle ); - StretchBlt( DC, fWidth - 1, 0, -fWidth, fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY ); - SelectObject( DC, Save ); - DeleteDC( DC ); - end; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap; - const SrcRect: TRect); -var DCsrc, DCdst: HDC; - SaveSrc, SaveDst: THandle; -begin - if (GetHandle = 0) or (SrcBmp.GetHandle = 0) then Exit; {>>>>>>>>>>>>>>>>>>>>} - fDetachCanvas( @Self ); - SrcBmp.fDetachCanvas( SrcBmp ); - DCsrc := CreateCompatibleDC( 0 ); - SaveSrc := SelectObject( DCsrc, SrcBmp.fHandle ); - DCdst := DCsrc; - SaveDst := 0; - if SrcBmp <> @Self then - begin - DCdst := CreateCompatibleDC( 0 ); - SaveDst := SelectObject( DCdst, fHandle ); - end; - StretchBlt( DCdst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, - DstRect.Bottom - DstRect.Top, DCsrc, SrcRect.Left, SrcRect.Top, - SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, - SRCCOPY ); - if SrcBmp <> @Self then - begin - SelectObject( DCdst, SaveDst ); - DeleteDC( DCdst ); - end; - SelectObject( DCsrc, SaveSrc ); - DeleteDC( DCsrc ); -end; -{$ENDIF PAS_VERSION} - -function TBitmap.CopyToClipboard: Boolean; -var DibMem: PAnsiChar; - HdrSize: Integer; - Gbl: HGlobal; - //Mem: PStream; - //Sz: Integer; - //Pt: Pointer; - Restore_Compression: Integer; -begin - Result := FALSE; - if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if not OpenClipboard( Applet.GetWindowHandle ) then Exit; {>>>>>>>>>>>>>>>>>>} - if EmptyClipboard then - begin - HandleType := bmDIB; - HdrSize := sizeof( TBitmapInfoHeader ); - Restore_Compression := -1; - TRY - if fDIBHeader.bmiHeader.biBitCount <= 8 then - Inc( HdrSize, - (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad ) ) - else - begin - if fDIBHeader.bmiHeader.biCompression = BI_RGB then - begin - CASE fDIBHeader.bmiHeader.biBitCount OF - {24,} 32: - begin - Restore_Compression := fDIBHeader.bmiHeader.biCompression; - fDIBHeader.bmiHeader.biCompression := BI_BITFIELDS; - PDWORD( @ fDIBHeader.bmiColors[ 0 ] )^ := $FF0000; - PDWORD( Integer( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := $FF00; - PDWORD( Integer( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := $FF; - Inc( HdrSize, 12 ); - end; - END; - end; - end; - Gbl := GlobalAlloc( GMEM_MOVEABLE, HdrSize + fDIBSize ); - DibMem := GlobalLock( Gbl ); - if DibMem <> nil then - begin - Move( fDIBHeader^, DibMem^, HdrSize ); - Move( fDIBBits^, Pointer( Integer( DibMem ) + HdrSize )^, fDIBSize ); - if not GlobalUnlock( Gbl ) and (GetLastError = NO_ERROR) then - begin - Result := SetClipboardData( CF_DIB, Gbl ) <> 0; - end; - end; - FINALLY - if Restore_Compression >= 0 then - fDIBHeader.bmiHeader.biCompression := Restore_Compression; - END; - - end; - CloseClipboard; -end; - -function TBitmap.PasteFromClipboard: Boolean; -var Gbl: HGlobal; - Size {, HdrSize}: Integer; - Mem: PAnsiChar; - Strm: PStream; -begin - Result := FALSE; - if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if not OpenClipboard( Applet.GetWindowHandle ) then Exit; {>>>>>>>>>>>>>>>>>>} - TRY - if IsClipboardFormatAvailable( CF_DIB ) then - begin - Gbl := GetClipboardData( CF_DIB ); - if Gbl <> 0 then - begin - Size := GlobalSize( Gbl ); - Mem := GlobalLock( Gbl ); - TRY - if (Size > 0) and (Mem <> nil) then - begin - Strm := NewMemoryStream; - Strm.Write( Mem^, Size ); - Strm.Position := 0; - LoadFromStreamEx( Strm ); - Strm.Free; - Result := not Empty; - end; - FINALLY - GlobalUnlock( Gbl ); - END; - end; - end; - FINALLY - CloseClipboard; - END; -end; - -/////////////////////////////////////////////////////////////////////// -// I C O N -/////////////////////////////////////////////////////////////////////// - -{ -- icon -- } - -function NewIcon: PIcon; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TIcon'; - {$ENDIF} - {$IFDEF ICON_DIFF_WH} - Result.FWidth := 32; - Result.FHeight := 32; - {$ELSE} - Result.FSize := 32; - {$ENDIF} -end; - -{ TIcon } - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TIcon.Clear; -begin - if fHandle <> 0 then - begin - if not FShareIcon then - DestroyIcon( fHandle ); - fHandle := 0; - end; - fShareIcon := False; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_LOCAL} - {$UNDEF ASM_LOCAL} -{$ENDIF} - -{$IFNDEF ICON_DIFF_WH} - {$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF} -{$ENDIF} - -{$IFDEF ASM_LOCAL} -{$ELSE PAS_VERSION} //Pascal -function TIcon.Convert2Bitmap(TranColor: TColor): HBitmap; -var DC0, DC2: HDC; - Save: THandle; - Br: HBrush; -begin - Result := 0; - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DC0 := GetDC( 0 ); - DC2 := CreateCompatibleDC( DC0 ); - {$IFDEF ICON_DIFF_WH} - Result := CreateCompatibleBitmap( DC0, fWidth, fHeight ); - {$ELSE} - Result := CreateCompatibleBitmap( DC0, fSize, fSize ); - {$ENDIF} - Save := SelectObject( DC2, Result ); - Br := CreateSolidBrush( Color2RGB( TranColor ) ); - {$IFDEF ICON_DIFF_WH} - FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br ); - {$ELSE} - FillRect( DC2, MakeRect( 0, 0, fSize, fSize ), Br ); - {$ENDIF} - DeleteObject( Br ); - Draw( DC2, 0, 0 ); - SelectObject( DC2, Save ); - DeleteDC( DC2 ); - ReleaseDC( 0, DC0 ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -destructor TIcon.Destroy; -begin - Clear; - inherited; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TIcon.Draw(DC: HDC; X, Y: Integer); -begin - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF ICON_DIFF_WH} - DrawIconEx( DC, X, Y, fHandle, fWidth, fHeight, 0, 0, DI_NORMAL ); - {$ELSE} - DrawIconEx( DC, X, Y, fHandle, fSize, fSize, 0, 0, DI_NORMAL ); - {$ENDIF} -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TIcon.StretchDraw(DC: HDC; Dest: TRect); -begin - if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DrawIconEx( DC, Dest.Left, Dest.Top, FHandle, Dest.Right - Dest.Left, - Dest.Bottom - Dest.Top, 0, 0, DI_NORMAL ); -end; -{$ENDIF PAS_VERSION} - -function TIcon.GetEmpty: Boolean; -begin - Result := (fHandle = 0) - {$IFDEF ICONLOAD_PRESERVEBMPS} - and ((ImgBmp = nil) or ImgBmp.Empty) - {$ENDIF ICONLOAD_PRESERVEBMPS} - ; -end; - -function TIcon.GetHotSpot: TPoint; -var II : TIconInfo; -begin - Result := MakePoint( 0, 0 ); - if FHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - GetIconInfo( FHandle, II ); - Result.x := II.xHotspot; - Result.y := II.yHotspot; - if II.hbmMask <> 0 then - DeleteObject( II.hbmMask ); - if II.hbmColor <> 0 then - DeleteObject( II.hbmColor ); -end; - -procedure TIcon.LoadFromFile(const FileName: KOLString); -var Strm : PStream; -begin - Strm := NewReadFileStream( Filename ); - LoadFromStream( Strm ); - Strm.Free; -end; - -procedure TIcon.LoadFromStream(Strm: PStream); -var DesiredSize : Integer; - Pos : DWord; - Mem : PStream; - {$IFNDEF ICONLOAD_PRESERVEBMPS} - ImgBmp, MskBmp : PBitmap; - {$ENDIF ICONLOAD_PRESERVEBMPS} - TmpBmp: PBitmap; - function ReadIcon : Boolean; - var IH : TIconHeader; - IDI, FoundIDI : TIconDirEntry; - I, J, SumSz, FoundSz, D : Integer; - II : TIconInfo; - BIH : TBitmapInfoheader; - SzImg: DWORD; - begin - Result := False; - if Strm.Read( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit; {>>>>>>>>>>>>>} - if (IH.idReserved = Sizeof( TBitmapInfoHeader )) then - begin - Strm.Position := Strm.Position - Sizeof( IH ); - {$IFDEF ICON_DIFF_WH} fWidth := 0; - fHeight := 0; - {$ELSE} fSize := 0; - {$ENDIF} - SumSz := 0; - end - else - if (IH.idReserved = 0) and ((IH.idType = 1) or (IH.idType = 2)) and - (IH.idCount >= 1) then - begin - if (IH.idReserved <> 0) or ((IH.idType <> 1) and (IH.idType <> 2)) or - (IH.idCount < 1) or (IH.idCount >= 1024) then Exit; {>>>>>>>>>>>>>>>>} - SumSz := Sizeof( IH ); - FoundSz := 1000000; - for I := 1 to IH.idCount do - begin - if Strm.Read( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit; {>>>>>} - Inc( SumSz, IDI.dwBytesInRes + Sizeof( IDI ) ); - D := IDI.bWidth - DesiredSize; - if D < 0 then D := -D; - if D < FoundSz then - begin - FoundSz := D; - FoundIDI := IDI; - end; - end; - if FoundSz = 1000000 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Strm.Position := Integer( Pos ) + FoundIDI.dwImageOffset; - {$IFDEF ICON_DIFF_WH} fWidth := FoundIDI.bWidth; - fHeight := FoundIDI.bHeight; - {$ELSE} fSize := FoundIDI.bWidth; - {$ENDIF} - end else Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if Strm.Read( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit; {>>>>>>>>>>} - {$IFDEF ICON_DIFF_WH} - fWidth := BIH.biWidth; - BIH.biHeight := BIH.biHeight div 2; // fSize; - fHeight := BIH.biHeight; - {$ELSE} - fSize := BIH.biWidth; - BIH.biHeight := BIH.biHeight div 2; // fSize; - {$ENDIF} - Mem := NewMemoryStream; - if (FoundIDI.bColorCount >= 2) or (FoundIDI.bReserved = 1) or - (FoundIDI.bColorCount = 0) then - begin - I := 0; - SzImg := ((BIH.biBitCount * BIH.biWidth + 31) div 32) * 4 * BIH.biHeight; - if (BIH.biSizeImage > 0) and (SzImg > BIH.biSizeImage) then - SzImg := BIH.biSizeImage; - if BIH.biBitCount <= 8 then - begin - I := (1 shl BIH.biBitCount) * Sizeof( TRGBQuad ); - end; - Mem.Write( BIH, Sizeof( BIH ) ); - if I > 0 then - begin - if Stream2Stream( Mem, Strm, I ) <> DWORD(I) then Exit; {>>>>>>>>>>>>} - end - else - if BIH.biBitCount = 16 then - begin - if BIH.biCompression = BI_BITFIELDS then // + by mdw - fix for - Stream2Stream(Mem, Strm, 12) // 16 bit per pixels - else - for I := 0 to 2 do - begin - J := InitColors[ I ]; - Mem.Write( J, 4 ); - end; - end; - I := Stream2Stream( Mem, Strm, SzImg ); - if I <> Integer( SzImg ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF ICON_DIFF_WH} - ImgBmp := NewBitmap( fWidth, fHeight ); - {$ELSE} - ImgBmp := NewBitmap( fSize, fSize ); - {$ENDIF} - {$IFDEF ICONLOAD_PRESERVEBMPS} - Add2AutoFree( ImgBmp ); - {$ENDIF ICONLOAD_PRESERVEBMPS} - Mem.Seek( 0, spBegin ); - {$IFDEF LOADEX} - ImgBmp.LoadFromStreamEx( Mem ); - {$ELSE} - ImgBmp.LoadFromStream( Mem ); - {$ENDIF} - if ImgBmp.Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end - else - begin - Mem.Write( BIH, Sizeof( BIH ) ); - end; - - BIH.biBitCount := 1; - BIH.biPlanes := 1; - BIH.biClrUsed := 0; - BIH.biCompression := 0; - Mem.Seek( 0, spBegin ); - BIH.biSizeImage := ((BIH.biWidth + 31) div 32) * 4 * BIH.biHeight; - Mem.Write( BIH, Sizeof( BIH ) ); - I := 0; - Mem.Write( I, Sizeof( I ) ); - I := $FFFFFF; - Mem.Write( I, Sizeof( I ) ); - I := BIH.biSizeImage; - J := Stream2Stream( Mem, Strm, I ); - while J < I do - begin - D := 0; - Mem.Write( D, 4 ); - Inc( J, 4 ); - end; - - {$IFDEF ICON_DIFF_WH} - MskBmp := NewBitmap( fWidth, fHeight ); - {$ELSE} - MskBmp := NewBitmap( fSize, fSize ); - {$ENDIF} - {$IFDEF ICONLOAD_PRESERVEBMPS} - Add2AutoFree( MskBmp ); - {$ENDIF ICONLOAD_PRESERVEBMPS} - Mem.Seek( 0, spBegin ); - {$IFDEF LOADEX} - MskBmp.LoadFromStreamEx( Mem ); - {$ELSE} - MskBmp.LoadFromStream( Mem ); - {$ENDIF} - - {$IFDEF ICONLOAD_PRESERVEBMPS} - Result := TRUE; - if not Only_Bmp then - {$ENDIF ICONLOAD_PRESERVEBMPS} - begin - II.fIcon := True; - II.xHotspot := 0; - II.yHotspot := 0; - II.hbmMask := 0; - if Assigned( MskBmp ) and not MskBmp.Empty then - II.hbmMask := MskBmp.Handle; - II.hbmColor := 0; - if ImgBmp <> nil then - II.hbmColor := ImgBmp.Handle; - fHandle := CreateIconIndirect( II ); - if SumSz > 0 then - Strm.Seek( Integer( Pos ) + SumSz, spBegin ); - Result := fHandle <> 0; - end; - - end; -begin - DesiredSize := Size; - if DesiredSize = 0 then - DesiredSize := GetSystemMetrics( SM_CXICON ); - Clear; - Pos := Strm.Position; - - Mem := nil; - {$IFDEF ICONLOAD_PRESERVEBMPS} - if ImgBmp <> nil then - begin - RemoveFromAutoFree( ImgBmp ); - RemoveFromAutoFree( MskBmp ); - Free_And_Nil( ImgBmp ); - Free_And_Nil( MskBmp ); - end; - {$ELSE} - ImgBmp := nil; - MskBmp := nil; - {$ENDIF ICONLOAD_PRESERVEBMPS} - TmpBmp := nil; - - if not ReadIcon then - begin - Clear; - Strm.Seek( Pos, spBegin ); - end; - - Mem.Free; - {$IFNDEF ICONLOAD_PRESERVEBMPS} - ImgBmp.Free; - MskBmp.Free; - {$ENDIF ICONLOAD_PRESERVEBMPS} - TmpBmp.Free; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TIcon.SaveToFile(const FileName: KOLString); -begin - SaveIcons2File( [ @Self ], FileName ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TIcon.SaveToStream(Strm: PStream); -begin - SaveIcons2Stream( [ @Self ], Strm ); -end; -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_noVERSION} -procedure TIcon.SetHandle(const Value: HIcon); -const szII = sizeof( TIconInfo ); - szBIH = sizeof(TBitmapInfoHeader); -asm //cmd //opd - CMP EDX, [EAX].fHandle - JE @@exit - PUSHAD - PUSH EDX - MOV EBX, EAX - CALL Clear - POP ECX - MOV [EBX].fHandle, ECX - JECXZ @@fin - ADD ESP, -szBIH - PUSH ESP - PUSH ECX - CALL GetIconInfo - MOV ESI, [ESP].TIconInfo.hbmMask - MOV EDI, [ESP].TIconInfo.hbmColor - PUSH ESP - PUSH szBIH - PUSH ESI - CALL GetObject - POP EAX - POP [EBX].fSize - ADD ESP, szBIH-8 - TEST ESI, ESI - JZ @@1 - PUSH ESI - CALL DeleteObject -@@1: TEST EDI, EDI - JZ @@fin - PUSH EDI - CALL DeleteObject -@@fin: POPAD -@@exit: -end; -{$ELSE PAS_VERSION} //Pascal -procedure TIcon.SetHandle(const Value: HIcon); -var II : TIconInfo; - B: TagBitmap; -begin - if FHandle = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Clear; - FHandle := Value; - if Value <> 0 then - begin - GetIconInfo( FHandle, II ); - GetObject( II.hbmMask, Sizeof( B ), @B ); - {$IFDEF ICON_DIFF_WH} - fWidth := B.bmWidth; - fHeight := B.bmHeight; - {$ELSE} - fSize := B.bmWidth; - {$ENDIF} - if II.hbmMask <> 0 then - DeleteObject( II.hbmMask ); - if II.hbmColor <> 0 then - DeleteObject( II.hbmColor ); - end; -end; -{$ENDIF PAS_VERSION} - -procedure TIcon.SetHandleEx(NewHandle: HIcon); -begin - if FHandle = NewHandle then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Clear; - FHandle := NewHandle; -end; - -procedure TIcon.SetSize(const Value: Integer); -begin - {$IFDEF ICON_DIFF_WH} - if (fWidth = Value) and (fHeight = Value) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>} - {$ELSE} - if FSize = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - Clear; - {$IFDEF ICON_DIFF_WH} - fWidth := Value; - fHeight := Value; - {$ELSE} - FSize := Value; - {$ENDIF} -end; - -{$IFDEF ICON_DIFF_WH} -function TIcon.GetIconSize: Integer; -begin - Result := Max( fWidth, fHeight ); -end; -{$ENDIF} - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function ColorBits( ColorsCount : Integer ) : Integer; -var I : Integer; -begin - for I := 1 to 6 do - begin - Result := PossibleColorBits[ I ]; - if (1 shl Result) >= ColorsCount then break; - end; -end; -{$ENDIF PAS_VERSION} - -function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean; -var I, Off : Integer; - IDI : TIconDirEntry; - BIH : TBitmapInfoHeader; - B: TagBitmap; - function RGBArraySize : Integer; - begin - Result := 0; - if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then - Result := (IDI.bColorCount + (IDI.bReserved shl 8)) * Sizeof( TRGBQuad ); - end; - function ColorDataSize( W, H: Integer ) : Integer; - var N: Integer; - begin - if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then - N := (ColorBits( IDI.bColorCount + (IDI.bReserved shl 8) ) ) - else - begin - N := IDI.wBitCount; - end; - Result := ((N * W + 31) div 32) * 4 - * H; - end; - function MaskDataSize( W, H: Integer ) : Integer; - begin - Result := ((W + 31) div 32) * 4 * H; - end; -var BColor, BMask: HBitmap; - W, H: Integer; - ImgBmp, MskBmp: PBitmap; - IH : TIconHeader; - Colors : PList; -begin - {$IFDEF KOL_ASSERTIONS} - Assert( (High(BmpHandles) >= 0) and (High(BmpHandles) and 1 <> 0), - 'Incorrect parameters count in call to SaveIcons2StreamEx' ); - {$ENDIF KOL_ASSERTIONS} - Result := False; - IH.idReserved := 0; - IH.idType := 1; - IH.idCount := (High( BmpHandles )+1) div 2; - if Strm.Write( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit; {>>>>>>>>>>>>>>>} - Off := Sizeof( IH ) + IH.idCount * Sizeof( IDI ); - Colors := NewList; - ImgBmp := NewBitmap( 0, 0 ); - MskBmp := NewBitmap( 0, 0 ); - TRY - - for I := 0 to High( BmpHandles ) div 2 do - begin - BColor := BmpHandles[ I * 2 ]; - BMask := BmpHandles[ I * 2 + 1 ]; - if (BColor = 0) and (BMask = 0) then break; - {$IFDEF KOL_ASSERTIONS} - Assert( BMask <> 0, 'Mask bitmap not provided for saving icons in SaveIcons2StreamEx' ); - {$ENDIF KOL_ASSERTIONS} - GetObject( BMask, Sizeof( B ), @ B ); - W := B.bmWidth; - H := B.bmHeight; - if BColor <> 0 then - begin - GetObject( BColor, Sizeof( B ), @B ); - {$IFDEF KOL_ASSERTIONS} - Assert( (B.bmWidth = W) and (B.bmHeight = H), - 'Mask bitmap size must much color bitmap size in SaveIcons2StreamEx' ); - {$ENDIF KOL_ASSERTIONS} - end; - ZeroMemory( @IDI, Sizeof( IDI ) ); - - IDI.bWidth := W; - IDI.bHeight := H; - if BColor = 0 then - IDI.bColorCount := 2 - else - begin - ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H, - LR_CREATEDIBSECTION ); - ZeroMemory( @BIH, Sizeof( BIH ) ); - BIH.biSize := Sizeof( BIH ); - GetObject( ImgBmp.Handle, Sizeof( B ), @B ); - if (B.bmPlanes = 1) and (B.bmBitsPixel >= 15) then - begin - IDI.bColorCount := 0; - IDI.bReserved := 0; - IDI.wBitCount := B.bmBitsPixel; - end - else - if B.bmPlanes * (1 shl B.bmBitsPixel) < 16 then - begin - ImgBmp.PixelFormat := pf1bit; - IDI.bColorCount := 2; - end - else - if B.bmPlanes * (1 shl B.bmBitsPixel) < 256 then - begin - ImgBmp.PixelFormat := pf4bit; - IDI.bColorCount := 16; - end - else - begin - ImgBmp.PixelFormat := pf8bit; - IDI.bColorCount := 0; - IDI.bReserved := 1; - end; - end; - Colors.Add( Pointer(IDI.bColorCount + (IDI.bReserved shl 8)) ); - IDI.dwBytesInRes := Sizeof( BIH ) + RGBArraySize + - ColorDataSize( W, H ) + MaskDataSize( W, H ); - IDI.dwImageOffset := Off; - if Strm.Write( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit; {>>>>>>>>} - Inc( Off, IDI.dwBytesInRes ); - end; - for I := 0 to High( BmpHandles ) div 2 do - begin - BColor := BmpHandles[ I * 2 ]; - BMask := BmpHandles[ I * 2 + 1 ]; - if (BColor = 0) and (BMask = 0) then break; - GetObject( BMask, Sizeof( B ), @ B ); - W := B.bmWidth; - H := B.bmHeight; - - ZeroMemory( @BIH, Sizeof( BIH ) ); - BIH.biSize := Sizeof( BIH ); - BIH.biWidth := W; - BIH.biHeight := H; - if BColor <> 0 then - BIH.biHeight := W * 2; - BIH.biPlanes := 1; - PWord( @ IDI.bColorCount )^ := DWord( Colors.Items[ I ] ); - if IDI.wBitCount = 0 then - IDI.wBitCount := ColorBits( PWord( @ IDI.bColorCount )^ ); - BIH.biBitCount := IDI.wBitCount; - BIH.biSizeImage := Sizeof( BIH ) + ColorDataSize( W, H ) + MaskDataSize( W, H ); - if Strm.Write( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit; {>>>>>>>>} - if BColor <> 0 then - begin - - ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H, 0 ); - case BIH.biBitCount of - 1 : ImgBmp.PixelFormat := pf1bit; - 4 : ImgBmp.PixelFormat := pf4bit; - 8 : ImgBmp.PixelFormat := pf8bit; - 16: ImgBmp.PixelFormat := pf16bit; - 24: ImgBmp.PixelFormat := pf24bit; - 32: ImgBmp.PixelFormat := pf32bit; - end; - end - else - begin - ImgBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 ); - ImgBmp.PixelFormat := pf1bit; - end; - if ImgBmp.FDIBBits <> nil then - begin - if Strm.Write( Pointer(Integer(ImgBmp.FDIBHeader) + Sizeof(TBitmapInfoHeader))^, - PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) ) <> - PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) then Exit; {>>>>>>>} - if Strm.Write( ImgBmp.FDIBBits^, ColorDataSize( W, H ) ) <> - DWord( ColorDataSize( W, H ) ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - MskBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 ); - - MskBmp.PixelFormat := pf1bit; - if Strm.Write( MskBmp.FDIBBits^, MaskDataSize( W, H ) ) <> - DWord( MaskDataSize( W, H ) ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - - FINALLY - Colors.Free; - ImgBmp.Free; - MskBmp.Free; - END; - Result := True; -end; - -{$IFDEF FPC} - {$DEFINE _D3orFPC} -{$ENDIF} -{$IFDEF _D2orD3} - {$DEFINE _D3orFPC} -{$ENDIF} -procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream ); -var I, J, Pos : Integer; - {$IFDEF _D3orFPC} - Bitmaps: array[ 0..63 ] of HBitmap; - {$ELSE DELPHI} - Bitmaps: array of HBitmap; - {$ENDIF FPC/DELPHI} - II: TIconInfo; - Bmp: HBitmap; -begin - for I := 0 to High( Icons ) do - begin - if Icons[ I ].Handle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - for J := I + 1 to High( Icons ) do - if Icons[ I ].Size = Icons[ J ].Size then Exit; {>>>>>>>>>>>>>>>>>>>>>>} - end; - Pos := Strm.Position; - - {$IFDEF _D3orFPC} - for I := 0 to High( Bitmaps ) do - Bitmaps[ I ] := 0; - {$ELSE DELPHI} - SetLength( Bitmaps, Length( Icons ) * 2 ); - {$ENDIF FPC/DELPHI} - for I := 0 to High( Icons ) do - begin - GetIconInfo( Icons[ I ].Handle, II ); - Bitmaps[ I * 2 ] := II.hbmColor; - Bitmaps[ I * 2 + 1 ] := II.hbmMask; - end; - - if not SaveIcons2StreamEx( Bitmaps, Strm ) then - Strm.Seek( Pos, spBegin ); - - for I := 0 to High( Bitmaps ) do - begin - Bmp := Bitmaps[ I ]; - if Bmp <> 0 then - DeleteObject( Bmp ); - end; -end; - -procedure SaveIcons2File( const Icons : array of PIcon; const FileName : KOLString ); -var Strm: PStream; -begin - Strm := NewWriteFileStream( FileName ); - SaveIcons2Stream( Icons, Strm ); - Strm.Free; -end; - -procedure TIcon.LoadFromExecutable(const FileName: KOLString; IconIdx: Integer); -var I: Integer; -begin - Clear; - I := ExtractIcon( hInstance, PKOLChar( FileName ), IconIdx ); - if I > 1 then - Handle := I; -end; - -function GetFileIconCount( const FileName: KOLString ): Integer; -begin - Result := ExtractIcon( hInstance, PKOLChar( FileName ), DWORD(-1) ); -end; - -procedure TIcon.LoadFromResourceID(Inst, ResID, DesiredSize: Integer); -begin - LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ), DesiredSize ); -end; - -procedure TIcon.LoadFromResourceName(Inst: Integer; ResName: PKOLChar; DesiredSize: Integer); -begin - Handle := LoadImage( Inst, ResName, IMAGE_ICON, DesiredSize, DesiredSize, $8000 {LR_SHARED} ); - if fHandle <> 0 then FShareIcon := True; -end; - -function LoadImgIcon( RsrcName: PKOLChar; Size: Integer ): HIcon; -begin - Result := LoadImage( hInstance, RsrcName, IMAGE_ICON, Size, Size, $8000 {LR_SHARED} ); -end; - -{$IFDEF OLD_ALIGN} -procedure AlignChildrenProc( Sender: PObj ); -type - TAligns = set of TControlAlign; -var P: PControl; - CR: TRect; - procedure DoAlign( Allowed: TAligns ); - var I: Integer; - C: PControl; - R, R1: TRect; - W, H: Integer; - ChgPos, ChgSiz: Boolean; - begin - for I := 0 to P.fChildren.fCount - 1 do - begin - C := P.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - if not C.ToBeVisible then continue; - // important: not fVisible, and even not Visible, but ToBeVisible! - if {$IFDEF USE_FLAGS} G4_NotUseAlign in C.fFlagsG4 - {$ELSE} C.fNotUseAlign {$ENDIF} then continue; - if C.FAlign in Allowed then - begin - R := C.BoundsRect; - R1 := R; - W := R.Right - R.Left; - H := R.Bottom - R.Top; - case C.FAlign of - caTop: - begin - OffsetRect( R, 0, -R.Top + CR.Top + P.Margin ); - Inc( CR.Top, H + P.Margin ); - R.Left := CR.Left + P.Margin; - R.Right := CR.Right - P.Margin; - end; - caBottom: - begin - OffsetRect( R, 0, -R.Bottom + CR.Bottom - P.Margin ); - Dec( CR.Bottom, H + P.Margin ); - R.Left := CR.Left + P.Margin; - R.Right := CR.Right - P.Margin; - end; - caLeft: - begin - OffsetRect( R, -R.Left + CR.Left + P.Margin, 0 ); - Inc( CR.Left, W + P.Margin ); - R.Top := CR.Top + P.Margin; - R.Bottom := CR.Bottom - P.Margin; - end; - caRight: - begin - OffsetRect( R, -R.Right + CR.Right - P.Margin, 0 ); - Dec( CR.Right, W + P.Margin ); - R.Top := CR.Top + P.Margin; - R.Bottom := CR.Bottom - P.Margin; - end; - caClient: - begin - R := CR; - InflateRect( R, -P.Margin, -P.Margin ); - end; - end; - if R.Right < R.Left then R.Right := R.Left; - if R.Bottom < R.Top then R.Bottom := R.Top; - ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top); - ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H); - if ChgPos or ChgSiz then - begin - C.BoundsRect := R; - if ChgSiz then - AlignChildrenProc( C ); - end; - end; - end; - end; -begin - P := Pointer( Sender ); - if P = nil then Exit; // Called for form - ignore. {>>>>>>>>>>>>>>>>>>>>>>>>>} - CR := P.ClientRect; - if CR.Right <= CR.Left then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - DoAlign( [ caTop, caBottom ] ); - DoAlign( [ caLeft, caRight ] ); - DoAlign( [ caClient ] ); -end; -{$ELSE NEW_ALIGN} - -procedure AlignChildrenProc_(P:PControl); -type TAligns = set of TControlAlign; -var CR: TRect; - procedure DoAlign( Allowed: TAligns ); - var I, W, H: Integer; - C: PControl; - R, R1: TRect; - ChgPos, ChgSiz: Boolean; - begin - for I := 0 to P.fChildren.fCount - 1 do - begin - if not (oaAligning in P.fAligning) then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>} - C := P.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - with C^ do - begin - {$IFDEF SAFE_CODE} - C.RefInc; - TRY - {$ENDIF} - if (not( - {$IFDEF USE_FLAGS} (F3_Visible in fStyle.f3_Style) - {$ELSE} fVisible {$ENDIF} - {$IFDEF CREATE_HIDDEN} - or - {$IFDEF USE_FLAGS} (G4_CreateHidden in fFlagsG4) - {$ELSE} fCreateHidden {$ENDIF} - {$ENDIF CREATE_HIDDEN} - )) - or(not(fAlign in Allowed)) then continue; - if {$IFDEF USE_FLAGS} not(G4_NotUseAlign in fFlagsG4) - {$ELSE} not fNotUseAlign {$ENDIF} then - begin - R := BoundsRect; - R1 := R; - W := R.Right - R.Left; - H := R.Bottom - R.Top; - case FAlign of - caTop: - begin - OffsetRect( R, 0, -R.Top + CR.Top + P.Margin ); - Inc( CR.Top, H + P.Margin ); - R.Left := CR.Left + P.Margin; - R.Right := CR.Right - P.Margin; - end; - caBottom: - begin - OffsetRect( R, 0, -R.Bottom + CR.Bottom - P.Margin ); - Dec( CR.Bottom, H + P.Margin ); - R.Left := CR.Left + P.Margin; - R.Right := CR.Right - P.Margin; - end; - caLeft: - begin - OffsetRect( R, -R.Left + CR.Left + P.Margin, 0 ); - Inc( CR.Left, W + P.Margin ); - R.Top := CR.Top + P.Margin; - R.Bottom := CR.Bottom - P.Margin; - end; - caRight: - begin - OffsetRect( R, -R.Right + CR.Right - P.Margin, 0 ); - Dec( CR.Right, W + P.Margin ); - R.Top := CR.Top + P.Margin; - R.Bottom := CR.Bottom - P.Margin; - end; - caClient: - begin - R := CR; - InflateRect( R, -P.Margin, -P.Margin ); - end; - end; - if R.Right < R.Left then R.Right := R.Left; - if R.Bottom < R.Top then R.Bottom := R.Top; - ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top); - ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H); - if ChgSiz then - begin - exclude(fAligning,oaWaitAlign); - include(fAligning,oaFromSelf); - end; - if ChgPos or ChgSiz then BoundsRect := R; - end; - {$IFDEF SAFE_CODE} - FINALLY - C.RefDec; - END; - {$ENDIF SAFE_CODE} - if oaWaitAlign in fAligning then AlignChildrenProc_(C); - end; - end; - end; - -begin - exclude(P.fAligning,oaWaitAlign); - include(P.fAligning,oaAligning); - CR := P.ClientRect; - DoAlign( [ caTop, caBottom ] ); - DoAlign( [ caLeft, caRight ] ); - DoAlign( [ caClient,caNone ] ); - exclude(P.fAligning,oaAligning); -end; - -{$IFDEF ASM_TLIST} -procedure AlignChildrenProc(Sender: PObj); -const AlignModes = (1 shl byte(caBottom))+(1 shl byte(caTop))+ - (((1 shl byte(caRight)) +(1 shl byte(caLeft)))shl 8)+ - (((1 shl byte(caClient))+(1 shl byte(caNone)))shl 16); -asm //cmd //opd - TEST EAX,EAX - JZ @@21 - CMP [EAX].TControl.fParent,0 - SETZ DL - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fFlagsG3, (1 shl G3_IsForm) - SETNZ DH - OR DL, DH - {$ELSE} - OR DL,[EAX].TControl.fIsForm - {$ENDIF} - BTR dword ptr[EAX].TControl.fAligning,oaFromSelf - JA @@20 - OR byte ptr[EAX].TControl.fAligning,(1 shl oaWaitAlign) - MOV EAX,[EAX].TControl.fParent -@@20: TEST EAX, EAX - JZ @@21 - CALL @@ToBeAlign - JNZ @@DoAlign -@@21: RETN - -@@ToBeAlign: - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fStyle.f3_Style, 1 shl F3_Visible - SETNZ DL - {$ELSE} - MOV DL,[EAX].TControl.fVisible - {$ENDIF} - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fFlagsG3, 1 shl G3_IsForm - SETNZ DH - OR DL, DH - TEST [EAX].TControl.fFlagsG4, (1 shl G4_CreateHidden) - SETNZ DH - OR DL, DH - {$ELSE} - OR DL,[EAX].TControl.fCreateHidden - {$ENDIF} - JE @@10 - {$IFDEF USE_FLAGS} - TEST [EAX].TControl.fFlagsG3, 1 shl G3_IsForm - SETNZ DH - AND DL, DH - {$ELSE} - AND DL,[EAX].TControl.fIsForm - {$ENDIF} - JNE @@12 - CMP dword ptr[EAX].TControl.fParent,0 - JE @@11 - PUSH EAX - MOV EAX,[EAX].TControl.fParent - CALL @@ToBeAlign - POP EAX -@@10: XOR DL,1 -//!!! Important: oaWaitAlign=0 - OR [EAX].TControl.fAligning,DL -@@11: XOR DL,1 -@@12: RETN - -@@DoAlign: - //CALL AlignChildrenProc_ - //RET - PUSH EBP - PUSH EBX - PUSH ESI - PUSH EDI - PUSH AlignModes //00210A14h - SUB ESP,030h - MOV EBX,EAX - AND byte ptr[EBX].TControl.fAligning,not(1 shl oaWaitAlign) - OR byte ptr[EBX].TControl.fAligning,(1 shl oaAligning) - LEA EDX,[ESP+20h] //@CR - CALL TControl.ClientRect -@@Main: - MOV EAX,[EBX].TControl.fChildren - MOV EDI,[EAX].TList.fCount - MOV EBP,[EAX].TList.fItems - JMP @@entry -@@loop: - MOV ESI,[EBP] - {$IFDEF USE_FLAGS} - MOV AL,[ESI].TControl.fStyle.f3_Style - SHR AL, F3_Visible - OR AL,[ESI].TControl.fFlagsG4 - AND AL, 1 shl G4_CreateHidden // G4_CreateHidden = 0 !!! - {$ELSE} - MOV AL,[ESI].TControl.fVisible - OR AL,[ESI].TControl.fCreateHidden - {$ENDIF} - JZ @@continue - MOVZX EAX,[ESI].TControl.fAlign - BT [ESP+30h],EAX //Allowed - JNC @@continue - {$IFDEF USE_FLAGS} - TEST [ESI].TControl.fFlagsG4, 1 shl G4_NotUseAlign - {$ELSE} - CMP byte ptr[ESI].TControl.fNotUseAlign,0 - {$ENDIF} - JNE @@align - MOV EDX,ESP //@R - MOV EAX,ESI //C - CALL TControl.GetBoundsRect - MOV EAX,[ESP+0Ch] //R.Bottom - MOV [ESP+1Ch],EAX //H - MOV EAX,[ESP+08h] //R.Right - MOV [ESP+18h],EAX //W - MOV EAX,[ESP+04h] //R.Top - MOV [ESP+14h],EAX //R1.Top - SUB [ESP+1Ch],EAX //H - MOV EAX,[ESP] //R.Left - MOV [ESP+10h],EAX //R1.Left - SUB [ESP+18h],EAX //W - MOVSX EDX,[EBX].TControl.fMargin - MOVZX ECX,byte ptr[ESI].TControl.fAlign -//!!! Order of caXXX-constants is important - LOOP @@caTop - MOV EAX,[ESP+20h] //CR.Left - SUB EAX,[ESP] //R.Left - ADD EAX,EDX //+Margin - MOV ECX,[ESP+18h] //W - ADD ECX,EDX //+Margin - ADD [ESP+20h],ECX //CR.Left - JMP @@00 -@@caTop: - LOOP @@caRight - MOV EAX,[ESP+24h] //CR.Top - SUB EAX,[ESP+04h] //R.Top - ADD EAX,EDX //+Margin - MOV ECX,[ESP+1Ch] //H - ADD ECX,EDX //+Margin - ADD [ESP+24h],ECX //CR.Top - JMP @@01 -@@caRight: - LOOP @@caBottom - MOV EAX,[ESP+28h] //CR.Right - SUB EAX,[ESP+08h] //R.Right - SUB EAX,EDX //-Margin - MOV ECX,[ESP+18h] //W - ADD ECX,EDX //+Margin - SUB [ESP+28h],ECX //CR.Right -@@00: ADD [ESP],EAX //R.Left - ADD [ESP+08h],EAX //R.Right - MOV EAX,[ESP+2Ch] //CR.Bottom - SUB EAX,EDX //+Margin - MOV [ESP+0Ch],EAX //R.Bottom - ADD EDX,[esp+24h] //Margin+CR.Top - MOV [ESP+04h],edx //R.Top - JMP @@caNone -@@caBottom: - LOOP @@caClient - MOV EAX,[ESP+2Ch] //CR.Bottom - SUB EAX,[ESP+0Ch] //R.Bottom - SUB EAX,EDX //-Margin - MOV ECX,[ESP+1Ch] //H - ADD ECX,EDX //+Margin - SUB [ESP+2Ch],ECX //CR.Bottom -@@01: ADD [ESP+04h],EAX //R.Top - ADD [ESP+0Ch],EAX //R.Bottom - MOV EAX,[ESP+28h] //CR.Right - SUB EAX,EDX //-Margin - MOV [esp+08h],EAX //R.Right - ADD EDX,[ESP+20h] //Margin+CR.Left - MOV [ESP],EDX //R.Left - JMP @@caNone -@@caClient: - LOOP @@caNone - MOV EAX,[ESP+2Ch] //CR.Bottom - SUB EAX,EDX //-Margin - MOV [ESP+0Ch],EAX //R.Bottom - MOV EAX,[ESP+28h] //CR.Right - SUB EAX,EDX //-Margin - MOV [ESP+08h],EAX //R.Right - MOV EAX,[ESP+24h] //CR.Top - ADD EAX,EDX //+Margin - MOV [ESP+04h],EAX //R.Top - ADD EDX,[ESP+20h] //Margin+CR.Left - MOV [ESP],EDX //R.Left -@@caNone: - MOV EAX,[ESP] //R.Left - CMP EAX,[ESP+08h] //R.Right - JLE @@02 //CMOVG ??? - MOV [ESP+08h],EAX //R.Right -@@02: MOV EAX,[ESP+04h] //R.Top - CMP EAX,[ESP+0Ch] //R.Bottom - JLE @@03 //CMOVG ??? - MOV [ESP+0Ch],EAX //R.Bottom -@@03: MOV EDX,[ESP] //R.Left - SUB EDX,[ESP+10h] //R1.Left - MOV EAX,[ESP+04h] //R.Top - SUB EAX,[ESP+14h] //R1.Top - OR EDX,EAX //ChgPos - MOV ECX,[ESP+08h] //R.Right - SUB ECX,[ESP] //R.Left - SUB ECX,[ESP+18h] //W - MOV EAX,[ESP+0Ch] //R.Bottom - SUB EAX,[ESP+04h] //R.Top - SUB EAX,[ESP+1Ch] //H - OR EAX,ECX - JZ @@04 - AND byte ptr[ESI].TControl.fAligning,not(1 shl oaWaitAlign) - OR byte ptr[ESI].TControl.fAligning,(1 shl oaFromSelf) -@@04: OR EAX,EDX - JZ @@align - MOV EDX,ESP //@R - MOV EAX,ESI //C - CALL TControl.SetBoundsRect -@@align: - TEST byte ptr[ESI].TControl.fAligning,(1 shl oaWaitAlign) - JZ @@continue - MOV EAX,ESI //C - CALL @@DoAlign -@@continue: - TEST byte ptr[EBX].TControl.fAligning,(1 shl oaAligning) - JZ @@exit - ADD EBP,4 -@@entry: - DEC EDI - JGE @@loop - SHR dword ptr[ESP+30h],8 //Allowed - JNZ @@Main - AND byte ptr[EBX].TControl.fAligning,not(1 shl oaAligning) -@@exit: - ADD ESP,34h - POP EDI - POP ESI - POP EBX - POP EBP -end; -{$ELSE PAS_VERSION} // Pascal -procedure AlignChildrenProc(Sender: PObj); - function ToBeAlign( S: PControl ):Boolean; - begin - {$IFDEF USE_FLAGS} - Result := ( - (F3_Visible in S.fStyle.f3_Style) - or ( - (G3_IsForm in S.fFlagsG3) // так надо! - {$IFDEF CREATE_HIDDEN} - or (G4_CreateHidden in S.fFlagsG4) - {$ENDIF CREATE_HIDDEN} - ) ) - and ( (G3_IsForm in S.fFlagsG3) - or (S.fParent=nil) or ToBeAlign(S.fParent) - ); - {$ELSE} - Result := ( - S.fVisible - {$IFDEF CREATE_HIDDEN} - or ( - S.fCreateHidden - ) - {$ENDIF CREATE_HIDDEN} - ) - and ( S.fIsForm - or (S.fParent=nil) or ToBeAlign(S.fParent) - ); - {$ENDIF} - if not Result then include(S.fAligning,oaWaitAlign); - end; -var fromSelf: Boolean; - S: PControl; -begin - if Sender = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - S := Pointer( Sender ); - fromSelf := oaFromSelf in S.fAligning; - Exclude( S.fAligning, oaFromSelf ); - if ( (S.fParent = nil) - or {$IFDEF USE_FLAGS} (G3_IsForm in S.fFlagsG3) - {$ELSE} (S.fIsForm) {$ENDIF} ) and (not fromSelf) then - else - begin - include(S.fAligning, oaWaitAlign); - S := S.Parent; - end; - if (S <> nil) and ToBeAlign(S) then - AlignChildrenProc_(S); -end; -{$ENDIF PAS_VERSION} -{$ENDIF OLD_ALIGN} - -procedure TControl.Set_Align(const Value: TControlAlign); -begin - Global_Align := AlignChildrenProc; - if {$IFDEF USE_FLAGS} G4_NotUseAlign in fFlagsG4 - {$ELSE} fNotUseAlign {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if FAlign = Value then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FAlign := Value; - {$IFDEF OLD_ALIGN} - AlignChildrenProc( Parent ); - {$ELSE NEW_ALIGN} - AlignChildrenProc(@Self); - {$ENDIF} -end; - -function TControl.SetAlign(AAlign: TControlAlign): PControl; -begin - Set_Align( AAlign ); - Result := @Self; -end; - -{$IFDEF LOG_ANTIFLICK} -procedure LogFlick( const s: AnsiString; const rects: array of TRect ); -var s1: AnsiString; - i: Integer; -begin - s1 := s + ' '; - for i := 0 to High( rects ) do - begin - s1 := s1 + '[' + Int2Str( rects[i].Left ) + ',' + Int2Str( rects[i].top ) + - ',' + Int2Str( rects[i].Right ) + ',' + Int2Str( rects[i].Bottom ) + - '=' + Int2Str( rects[i].Right - rects[i].Left ) + 'x' + - Int2Str( rects[i].Bottom - rects[i].Top ) + ']'; - end; - LogFileOutput( GetStartDir + 'log_antiflick', s1 ); -end; -{$ENDIF} - -procedure TControl.Update; -var I: Integer; - C: PControl; -begin - if fUpdateCount > 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - UpdateWindow( fHandle ); - for I := 0 to fChildren.fCount - 1 do - begin - C := fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - C.Update; - end; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - if Sender.fUpdateCount <> 0 then - begin - case Msg.message of - WM_PAINT: - begin - ValidateRect( Sender.Handle, nil ); - Rslt := 0; - end; - WM_ERASEBKGND: Rslt := 1; - else begin - Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := TRUE; - end - else Result := FALSE; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.BeginUpdate; -begin - Inc( fUpdateCount ); - AttachProc( @WndProcUpdate ); -end; - -procedure TControl.EndUpdate; -begin - Dec( fUpdateCount ); - if fUpdateCount <= 0 then - begin - Invalidate; - //Update; - end; -end; - -function TControl.GetSelection: KOLString; -var L: Integer; -begin - if fCommandActions.aGetSelection <> 0 then - begin - L := SelLength; - SetString( Result, nil, L + 1 ); - Perform( fCommandActions.aGetSelection, 0, Integer( @Result[ 1 ] ) ); - end - else - Result := Copy( Text, SelStart + 1, SelLength ); -end; - -procedure TControl.SetSelection(const Value: KOLString); -begin - ReplaceSelection( Value, True ); -end; - -procedure TControl.ReplaceSelection(const Value: KOLString; aCanUndo: Boolean); -begin - if fCommandActions.aReplaceSel <> 0 then - begin - Perform( fCommandActions.aReplaceSel, Integer( aCanUndo ), Integer( PKOLchar( Value ) ) ); - end; -end; - -procedure TControl.DeleteLines(FromLine, ToLine: Integer); -var I1, I2: DWORD; - SStart, SLength: DWORD; -begin - if FromLine > ToLine then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$IFDEF KOL_ASSERTIONS} - Assert( FromLine >= 0, 'Incorrect line index' ); - {$ENDIF KOL_ASSERTIONS} - I1 := Item2Pos( FromLine ); - I2 := Item2Pos( ToLine+1 ) - I1; - SStart := SelStart; - SLength := SelLength; - SelStart := I1; - {if ToLine >= Count-1 then - I2 := MaxInt;} - SelLength := I2; - ReplaceSelection( '', TRUE ); - if SStart >= I2 then - begin - SStart := SStart - (I2 - I1); - end - else - if SStart >= I1 then - begin - SLength := SLength - (I2 - SStart); - SStart := I1; - end - else - if SStart + SLength >= I2 then - begin - SLength := SLength - (I2 - I1); - end - else - if SStart + SLength >= I1 then - begin - SLength := I1 - SLength; - end; - SelStart := SStart; - SelLength := Max( 0, SLength ); -end; - -procedure TControl.SetTabOrder(const Value: SmallInt); -var CL: PList; - I : Integer; - C: PControl; -begin - if Value = fTabOrder then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - CL := CollectTabControls( ParentForm ); - for I := 0 to CL.fCount - 1 do - begin - C := CL.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - if C.fTabOrder >= Value then - Inc( C.fTabOrder ); - end; - fTabOrder := Value; - CL.Free; -end; - -function TControl.GetFocused: Boolean; -begin - if {$IFDEF USE_FLAGS} G3_IsControl in fFlagsG3 - {$ELSE} fIsControl {$ENDIF} then - Result := ParentForm.DF.fCurrentControl = @Self - else - Result := GetForegroundWindow = fHandle; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -procedure TControl.SetFocused(const Value: Boolean); -var PF: PControl; -begin - if not Value or - {$IFDEF USE_FLAGS} not( F2_Tabstop in fStyle.f2_Style ) - {$ELSE} not fTabStop {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>} - if {$IFDEF USE_FLAGS} G3_IsControl in fFlagsG3 - {$ELSE} fIsControl {$ENDIF} then - begin - PF := ParentForm; - if ( PF.DF.fCurrentControl <> nil ) and (PF.DF.fCurrentControl <> @ Self) then - if Assigned( PF.DF.fCurrentControl.EV.fLeave ) then - PF.DF.fCurrentControl.EV.fLeave( PF.DF.fCurrentControl ) - else - Windows.SetFocus( 0 ); - PF.DF.fCurrentControl := @Self; - {$IFDEF USE_GRAPHCTLS} - if Assigned( fSetFocus ) then - fSetFocus(@Self) - else - {$ENDIF} - SetFocus( GetWindowHandle ); - end - else - SetForegroundWindow( GetWindowHandle ); -end; -{$ENDIF PAS_VERSION} - -{$IFNDEF NOT_USE_RICHEDIT} - -////////////////////////////////////////////////////////////////////// -// R I C H E D I T -////////////////////////////////////////////////////////////////////// - -{ -- rich edit -- } - -function TControl.REGetFont: PGraphicTool; -var - CF: PCharFormat; - //CFA: PCharFormat2A; - //CFW: PCharFormat2W; - FS: TFontStyle; -begin - {$IFDEF STATIC_RICHEDIT_DATA} - CF := @ DF.fRECharFormatRec; - {$ELSE} - CF := DF.fRECharFormatRec; - {$ENDIF} - ZeroMemory( CF, Sizeof( CF^ ) ); - {$IFDEF UNICODE_CTRLS} - CF.cbSize := Sizeof( CF^ ); - {$ELSE} - CF.cbSize := sizeof( RichEdit.TCharFormat ) + DF.fCharFmtDeltaSz; - {$ENDIF} - if DF.fTmpFont = nil then - begin - DF.fTmpFont := NewFont; - {$IFDEF USE_AUTOFREE4CONTROLS} - Add2AutoFree( DF.fTmpFont ); - {$ENDIF} - end; - Result := DF.fTmpFont; - Result.OnChange := nil; - Perform( EM_GETCHARFORMAT, 1, Integer( CF ) ); - Result.FontHeight := CF.yHeight; - FS := [ ]; - if LongBool(CF.dwEffects and CFE_BOLD) then - FS := [ fsBold ]; - if LongBool(CF.dwEffects and CFE_ITALIC) then - include( FS, fsItalic ); - if LongBool(CF.dwEffects and CFE_STRIKEOUT) then - include( FS, fsStrikeOut ); - if LongBool(CF.dwEffects and CFE_UNDERLINE) then - include( FS, fsUnderline ); - Result.FontStyle := FS; - if not LongBool(CF.dwEffects and CFE_AUTOCOLOR) then - Result.Color := CF.crTextColor; - Result.FontPitch := TFontPitch( CF.bPitchAndFamily and 3 ); - Result.FontCharset := CF.bCharSet; - {$IFDEF UNICODE_CTRLS} - {$ELSE} - if (PWord( @CF.szFaceName[0] )^ shr 8) <> 0 then - Result.FontName := PAnsiChar(@CF.szFaceName[0]) // real T,0 works fine. - else - {$ENDIF} - Result.FontName := KOLString(PWideChar(@CF.szFaceName[0])); - Result.OnChange := RESetFont; -end; - -const RichAreas: array[ TRichFmtArea ] of Integer = ( SCF_SELECTION, - 3 {SCF_WORD}, 4 {SCF_ALL} ); - -procedure TControl.RESetFontEx(const Index: Integer); -var CF: PCharFormat; - FS: TFontStyle; -begin - {$IFDEF STATIC_RICHEDIT_DATA} - CF := @ DF.fRECharFormatRec; - {$ELSE} - CF := DF.fRECharFormatRec; - {$ENDIF} - ZeroMemory( CF, {82} sizeof( CF^ ) ); - {$IFDEF UNICODE_CTRLS} - CF.cbSize := Sizeof( CF^ ); - {$ELSE} - CF.cbSize := 60 { sizeof( TCharFormat ) } + DF.fCharFmtDeltaSz; - {$ENDIF} - CF.dwMask := CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC - or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE; - CF.yHeight := DF.fTmpFont.FontHeight; - FS := DF.fTmpFont.FontStyle; - if fsBold in FS then CF.dwEffects := CFE_BOLD; - if fsItalic in FS then CF.dwEffects := CF.dwEffects or CFE_ITALIC; - if fsStrikeOut in FS then CF.dwEffects := CF.dwEffects or CFE_STRIKEOUT; - if fsUnderline in FS then CF.dwEffects := CF.dwEffects or CFE_UNDERLINE; - CF.crTextColor := Color2RGB(DF.fTmpFont.Color); - CF.bCharSet := DF.fTmpFont.FontCharset; - CF.bPitchAndFamily := Ord( DF.fTmpFont.FontPitch ); - {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF} - ( CF.szFaceName, PKOLChar( DF.fTmpFont.FontName ), 31 ); - Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ], Integer( CF ) ); -end; - -procedure TControl.RESetFont(Value: PGraphicTool); -var H: Integer; -begin - if Value <> DF.fTmpFont then - REGetFont; - H := DF.fTmpFont.fData.Font.Height; - DF.fTmpFont := DF.fTmpFont.Assign( Value ); - if DF.fTmpFont.fData.Font.Height = 0 then - DF.fTmpFont.fData.Font.Height := H; - RESetFontEx( Integer( CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC - or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE ) ); -end; - -function TControl.REGetFontMask( const Index: Integer ): Boolean; -begin - REGetFont; - Result := LongBool( DF.fRECharFormatRec.dwMask and Index ); -end; - -function TControl.REGetFontEffects(const Index: Integer): Boolean; -begin - REGetFont; - Result := LongBool( DF.fRECharFormatRec.dwEffects and Index ); -end; - -procedure TControl.RESetFontEffect(const Index: Integer; - const Value: Boolean); -var - CF: PCharFormat; -begin - ReGetFont; - {$IFDEF STATIC_RICHEDIT_DATA} - CF := @ DF.fRECharFormatRec; - {$ELSE} - CF := DF.fRECharFormatRec; - {$ENDIF} - { - CF.dwEffects := $FFFFFFFF and Index; - if not Value then CF.dwEffects := 0; - } - CF.dwEffects := CF.dwEffects or DWORD( Index ); - if not Value then CF.dwEffects := CF.dwEffects and not Index; - CF.dwMask := Index; - Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ], Integer( CF ) ); -end; - -function TControl.REGetFontAttr(const Index: Integer): Integer; -var CF: PDWORD; - Mask: DWORD; -begin - REGetFont; - CF := Pointer( Integer( @DF.fRECharFormatRec ) + (HiWord(Index) and $7E) ); - Mask := $FFFFFFFF; - if LongBool( HiWord(Index) and $1 ) then - Mask := $FF; - Result := CF^ and Mask; -end; - -procedure TControl.RESetFontAttr(const Index, Value: Integer); -var CF: PDWORD; - Mask: DWORD; -begin - REGetFont; - {$IFDEF STATIC_RICHEDIT_DATA} - CF := Pointer( Integer( @ DF.fRECharFormatRec ) + (HiWord(Index) and $7E) ); - {$ELSE} - CF := Pointer( Integer( DF.fRECharFormatRec ) + (HiWord(Index) and $7E) ); - {$ENDIF} - Mask := 0; - if LongBool( HiWord(Index) and $1 ) then - Mask := $FFFFFF00; - CF^ := CF^ and Mask or DWORD(Value); - DF.fRECharFormatRec.dwMask := Index and $FF81FFFF; - if LongBool( DF.fRECharFormatRec.dwMask and (CFM_COLOR or CFM_BACKCOLOR) ) then - DF.fRECharFormatRec.dwEffects := DF.fRECharFormatRec.dwEffects and - not (CFE_AUTOCOLOR or CFE_AUTOBACKCOLOR); - Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ], - Integer( {$IFDEF STATIC_RICHEDIT_DATA} @ {$ENDIF} DF.fRECharFormatRec ) ); -end; - -procedure TControl.RESetFontAttr1(const Index, Value: Integer); -begin - RESetFontAttr( Index, Color2RGB( Value ) ); -end; - -function TControl.REGetFontSizeValid: Boolean; -begin - Result := REGetFontMask( Integer( CFM_SIZE ) ); -end; - -function TControl.REGetFontName: KOLString; -begin - ReGetFont; - Result := DF.fRECharFormatRec.szFaceName; -end; - -procedure TControl.RESetFontName(const Value: KOLString); -begin - ReGetFont; - {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF} - ( DF.fRECharFormatRec.szFaceName, PKOLChar( Value ), Sizeof( DF.fRECharFormatRec.szFaceName ) - 1 ); - DF.fRECharFormatRec.dwMask := CFM_FACE; - Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ], Integer( @DF.fRECharFormatRec ) ); -end; - -function TControl.REGetCharformat: TCharFormat; -begin - REGetFont; - Result := {$IFDEF STATIC_RICHEDIT_DATA} DF.fRECharFormatRec - {$ELSE} DF.fRECharFormatRec^ {$ENDIF}; -end; - -procedure TControl.RESetCharFormat(const Value: TCharFormat); -begin - Perform( EM_SETCHARFORMAT, RichAreas[ DF.fRECharArea ], Integer( @Value ) ); -end; - -function REOut2Stream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger ) - :DWORD; stdcall; -begin - if Sz + Sender.DF.fREStream.Position > Sender.DF.fREStream.Size then - Sender.DF.fREStream.Size := Sender.DF.fREStream.Size + DWORD( {Min(} Sz {, 8192 )} ); - pSz^ := Sender.DF.fREStream.Write( Buf^, Sz ); - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnProgress ) then - {$ENDIF} - Sender.EV.fOnProgress( Sender ); - Result := 0; -end; - -const TextTypes: array[ TRETextFormat ] of WORD = ( SF_RTF, SF_TEXT, - SF_RTF or SFF_PLAINRTF, SF_RTFNOOBJS, SF_RTFNOOBJS or SFF_PLAINRTF, - SF_TEXTIZED, {SF_UNICODE} $0010, $0010 or SF_TEXT ); - -function TControl.RE_SaveToStream(Stream: PStream; Format: TRETextFormat; - SelectionOnly: Boolean): Boolean; -var ES: TEditStream; - SelFlag: Integer; -begin - DF.fREStream := Stream; - ES.dwCookie := Integer( @Self ); - ES.dwError := 0; - ES.pfnCallback := @REOut2Stream; - SelFlag := 0; - if SelectionOnly then - SelFlag := SFF_SELECTION; - Perform( EM_STREAMOUT, TextTypes[ Format ] or SelFlag, Integer( @ES ) ); - DF.fREStream := nil; - DF.fREError := ES.dwError; - Result := DF.fREError = 0; -end; - -procedure RE_AddText( Self_: PControl; const S: KOLString ); -begin - Self_.SelStart := Self_.TextSize; - Self_.RE_Text[ reText, True ] := S; -end; - -function TControl.REReadText(Format: TRETextFormat; - SelectionOnly: Boolean): KOLString; -var B0: Integer; - MS: PStream; -begin - fCommandActions.aAddText := RE_AddText; - MS := NewMemoryStream; - RE_SaveToStream( MS, Format, SelectionOnly ); - B0 := 0; - MS.Write( B0, Sizeof( KOLChar ) ); - {$IFDEF UNICODE_CTRLS} - {$ELSE} - if not (Format in [reUnicode,reTextUnicode]) then - Result := AnsiString(PAnsiChar( MS.fMemory )) // must be PAnsiChar, not PKOLChar! - else - {$ENDIF} - Result := PKOLChar( MS.fMemory ); - MS.Free; -end; - -function REInFromStream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger ) - :DWORD; stdcall; -begin - {$IFDEF _D3} if Sender.DF.fREStrLoadLen >= 0 then {$ENDIF} - if Sz > Sender.DF.fREStrLoadLen then - Sz := Sender.DF.fREStrLoadLen; - pSz^ := Sender.DF.fREStream.Read( Buf^, Sz ); - Dec( Sender.DF.fREStrLoadLen, pSz^ ); - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnProgress ) then - {$ENDIF} - Sender.EV.fOnProgress( Sender ); - Result := 0; -end; - -function TControl.RE_LoadFromStream(Stream: PStream; Length: Integer; - Format: TRETextFormat; SelectionOnly: Boolean): Boolean; -var ES: TEditStream; - SelFlag: Integer; -begin - DF.fREStream := Stream; - DF.fREStrLoadLen := DWORD( Length ); - ES.dwCookie := Integer( @Self ); - ES.dwError := 0; - ES.pfnCallback := @REInFromStream; - SelFlag := 0; - if SelectionOnly then - SelFlag := SFF_SELECTION; - Perform( EM_STREAMIN, TextTypes[ Format ] or SelFlag, Integer( @ES ) ); - DF.fREStream := nil; - DF.fREError := ES.dwError; - Result := DF.fREError = 0; -end; - -procedure TControl.REWriteText(Format: TRETextFormat; - SelectionOnly: Boolean; const Value: KOLString); -var MS: PStream; - {$IFDEF UNICODE_CTRLS} - {$ELSE} - s: AnsiString; // not KOLString! - {$ENDIF} -begin - fCommandActions.aAddText := RE_AddText; - {$IFDEF UNICODE_CTRLS} - {$ELSE} - if not (Format in [reUnicode,reTextUnicode]) then - begin - s := Value; - MS := NewExMemoryStream( @ s[ 1 ], Length( s ) ); - end - else - {$ENDIF} - MS := NewExMemoryStream( @ Value[ 1 ], Length( Value ) * Sizeof( KOLChar ) ); - RE_LoadFromStream( MS, MS.fData.fSize, Format, SelectionOnly ); - MS.Free; -end; - -function TControl.RE_LoadFromFile(const Filename: KOLString; - Format: TRETextFormat; SelectionOnly: Boolean): Boolean; -var Strm: PStream; -begin - Strm := NewReadFileStream( Filename ); - Result := RE_LoadFromStream( Strm, -1, Format, SelectionOnly ); - Strm.Free; -end; - -function TControl.RE_SaveToFile(const Filename: KOLString; - Format: TRETextFormat; SelectionOnly: Boolean): Boolean; -var Strm: PStream; -begin - Strm := NewWriteFileStream( Filename ); - Result := RE_SaveToStream( Strm, Format, SelectionOnly ); - Strm.Free; -end; - -function TControl.REGetParaFmt: TParaFormat; -begin - ZeroMemory( @Result, sizeof( TParaFormat2 ) ); - Result.cbSize := sizeof( RichEdit.TParaFormat ) + DF.fParaFmtDeltaSz; - Perform( EM_GETPARAFORMAT, 0, Integer( @Result ) ); -end; - -procedure TControl.RESetParaFmt(const Value: TParaFormat); -begin - Perform( EM_SETPARAFORMAT, 0, Integer( @Value ) ); -end; - -function TControl.REGetNumbering: Boolean; -begin - Result := LongBool( ReGetParaAttr( 9 shl 16 ) ); -end; - -function TControl.REGetParaAttr( const Index: Integer ): Integer; -var pDw : PDWORD; -begin - {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec - {$ELSE} DF.fREParaFmtRec^ {$ENDIF} - := REGetParaFmt; - pDw := Pointer( Integer( @DF.fREParaFmtRec ) + ( HiWord( Index ) and $7E ) ); - Result := pDw^; - if LongBool( HiWord( Index ) and 1 ) then - Result := Result and $FFFF; -end; - -function TControl.REGetParaAttrValid( const Index: Integer ): Boolean; -begin - Result := LongBool( ReGetParaAttr( 4 shl 16 ) and Index ); -end; - -function TControl.REGetTabCount: Integer; -begin - Result := ReGetParaAttr( 27 shl 16 ); -end; - -function TControl.REGetTabs(Idx: Integer): Integer; -begin - Result := ReGetParaAttr( (28 + 4 * Idx) shl 16 ); -end; - -function TControl.REGetTextAlign: TRichTextAlign; -begin - Result := TRichTextAlign( ReGetParaAttr( 25 shl 16 ) - 1 ); -end; - -procedure TControl.RESetNumbering(const Value: Boolean); -begin - RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Integer( Value ) ); -end; - -procedure TControl.RESetParaAttr(const Index, Value: Integer); -var pDw: PDWORD; - Mask: Integer; -begin - REGetParaAttr( 0 ); - pDw := Pointer( Integer( @DF.fREParaFmtRec ) + ( HiWord( Index ) and $7E ) ); - Mask := 0; - if LongBool( HiWord( Index ) and 1 ) then - Mask := Integer( $FFFF0000 ); - pDw^ := pDw^ and Mask or DWORD(Value); - DF.fREParaFmtRec.dwMask := Index and $8000FFFF; - RESetParaFmt( {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec - {$ELSE} DF.fREParaFmtRec^ {$ENDIF} ); -end; - -procedure TControl.RESetTabCount(const Value: Integer); -begin - REGetParaAttr( 0 ); - RESetParaAttr( (27 shl 16) or PFM_TABSTOPS, Value ); -end; - -procedure TControl.RESetTabs(Idx: Integer; const Value: Integer); -begin - REGetParaAttr( 0 ); - RESetParaAttr( (28 + 4 * Idx) or PFM_TABSTOPS, Value ); -end; - -procedure TControl.RESetTextAlign(const Value: TRichTextAlign); -begin - RESetParaAttr( (25 shl 16) or PFM_ALIGNMENT, Ord( Value ) + 1 ); -end; - -function TControl.REGetStartIndentValid: Boolean; -begin - Result := REGetParaAttrValid( Integer( PFM_STARTINDENT ) ); -end; - -procedure TControl.RE_HideSelection(aHide: Boolean); -begin - Perform( EM_HIDESELECTION, Integer( aHide ), 1 ); -end; - -function TControl.RE_SearchText(const Value: KOLString; MatchCase, - WholeWord, ScanForward: Boolean; SearchFrom, SearchTo: Integer): Integer; -var Flags: Integer; - FT: {$IFDEF UNICODE_CTRLS} TFindTextW {$ELSE} - {$IFDEF _D2} TFindText {$ELSE} TFindTextA {$ENDIF} {$ENDIF}; -begin - Flags := Integer( ScanForward ); -{$IFDEF _D2009orHigher} -{$WARN SYMBOL_DEPRECATED OFF} // check deprecate state -{$ENDIF} - if WholeWord then Flags := Flags or FT_WHOLEWORD; - if MatchCase then Flags := Flags or FT_MATCHCASE; -{$IFDEF _D2009orHigher} -{$WARN SYMBOL_DEPRECATED ON} -{$ENDIF} - FT.chrg.cpMin := SearchFrom; - FT.chrg.cpMax := SearchTo; - FT.lpstrText := PKOLChar( Value ); - Result := Perform( EM_FINDTEXT, Flags, Integer( @FT ) ); -end; - - {$IFNDEF _FPC} - {$IFNDEF _D2} //------- KOLWideString not supported in D2 -function TControl.RE_WSearchText(const Value: KOLWideString; MatchCase, - WholeWord, ScanForward: Boolean; SearchFrom, SearchTo: Integer): Integer; -var Flags: Integer; - FT: TFindTextW; -begin - Flags := Integer( ScanForward ); -{$IFDEF _D2009orHigher} -{$WARN SYMBOL_DEPRECATED OFF} // check deprecate state -{$ENDIF} - if WholeWord then Flags := Flags or FT_WHOLEWORD; - if MatchCase then Flags := Flags or FT_MATCHCASE; -{$IFDEF _D2009orHigher} -{$WARN SYMBOL_DEPRECATED ON} // switch on! -{$ENDIF} - FT.chrg.cpMin := SearchFrom; - FT.chrg.cpMax := SearchTo; - FT.lpstrText := PWideChar( Value ); - Result := Perform( WM_USER+123 {EM_FINDTEXTW}, Flags, Integer( @FT ) ); -end; - {$ENDIF}{$ENDIF} - -{$ENDIF NOT_USE_RICHEDIT} - -function TControl.CanUndo: Boolean; -begin - Result := LongBool( Perform( EM_CANUNDO, 0, 0 ) ); -end; - -procedure TControl.EmptyUndoBuffer; -begin - Perform( EM_EMPTYUNDOBUFFER, 0, 0 ); -end; - -function TControl.Undo: Boolean; -begin - Result := LongBool( Perform( EM_UNDO, 0, 0 ) ); -end; - -{$IFNDEF NOT_USE_RICHEDIT} -function TControl.RE_Redo: Boolean; -begin - Result := LongBool( Perform( EM_REDO, 0, 0 ) ); -end; - -function TControl.REGetAutoURLDetect: Boolean; -begin - Result := LongBool( Perform( EM_GETAUTOURLDETECT, 0, 0 ) ); -end; - -procedure TControl.RESetAutoURLDetect(const Value: Boolean); -begin - AttachProc( WndProc_RE_LinkNotify ); - Perform( EM_AUTOURLDETECT, Integer( Value ), 0 ); -end; - -procedure TControl.RESetZoom( const Value: TSmallPoint ); -begin - Perform( EM_SETZOOM, Value.x, Value.y ); -end; - -function TControl.REGetZoom: TSmallPoint; -var P: TPoint; -begin - Perform( EM_GETZOOM, Integer( @ P.X ), Integer( @ P.Y ) ); - Result := Point2SmallPoint( P ); -end; - -function TControl.GetMaxTextSize: DWORD; -begin - Result := Perform( EM_GETLIMITTEXT, 0, 0 ); -end; - -procedure TControl.SetMaxTextSize(const Value: DWORD); -var V1, V2: Integer; -begin - if fCommandActions.aSetLimit <> 0 then - begin - V1 := 0; V2 := Value; - if fCommandActions.aSetLimit = EM_SETLIMITTEXT then - begin - V1 := Value; V2 := 0; - end; - Perform( fCommandActions.aSetLimit, V1, V2 ); - end; -end; - -function WndProc_REFmt( _Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Mask: Integer; - Shft, Alt, Ctrl, Flg: Boolean; - Delta: Integer; - TA: TRichTextAlign; - ChgTA: Boolean; - US: TRichUnderline; - NS: TRichNumbering; - NB: TRichNumBrackets; - Side: TBorderEdge; - Param: DWORD; -begin - Result := False; - if Msg.message = WM_CHAR then - if _Self_.DF.FSupressTab then - begin - _Self_.DF.FSupressTab := FALSE; - if Msg.wParam = 9 then - begin - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - if (Msg.message = WM_KEYDOWN) or (Msg.message = WM_SYSKEYDOWN) then - begin - Ctrl := GetKeyState( VK_CONTROL ) < 0; - Alt := GetKeyState( VK_MENU ) < 0; - Param := Msg.wParam; - if Ctrl or - Alt and IntIn(Param, [ VK_ADD, VK_SUBTRACT, Integer( '-' ), Integer( '=' ), - Integer( '+' ), 189 , 187 ]) then - begin - Shft := GetKeyState( VK_SHIFT ) < 0; - Rslt := 0; - Result := True; - Mask := 0; - ChgTA := False; TA := raLeft; - case Param of - Integer('Z'): - begin - if Shft then - begin - _Self_.RE_Redo; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := False; - end; - - Integer('L'): begin ChgTA := True; TA := raLeft; end; - Integer('R'): begin ChgTA := True; TA := raRight; end; - Integer('E'): begin ChgTA := True; TA := raCenter; end; - Integer('J'): begin ChgTA := True; TA := raJustify; end; - Integer('N'): begin - if Shft then - begin - NS := _Self_.RE_NumStyle; - NB := _Self_.RE_NumBrackets; - if NS = rnBullets then - begin - _Self_.RE_NumStyle := rnNone; Exit; {>>>>>>>>>>>>>>>>>>} - end; - if NS = rnNone then - begin - _Self_.RE_NumStyle := rnBullets; Exit; {>>>>>>>>>>>>>>>} - end - else - if Ord( NB ) = 0 then - NB := High(NB) else - NB := Pred(NB); - _Self_.RE_NumBrackets := NB; - end - else - begin - NS := _Self_.RE_NumStyle; - if Ord( NS ) = 0 then - begin - NS := rnURoman; //rnULetter; //High( NS ); - { because rnLRoman, rnURoman, rnNoNumber are not shown - in RichEdit. } - _Self_.RE_NumBrackets := rnbPeriod; - end else - NS := Pred(NS); - _Self_.RE_NumStyle := NS; - if NS in [ rnLRoman, rnURoman, rnArabic ] then - _Self_.RE_NumStart := 1; - end; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Integer('W'): begin - Delta := _Self_.RE_BorderWidth[ beLeft ] + 4; - if Shft then Delta := -1; - for Side := Low(Side) to High(Side) do - begin - if Delta < 0 then - _Self_.RE_BorderStyle[ Side ] := _Self_.RE_BorderStyle[ Side ] + 1 - else - begin - _Self_.RE_BorderWidth[ Side ] := Delta; - _Self_.RE_BorderSpace[ Side ] := Delta; - end; - end; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - (* TABLES STUFF -- to try, uncomment it and press CTRL+T in RichEdit. - (and uncomment declaration for Tmp above). - - Not finished, and seems no way to figure it out - even RichEdit20.dll - (i.e. Rich Edit v3.0) can not display tables properly formatted. :((( - - Integer('T'): begin - if _Self_.RE_Table then - begin - //MsgOK( 'table' ); - end; - Tmp := _Self_.REReadText( reRTF, True ); - if StrIsStartingFrom( PAnsiChar(Tmp), '{\rtf' ) - and (CopyTail( Tmp, 3 ) = '}'#$D#$A) then - begin - //Tmp := Copy( Tmp, 1, Length(Tmp) - 3 ); - _Self_.RE_Text[ reRTF, True ] := '{\rtf1' + //Copy( Tmp, 1, 6 ) + - '\trowd' + - //'\lytcalctblwd' + - //'\oldlinewrap' + - //'\alntblind' + - //'\trgaph108' + - '\trleft-108' + - {'\trbrdrt\brdrs\brdrw10' + - '\trbrdrl\brdrs\brdrw10' + - '\trbrdrb\brdrs\brdrw10' + - '\trbrdrr\brdrs\brdrw10' + - '\trbrdrh\brdrs\brdrw10' + - '\trbrdrv\brdrs\brdrw10' +} - //'\clvertalt' + - {'\clbrdrt\brdrs\brdrw10' + - '\clbrdrl\brdrs\brdrw10' + - '\clbrdrb\brdrs\brdrw10' + - '\clbrdrr\brdrs\brdrw10' +} - //'\cltxlrtb' + - '\cellx1414' + - //'\pard' + - //'\plain' + - //'\widctlpar' + - '\trautofit1' + - '\intbl' + - //'\adjustright' + - //'\fs20\lang1049' + - //'\cgrid' + - '\trrh0' + - '{\clFitText{{\box\brdrs\brdrw20\brsp20}'+ - '\par}\cell\row}' + - //'\pard\widctlpar' + - //'\intbl'+ - //'\adjustright'+ - //'{\row}' + - '\pard\widctlpar' + - '}'#$D#$A; - _Self_.Perform( WM_KEYDOWN, VK_UP, 0 ); - _Self_.Perform( WM_KEYUP, VK_UP, 0 ); - end; Exit; - end; - *) - Integer('B'): Mask := CFM_BOLD; - Integer('I'): - begin - Mask := CFM_ITALIC; - _Self_.DF.FSupressTab := TRUE; - end; - Integer('U'): - begin - if Shft then - begin - US := _Self_.RE_FmtUnderlineStyle; - if Ord(US) = 0 then US := High(TRichUnderLine) - else US := Pred( US ); - _Self_.RE_FmtUnderlineStyle := US; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Mask := CFM_UNDERLINE; - end; - Integer('O'): Mask := CFM_STRIKEOUT; - VK_SUBTRACT, VK_ADD, Integer( '+' ), 187, Integer( '-' ), 189: - ; - else - begin - Result := False; - Msg.wParam := Param; - end; - end; - if not Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if ChgTA then - begin - if Shft then Result := False - else _Self_.RE_TextAlign := TA; - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - _Self_.REGetFont; - if Mask > 0 then - begin - if Shft then Result := False - else begin - Flg := _Self_.REGetFontEffects( Mask ); - if not Flg then - _Self_.DF.fRECharFormatRec.dwEffects := _Self_.DF.fRECharFormatRec.dwEffects and not Mask; - _Self_.DF.fRECharFormatRec.dwEffects := _Self_.DF.fRECharFormatRec.dwEffects xor DWORD(Mask); - end; - end - else - if IntIn( Param, [ VK_ADD, VK_SUBTRACT, Integer( '+' ), - Integer( '-' ), 189, 187 ] ) then - begin - if (Param = VK_SUBTRACT) or (Param = DWORD( '-' )) or (Param = 189) then - Delta := -1 - else - Delta := 1; - if Alt and Ctrl then - begin - Mask := Integer( CFM_SIZE ) or Integer( CFM_OFFSET ); - Delta := 0; - _Self_.DF.fRECharFormatRec.yOffset := 0; - _Self_.DF.fRECharFormatRec.yHeight := 200; - end - else - if Alt then Mask := Integer( CFM_SIZE ) - else Mask := Integer( CFM_OFFSET ); - Inc( _Self_.DF.fRECharFormatRec.yOffset, Delta * _Self_.DF.fRECharFormatRec.yHeight div 3 ); - Inc( _Self_.DF.fRECharFormatRec.yHeight, Delta * _Self_.DF.fRECharFormatRec.yHeight div 8 ); - Flg := LongBool( _Self_.DF.fRECharFormatRec.dwMask and Mask ); - if not Flg then - _Self_.DF.fRECharFormatRec.yOffset := 0; - end; - _Self_.DF.fRECharFormatRec.dwMask := Mask; - if _Self_.SelLength = 0 then - _Self_.SelLength := 1; - _Self_.Perform( EM_SETCHARFORMAT, SCF_SELECTION { RichAreas[ _Self_.fRECharArea ] }, - Integer( {$IFDEF STATIC_RICHEDIT_DATA} @_Self_.DF.fRECharFormatRec - {$ELSE} _Self_.DF.fRECharFormatRec {$ENDIF} ) ); - end; - end; -end; - -function TControl.RE_FmtStandard: PControl; -begin - AttachProc( WndProc_REFmt ); - Result := @Self; -end; - -procedure TControl.RE_CancelFmtStandard; -begin - DetachProc( WndProc_REFmt ); -end; -{$ENDIF NOT_USE_RICHEDIT} - -{$IFDEF ASM_TLIST} -function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -asm //cmd //opd - CMP [EAX].TControl.fRefCount, 0 - JL @@fin_false - PUSHAD - MOV EBX, EAX - MOV EBP, ECX - MOV ECX, [EBX].TControl.fDynHandlers - JECXZ @@ret_false - MOV ESI, ECX - MOV ECX, [ESI].TList.fCount - JECXZ @@ret_false - MOV EDI, ECX - SHR EDI, 1 - CALL TControl.RefInc -@@loo: DEC EDI - JS @@e_loo - PUSH EDX - PUSH EBX -{$IFNDEF SMALLEST_CODE} -{$IFNDEF ENUM_DYN_HANDLERS_AFTER_RUN} - XOR EAX, EAX - CMP [AppletTerminated], AL - JZ @@do_call - MOV ECX, [ESI].TList.fItems - MOV ECX, [ECX+EDI*8+4] - JECXZ @@skip_call -{$ENDIF} -{$ENDIF} -@@do_call: - MOV EAX, [ESI].TList.fItems - MOV EAX, [EAX+EDI*8] - XCHG EAX, EBX - MOV ECX, EBP - CALL EBX -@@skip_call: - POP EBX - POP EDX - TEST AL, AL - JZ @@loo -@@ret_true: - MOV EAX, EBX - CALL TControl.RefDec - POPAD - MOV AL, 1 - RET -@@e_loo: - XOR EAX, EAX - INC EAX - CMP [EBX].TControl.fRefCount, EAX - JE @@ret_true - MOV EAX, EBX - CALL TControl.RefDec -@@ret_false: - POPAD -@@fin_false: - XOR EAX, EAX -end; -{$ELSE PAS_VERSION} //Pascal -function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var I: Integer; - Proc: TWindowFunc; -begin - Result := False; - if Self_.fRefCount < 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (Self_.fDynHandlers = nil) or (Self_.fDynHandlers.fCount = 0) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Self_.RefInc; // Prevent destroying Self_ - for I := Self_.fDynHandlers.fCount div 2 - 1 downto 0 do - begin - Proc := Self_.fDynHandlers.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I * 2 ]; -{$IFNDEF SMALLEST_CODE} -{$IFNDEF ENUM_DYN_HANDLERS_AFTER_RUN} - if not AppletTerminated or ( - Self_.fDynHandlers.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF} - [ I * 2 + 1 ] <> nil) then -{$ENDIF} -{$ENDIF} - if Proc( Self_, Msg, Rslt ) then - begin - Result := True; - break; - end; - end; - {$IFDEF DEBUG_ENDSESSION} - if EndSession_Initiated then - begin - LogFileOutput( GetStartDir + 'es_debug.txt', - 'ENUM_DYN_HANDLERS: Self_:' + Int2Hex( DWORD( Self_ ), 8 ) ); - LogFileOutput( GetStartDir + 'es_debug.txt', - 'ENUM_DYN_HANDLERS: Self_.fRefCount:' + Int2Str( Self_.fRefCount ) ); - end; - {$ENDIF} - if LongBool(Self_.fRefCount and 1) then - Result := True; // If Self_ will be destroyed now, stop further processing - Self_.RefDec; // Destroy Self_, if Free was called for it while processing attached procedures -end; -{$ENDIF PAS_VERSION} - -procedure TransparentAttachProcExtension ( DynHandlers: PList ); -var i: integer; -begin - I := DynHandlers.IndexOf( @WndProcTransparent ); - if I >=0 then begin - DynHandlers.Delete( I ); - DynHandlers.Delete( I ); - DynHandlers.Add( @WndProcTransparent ); - DynHandlers.Add( nil ); - end; -end; - -procedure DummyAttachProcExtension ( DynHandlers: PList ); -begin -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -procedure TControl.AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean ); -begin - //if fDynHandlers = nil then - // fDynHandlers := NewList; - if not IsProcAttached( Proc ) then - begin - fDynHandlers.Add( @Proc ); - fDynHandlers.Add( Pointer( Integer( ExecuteAfterAppletTerminated ) ) ); - end; - {$IFNDEF SMALLEST_CODE} - Global_AttachProcExtension(fDynHandlers); - {$ENDIF} - PP.fOnDynHandlers := EnumDynHandlers; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.AttachProc(Proc: TWindowFunc); -begin - AttachProcEx( Proc, FALSE ); -end; - -procedure TControl.DetachProc(Proc: TWindowFunc); -var I: Integer; -begin - if fDynHandlers = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - I := fDynHandlers.IndexOf( @Proc ); - if I >=0 then - begin - fDynHandlers.Delete( I ); - fDynHandlers.Delete( I ); - end; -end; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal -function TControl.IsProcAttached(Proc: TWindowFunc): Boolean; -var I: Integer; -begin - I := fDynHandlers.IndexOf( @Proc ); - Result := I >=0; -end; -{$ENDIF PAS_VERSION} - -{$IFDEF nASM_VERSION}{$ELSE PAS_VERSION} -function WndProcAutoPopupMenu( Control: PControl; var Msg: TMsg; var MsgRslt: Integer ): Boolean; -var {$IFNDEF SMALLEST_CODE} - R: TRect; - M: Word; - I: Integer; - {$ENDIF SMALLEST_CODE} - P: TPoint; -begin - if (Msg.message = WM_CONTEXTMENU) and - (Control.fAutoPopupMenu <> nil) then - begin - {$IFDEF USE_MENU_CURCTL} - PMenu( Control.fAutoPopupMenu ).fCurCtl := Control; - {$ENDIF USE_MENU_CURCTL} - P.X := SmallInt( LoWord( Msg.lParam ) ); - P.Y := SmallInt( HiWord( Msg.lParam ) ); - {$IFNDEF SMALLEST_CODE} - if (Msg.lParam = -1) then - begin - I := Control.CurIndex; - M := Control.fCommandActions.aItem2XY; - if (I >= 0) and (M <> 0) then - begin - CASE M OF - EM_POSFROMCHAR: - begin - I := Control.SelStart + Control.SelLength; - // Edit or Rich Edit 2: - I := Control.Perform( M, I, 1 ); - P.X := SmallInt( LoWord( I ) ); - P.Y := SmallInt( HiWord( I ) ); - end; - LB_GETITEMRECT, LVM_GETITEMRECT, TCM_GETITEMRECT: - begin - R.Left := LVIR_BOUNDS; - Control.Perform( M, I, Integer( @ R ) ); - P.X := R.Left; - P.Y := R.Bottom; - end; - TVM_GETITEMRECT: - begin - I := Control.TVSelected; - R.Left := I; - Control.Perform( M, 1, Integer( @ R ) ); - P.X := R.Left; - P.Y := R.Bottom; - end; - END; - R := Control.ClientRect; - if P.X < R.Left then P.X := R.Left; - if P.X > R.Right then P.X := R.Right; - if P.Y < R.Top then P.Y := R.Top; - if P.Y > R.Bottom then P.Y := R.Bottom; - end; - P := Control.Client2Screen( P ); - end; - {$ENDIF SMALLEST_CODE} - PMenu( Control.fAutoPopupMenu ).Popup( P.X, P.Y ); - Result := TRUE; - end - else - Result := FALSE; -end; -{$ENDIF PAS_VERSION} - -procedure TControl.SetAutoPopupMenu(PopupMenu: PObj); -{ new version - by Alexander Pravdin. Allows to attach a submenu (e.g. of the - main menu) as a popup menu to a control, to avoid duplicating menu object, - if it is the same already as desired. } -var pm: PMenu; -begin - if PopupMenu <> nil then - {$IFDEF USE_MENU_CURCTL} - begin - pm := PMenu( PopupMenu ); - if ( pm.FParentMenu <> nil ) then - begin - while pm.FControl = nil do - pm := pm.FParentMenu; - PMenu( PopupMenu ).FControl := pm.FControl; - end - else - begin - PMenu( PopupMenu ).FControl := @Self; - end; - AttachProc(WndProcAutoPopupMenu); - AttachProc(WndProcMenu) - end - else begin - DetachProc(WndProcAutoPopupMenu); - DetachProc(WndProcMenu); - end; - {$ELSE} - begin - pm := PMenu( PopupMenu ); - while pm.FControl = nil do pm := pm.Parent; - PMenu( PopupMenu ).FControl := pm.FControl; - end; - {$ENDIF} - fAutoPopupMenu := PopupMenu; - {$IFNDEF USE_MENU_CURCTL} - AttachProc( WndProcAutoPopupMenu ); - {$ENDIF} -end; - -function SearchAnsiMnemonics( const S: KOLString ): KOLString; -var I: Integer; - Sh: ShortInt; -begin - Result := S; - for I := 1 to Length( Result ) do - begin - Sh := VkKeyScanEx( Result[ I ], MnemonicsLocale ); - if Sh <> -1 then - Result[ I ] := KOLChar( Sh ); - end; -end; - -procedure SupportAnsiMnemonics( LocaleID: Integer ); -begin - MnemonicsLocale := LocaleID; - SearchMnemonics := SearchAnsiMnemonics; -end; - -function WndProcMnemonics( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Form: PControl; - - function HandleMnemonic( Prnt: PControl ): Boolean; - var C: PControl; - XY: Integer; - procedure DoPressMnemonic; - begin - if Msg.message = WM_SYSKEYDOWN then - begin - //Form.DF.fPressedMnemonic := Msg.wParam; - C.Perform( WM_LBUTTONDOWN, MK_LBUTTON, XY ); - end - else - begin - //Form.DF.fPressedMnemonic := 0; - C.Perform( WM_LBUTTONUP, MK_LBUTTON, XY ); - end; - end; - var I, J: Integer; - R: TRect; - begin - for I := 0 to Prnt.ChildCount-1 do - begin - C := Prnt.Children[ I ]; - if {$IFDEF USE_FLAGS} G5_IsButton in C.fFlagsG5 - {$ELSE} C.IsButton {$ENDIF} then - if C.Enabled then - begin - if C.fCommandActions.aGetCount = TB_BUTTONCOUNT then - for J := 0 to C.Count-1 do - begin - if C.TBButtonEnabled[ J ] then - if pos( KOLString('&') + AnsiChar( Msg.wParam ), SearchMnemonics( C.TBButtonText[ J ] ) ) > 0 then - begin - C.fCurIndex := J; - C.DF.fTBCurItem := C.TBIndex2Item( J ); - R := C.TBButtonRect[ J ]; - XY := R.Left or (R.Top shl 16); - DoPressMnemonic; - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - if pos( KOLString('&') + AnsiChar( Msg.wParam ), SearchMnemonics( C.Caption ) ) > 0 then - begin - XY := 0; - DoPressMnemonic; - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - if HandleMnemonic( C ) then - begin - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := FALSE; - end; - -{$IFDEF NEW_MENU_ACCELL} - function FindByCtlRef(C: PControl; Accell: TMenuAccelerator): Boolean; - - function FindInMenu(M: PMenu): PMenu; - var - I: Integer; - SM: PMenu; - begin - for I := 0 to M.FMenuItems.Count - 1 do begin - Result := M.FMenuItems.Items[I]; - if (Cardinal(Result.Accelerator) = Cardinal(Accell)) and Result.Enabled then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := nil; - for I := 0 to M.FMenuItems.Count - 1 do begin - SM := PMenu(M.FMenuItems.Items[I]); - if (SM.FMenuItems.Count > 0) then - Result := FindInMenu(SM); - if (Result <> nil) then - Break; - end; - end; - - function FindInMenu2(M: PMenu): Boolean; - var - MI: PMenu; - begin - if (M <> nil) then begin - MI := FindInMenu(M); - if (MI <> nil) then begin - //M.FControl.Perform(WM_COMMAND, MI.FId, 0); - C.Perform(WM_COMMAND, MI.FId, 0); // fixed - Result := True; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := False; - end; - - var - Parent: PControl; - begin - Result := False; - if not FindInMenu2(PMenu(C.fAutoPopupMenu)) then - if not FindInMenu2(PMenu(C.fMenuObj)) then begin - Parent := C.Parent; - if (Parent <> nil) then - Result := FindByCtlRef(Parent, Accell); - end; - end; - -var - Ac: TMenuAccelerator; -{$ENDIF} -begin - Result := FALSE; - if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then - begin -{$IFDEF NEW_MENU_ACCELL} - Ac := MakeAccelerator(FVIRTKEY or GetShiftState, Msg.wParam); - Result := FindByCtlRef(Sender, Ac); -{$ELSE} - if (Sender.fAccelTable <> 0) - {$IFDEF KEY_PREVIEW} - and (Sender.DF.fKeyPreviewCount = 0) - {$ENDIF} - then - Result := LongBool( TranslateAccelerator( Sender.fHandle, Sender.fAccelTable, Msg ) ); - if not Result then - begin - if Sender.DF.fCurrentControl <> nil then - if Sender.DF.fCurrentControl.fAccelTable <> 0 then - Result := LongBool( TranslateAccelerator( Sender.DF.fCurrentControl.fHandle, - Sender.DF.fCurrentControl.fAccelTable, Msg ) ); - end; - if not Result then - begin - Form := Sender.ParentForm; - if (Form <> nil) and (Form <> Sender) - {$IFDEF KEY_PREVIEW} - and (Form.DF.fKeyPreviewCount = 0) - {$ENDIF KEY_PREVIEW} - then - if Form.fAccelTable <> 0 then - Result := LongBool( TranslateAccelerator( Form.fHandle, - Form.fAccelTable, Msg ) ); - end; -{$ENDIF} - end; - if Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (Msg.message = WM_SYSKEYUP) or - (Msg.message = WM_SYSKEYDOWN) and (GetKeyState( VK_MENU ) < 0) then - begin - Rslt := 0; - Form := Sender.ParentForm; - if Form <> nil then - begin - if AnsiChar( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then - begin - if HandleMnemonic( Form ) then - begin - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; - end else - if Msg.message = WM_KEYUP then - begin - Rslt := 0; - Form := Sender.ParentForm; - if Form <> nil then - begin - if Msg.wParam = VK_MENU then - // if Form.DF.fPressedMnemonic <> 0 then - // Form.DF.fPressedMnemonic := Form.DF.fPressedMnemonic or $80000000; - else if AnsiChar( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then - begin - if HandleMnemonic( Form ) then - begin - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - end; - end; - Result := FALSE; -end; - -function TControl.SupportMnemonics: PControl; -begin - fGlobalProcKeybd := WndProcMnemonics; - Result := @Self; -end; - -procedure TControl.SelectAll; -begin - SelStart := 0; - SelLength := -1; // this can be not working for some controls... //*//* -end; - -{$IFnDEF NOT_USE_RICHEDIT} -function RevokeDragDrop(wnd: HWnd): HResult; stdcall; - external 'ole32.dll' name 'RevokeDragDrop'; - -function TControl.RE_NoOLEDragDrop: PControl; -begin - RevokeDragDrop( Handle ); - Result := @Self; -end; -{$ENDIF NOT_USE_RICHEDIT} - -function WndProcOnResize( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - if Msg.message = WM_SIZE then - begin - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnResize ) then - {$ENDIF} - Self_.EV.fOnResize( Self_ ); - end; - Result := False; -end; - -procedure TControl.SetOnResize(const Value: TOnEvent); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .FOnResize := Value; - AttachProc( WndProcOnResize ); -end; - -function WndProcMove( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - if Msg.message = WM_MOVE then - begin - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.FOnMove ) then - {$ENDIF} - Self_.EV.FOnMove( Self_ ); - end; - Result := False; -end; - -procedure TControl.SetOnMove(const Value: TOnEvent); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .FOnMove := Value; - AttachProc( WndProcMove ); -end; - -function WndProcMoving( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := False; - if Msg.message = WM_MOVING then - begin - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.FOnMoving ) then - {$ENDIF} - Self_.EV.FOnMoving( Self_, Pointer( Msg.lParam ) ); - Rslt := 1; - Result := TRUE; - end; -end; - -procedure TControl.SetOnMoving(const Value: TOnEventMoving); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .FOnMoving := Value; - AttachProc( WndProcMoving ); -end; - -{$IFNDEF NOT_USE_RICHEDIT} -function WndProc_REBottomless( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - if Msg.message = WM_SIZE then - Self_.Perform( EM_REQUESTRESIZE, 0, 0 ); - Result := False; -end; - -function TControl.RE_Bottomless: PControl; -begin - AttachProc( WndProc_REBottomless ); - Result := @Self; -end; - -procedure TControl.RE_Append(const S: KOLString; ACanUndo: Boolean); -begin - SelStart := TextSize; - if S <> '' then - begin - ReplaceSelection( S, ACanUndo ); - SelStart := TextSize; - end; -end; - -procedure TControl.RE_InsertRTF(const S: KOLString); -var MS: PStream; -begin - MS := NewMemoryStream; - MS.Size := (Length( S ) + 1) * Sizeof(KOLChar); - Move( S[ 1 ], MS.Memory^, ( Length( S ) + 1 ) * Sizeof( KOLChar ) ); - RE_LoadFromStream( MS, Length( S ), reRTF, TRUE ); - MS.Free; -end; -{$ENDIF NOT_USE_RICHEDIT} - -procedure TControl.DoSelChange; -begin - {$IFDEF NIL_EVENTS} - if Assigned( EV.fOnSelChange ) then - {$ELSE} - if TMethod( EV.fOnSelChange ).Code <> @DummyObjProc then - {$ENDIF} - EV.fOnSelChange( @Self ) - else - {$IFDEF NIL_EVENTS} - if Assigned( EV.fOnChangeCtl ) then - {$ENDIF} - EV.fOnChangeCtl( @Self ); -end; - -{$IFNDEF NOT_USE_RICHEDIT} -function TControl.REGetUnderlineEx: TRichUnderline; -begin - Result := TRichUnderline( REGetFontAttr( ((81 - {$IFDEF UNICODE_CTRLS} + 32 {$ENDIF}) - shl 16) or CFM_UNDERLINETYPE ) - 1 ); -end; - -procedure TControl.RESetUnderlineEx(const Value: TRichUnderline); -begin - RESetFontAttr( ((81 - {$IFDEF UNICODE_CTRLS} + 32 {$ENDIF}) - shl 16) or CFM_UNDERLINETYPE, Ord( Value ) + 1 ); - RESetFontEffect( CFM_UNDERLINE, True ); -end; - -function TControl.GetTextSize: Integer; -begin - Result := 0; - if fHandle <> 0 then - Result := GetWindowTextLength( fHandle ); -end; - -function TControl.REGetTextSize(Units: TRichTextSize): Integer; -const TextLengthFlags: array[ TRichTextSizes ] of Integer = - ( not GTL_UseCRLF, not GTL_Precise, GTL_Close, GTL_NUMBytes ); -var GTL: TGetTextLengthEx; -begin - GTL.flags := MakeFlags( @Units, TextLengthFlags ); - if not(rtsBytes in Units) then - GTL.flags := GTL.flags or GTL_NUMCHARS; - GTL.codepage := CP_ACP; - Result := Perform( EM_GETTEXTLENGTHEX, Integer( @GTL ), 0 ); -end; - -function TControl.RE_TextSizePrecise: Integer; -var gtlex : TGetTextLengthEx; -begin - gtlex.flags := GTL_PRECISE; - gtlex.codepage := CP_ACP; - Result := Perform(EM_GETTEXTLENGTHEX,WPARAM(@gtlex), 0 ); -end; - -function TControl.REGetNumStyle: TRichNumbering; -begin - Result := TRichNumbering( ReGetParaAttr( 9 shl 16 ) ); -end; - -procedure TControl.RESetNumStyle(const Value: TRichNumbering); -begin - RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Ord( Value ) ); -end; - -function TControl.REGetNumBrackets: TRichNumBrackets; -begin - REGetParaAttr( 0 ); - Result := TRichNumBrackets( (DF.fREParaFmtRec.wNumberingStyle shr 8) ); -end; - -procedure TControl.RESetNumBrackets(const Value: TRichNumBrackets); -begin - REGetParaAttr( 0 ); - DF.fREParaFmtRec.wNumberingStyle := DF.fREParaFmtRec.wNumberingStyle and $F8FF - or Word( Ord( Value ) shl 8 ); - DF.fREParaFmtRec.dwMask := PFM_NUMBERINGSTYLE; - RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec - {$ELSE} DF.fREParaFmtRec^ {$ENDIF}; -end; - -function TControl.REGetNumTab: Integer; -begin - REGetParaAttr( 0 ); - Result := DF.fREParaFmtRec.wNumberingTab; -end; - -procedure TControl.RESetNumTab(const Value: Integer); -begin - REGetParaAttr( 0 ); - DF.fREParaFmtRec.wNumberingTab := Value; - DF.fREParaFmtRec.dwMask := PFM_NUMBERINGTAB; - RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec - {$ELSE} DF.fREParaFmtRec^ {$ENDIF}; -end; - -function TControl.REGetNumStart: Integer; -begin - REGetParaAttr( 0 ); - Result := DF.fREParaFmtRec.wNumberingStart; -end; - -procedure TControl.RESetNumStart(const Value: Integer); -begin - REGetParaAttr( 0 ); - DF.fREParaFmtRec.wNumberingStart := Value; - DF.fREParaFmtRec.dwMask := PFM_NUMBERINGSTART; - RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec - {$ELSE} DF.fREParaFmtRec^ {$ENDIF}; -end; - -function TControl.REGetSpacing( const Index: Integer ): Integer; -begin - REGetParaAttr( 0 ); - Result := PInteger( Integer(@DF.fREParaFmtRec.dySpaceBefore) + (Index and $F) )^; -end; - -procedure TControl.RESetSpacing(const Index, Value: Integer); -begin - REGetParaAttr( 0 ); - PInteger( Integer(@DF.fREParaFmtRec.dySpaceBefore) + (Index and $F) )^ := Value; - DF.fREParaFmtRec.dwMask := Index and not $F; - RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec - {$ELSE} DF.fREParaFmtRec^ {$ENDIF}; -end; - -function TControl.REGetSpacingRule: Integer; -begin - REGetParaAttr( 0 ); - Result := DF.fREParaFmtRec.bLineSpacingRule; -end; - -procedure TControl.RESetSpacingRule(const Value: Integer); -begin - REGetParaAttr( 0 ); - DF.fREParaFmtRec.bLineSpacingRule := Value; - DF.fREParaFmtRec.dwMask := PFM_LINESPACING; - RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec - {$ELSE} DF.fREParaFmtRec^ {$ENDIF}; -end; - -function TControl.REGetLevel: Integer; -begin - REGetParaAttr( 0 ); - Result := DF.fREParaFmtRec.bCRC; -end; - -function TControl.REGetBorder(Side: TBorderEdge; const Index: Integer): Integer; -begin - REGetParaAttr( 0 ); - Result := PWORD( Integer(@DF.fREParaFmtRec.wBorderSpace) + Index )^ shr (Ord(Side) * 4); -end; - -procedure TControl.RESetBorder(Side: TBorderEdge; const Index: Integer; - const Value: Integer); -var Mask: Word; - pW : PWord; -begin - REGetParaAttr( 0 ); - pw := PWORD( Integer(@DF.fREParaFmtRec.wBorderSpace) + Index ); - Mask := $F shl (Ord(Side) * 4); - pw^ := pw^ and not Mask or (Value shl (4 * Ord(Side)) ); - DF.fREParaFmtRec.dwMask := PFM_BORDER; - RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec - {$ELSE} DF.fREParaFmtRec^ {$ENDIF}; -end; - -function TControl.REGetParaEffect(const Index: Integer): Boolean; -begin - Result := LongBool( HiWord( REGetParaAttr( 8 shl 16 ) ) and Index ); -end; - -procedure TControl.RESetParaEffect(const Index: Integer; - const Value: Boolean); -var Idx: Integer; -begin - REGetParaAttr( 0 ); - DF.fREParaFmtRec.wReserved := Index; - Idx := Index; - DF.fREParaFmtRec.dwMask := Idx shl 16; - RE_ParaFmt := {$IFDEF STATIC_RICHEDIT_DATA} DF.fREParaFmtRec - {$ELSE} DF.fREParaFmtRec^ {$ENDIF}; -end; - -function WndProc_REMonitorIns( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := False; - if (Msg.message = WM_KEYDOWN) and (Msg.wParam = VK_INSERT) and - ((GetKeyState(VK_CONTROL) or GetKeyState(VK_SHIFT) or GetKeyState(VK_MENU)) >= 0) then - begin - if not Self_.DF.fReOvrDisable then - Self_.DF.fREOvr := not Self_.DF.fREOvr - else - Result := True; - {$IFDEF NIL_EVENTS} - if assigned( Self_.EV.fOnREInsModeChg ) then - {$ENDIF} - Self_.EV.fOnREInsModeChg( Self_ ); - end; -end; - -function TControl.REGetOverwite: Boolean; -begin - AttachProc( WndProc_REMonitorIns ); - Result := DF.fREOvr; -end; - -procedure TControl.RESetOverwrite(const Value: Boolean); -begin - if REGetOverwite = Value then // do not replace with fREOvr here! - Exit; // this installs monitor WndProc_REMonitorIns. {>>>>>>>>>>>>>>>>>>>>>} - Perform( WM_KEYDOWN, VK_INSERT, 0 ); - Perform( WM_KEYUP, VK_INSERT, 0 ); -end; - -procedure TControl.RESetOvrDisable(const Value: Boolean); -begin - REGetOverwite; - DF.fReOvrDisable := Value; -end; - -function WndProc_RichEdTransp_ParentPaint( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var I: Integer; - C: PControl; -begin - if (Msg.message = WM_PAINT) and (Msg.wParam = 0) then - begin - for I := 0 to Self_.fChildren.fCount - 1 do - begin - C := Self_.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ I ]; - if {$IFDEF USE_FLAGS} G5_IsCommonCtl in C.fFlagsG5 - {$ELSE} C.fIsCommonControl {$ENDIF} then - begin - Inc( C.DF.fREUpdCount ); - PostMessage( C.fHandle, CM_NCUPDATE, C.DF.fREUpdCount, WM_PAINT ); - InvalidateRect( C.fHandle, nil, False ); - end; - end; - end; - Result := False; -end; - -function WndProc_RichEdTransp_Update( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Rgn, Rgn1: HRgn; - R, CR: TRect; - Pt: TPoint; - VW, HH, VH, HW: Integer; -begin - if Self_.DF.fRETransparent then - case Msg.message of - WM_CHAR, WM_KILLFOCUS, WM_SETFOCUS, WM_KEYDOWN, WM_LBUTTONDOWN: - begin - PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 ); - end; - WM_PAINT: - if Msg.wParam = 0 then - begin - Inc( Self_.DF.fREUpdCount ); - PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.DF.fREUpdCount, Msg.message ); - end; - WM_SIZE: - begin - Inc( Self_.DF.fREUpdCount ); - PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.DF.fREUpdCount, Msg.message ); - PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 ); - end; - WM_ERASEBKGND: - if Msg.wParam = 0 then - begin - Inc( Self_.DF.fREUpdCount ); - PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.DF.fREUpdCount, Msg.message ); - end; - WM_HSCROLL, WM_VSCROLL: - begin - Self_.DF.fREScrolling := LoWord( Msg.wParam ) <> SB_ENDSCROLL; - Inc( Self_.DF.fREUpdCount ); - PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.DF.fREUpdCount, Msg.message ); - if Self_.DF.fREScrolling then - Self_.Invalidate; - end; - CM_INVALIDATE: - begin - Self_.Parent.Invalidate; - Self_.Invalidate; - end; - CM_NCUPDATE: - if DWORD(Msg.wParam) = DWORD(Self_.DF.fREUpdCount) then - begin - GetWindowRect( Self_.fHandle, R ); - Windows.GetClientRect( Self_.fHandle, CR ); - Pt.x := 0; Pt.y := 0; - Pt := Self_.Client2Screen( Pt ); - OffsetRect( CR, Pt.x, Pt.y ); - Rgn := CreateRectRgn( R.Left, R.Top, R.Right, R.Bottom ); - if Self_.DF.fREScrolling then - begin - VW := GetSystemMetrics( SM_CXVSCROLL ); - HH := GetSystemMetrics( SM_CYHSCROLL ); - VH := GetSystemMetrics( SM_CYVSCROLL ); - HW := GetSystemMetrics( SM_CXHSCROLL ); - if CR.Right + VW <= R.Right then - begin - Rgn1 := CreateRectRgn( CR.Right, CR.Top + VH, CR.Right + VW, CR.Bottom - VH ); - CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF ); - DeleteObject( Rgn1 ); - end; - if CR.Bottom + HH <= R.Bottom then - begin - Rgn1 := CreateRectRgn( CR.Left + HW, CR.Bottom, CR.Right - HW, CR.Bottom + HH ); - CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF ); - DeleteObject( Rgn1 ); - end; - end; - Self_.Perform( WM_NCPAINT, Rgn, 0 ); - DeleteObject( Rgn ); // Unremarked By M.Gerasimov - end; - end; - Result := False; -end; - -function TControl.REGetTransparent: Boolean; -begin - Result := Longbool(ExStyle and WS_EX_TRANSPARENT); -end; - -procedure TControl.RESetTransparent(const Value: Boolean); -begin - if Value then - ExStyle := ExStyle or WS_EX_TRANSPARENT - else - ExStyle := ExStyle and not WS_EX_TRANSPARENT; - DF.fRETransparent := Value; - fParent.AttachProc( WndProc_RichEdTransp_ParentPaint ); - AttachProc( WndProc_RichEdTransp_Update ); - {$IFDEF USE_FLAGS} - if Value then - include( fFlagsG2, G2_Transparent ) - else exclude( fFlagsG2, G2_Transparent ); - {$ELSE} fTransparent := Value; {$ENDIF} -end; - -procedure TControl.RESetOnURL(const Index: Integer; const Value: TOnEvent); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents; {$ENDIF} - if Index = 0 then - EV.fOnREOverURL := Value - else - EV.fOnREURLClick := Value; - RE_AutoURLDetect := - assigned(EV.fOnREOverURL) or assigned(EV.fOnREURLClick); -end; - -procedure TControl.SetOnRE_URLClick(const Value: TOnEvent); -begin - RESetOnURL( 1, Value ); -end; - -procedure TControl.SetOnRE_OverURL(const Value: TOnEvent); -begin - RESetOnURL( 0, Value ); -end; - -function TControl.REGetOnURL(const Index: Integer): TOnEvent; -begin - CASE Index OF - 0: Result := EV.fOnREOverURL; - else Result := EV.fOnREURLClick; - END; -end; - -function TControl.REGetLangOptions(const Index: Integer): Boolean; -begin - Result := LongBool( Perform( EM_GETLANGOPTIONS, 0, 0 ) and Index); -end; - -procedure TControl.RESetLangOptions(const Index: Integer; - const Value: Boolean); -var Mask: Integer; -begin - Mask := -1; - if not Value then Inc( Mask ); - Perform( EM_SETLANGOPTIONS, 0, Perform( EM_GETLANGOPTIONS, 0, 0 ) and - not Index or (Mask and Index) ); -end; -{$ENDIF NOT_USE_RICHEDIT} - -function DoTrackMouseEvent(lpEventTrack: PTrackMouseEvent): BOOL; -var FunTrack: function(lpEventTrack: PTrackMouseEvent): BOOL; stdcall; - ComCtlModule: THandle; -begin - Result := FALSE; - ComCtlModule := GetModuleHandle( cctrl ); - if ComCtlModule = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FunTrack := GetProcAddress( ComCtlModule, '_TrackMouseEvent' ); - if not Assigned( FunTrack ) then Exit; // is necessary for Win95! {>>>>>>>>>>} - Result := FunTrack( lpEventTrack ); -end; - -function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; - forward; -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var P: TPoint; - MouseWasInControl: Boolean; - Yes: Boolean; - Track: TTrackMouseEvent; -begin - case Msg.message of - WM_MOUSEFIRST..WM_MOUSELAST: - begin - MouseWasInControl := {$IFDEF USE_FLAGS} G3_MouseInCtl in Self_.fFlagsG3; - {$ELSE} Self_.fMouseInControl; {$ENDIF} - if Assigned( Self_.EV.fOnTestMouseOver ) then - Yes := Self_.EV.fOnTestMouseOver( Self_ ) - else - begin - GetCursorPos( P ); - P := Self_.Screen2Client( P ); - Yes := PointInRect( P, Self_.ClientRect ); - end; - if MouseWasInControl <> Yes then - begin - Self_.Invalidate; - if Yes then - begin - {$IFDEF USE_FLAGS} include( Self_.fFlagsG3, G3_MouseInCtl ); - {$ELSE} Self_.fMouseInControl := TRUE; {$ENDIF} - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseEnter ) then - {$ENDIF} - Self_.EV.fOnMouseEnter( Self_ ); - Track.cbSize := Sizeof( Track ); - Track.dwFlags := TME_LEAVE; - Track.hwndTrack := Self_.Handle; - DoTrackMouseEvent( @ Track ); - Self_.Invalidate; - end - else - begin - {$IFDEF USE_FLAGS} exclude( Self_.fFlagsG3, G3_MouseInCtl ); - {$ELSE} Self_.fMouseInControl := FALSE; {$ENDIF} - Track.cbSize := Sizeof( Track ); - Track.dwFlags := TME_LEAVE or TME_CANCEL; - Track.hwndTrack := Self_.Handle; - DoTrackMouseEvent( @ Track ); - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseLeave ) then - {$ENDIF} - Self_.EV.fOnMouseLeave( Self_ ); - Self_.Invalidate; - end; - end; - end; - WM_MOUSELEAVE: - begin - if {$IFDEF USE_FLAGS} G3_MouseInCtl in Self_.fFlagsG3 - {$ELSE} Self_.fMouseInControl {$ENDIF} then - begin - {$IFDEF USE_FLAGS} exclude( Self_.fFlagsG3, G3_MouseInCtl); - {$ELSE} Self_.fMouseInControl := FALSE; {$ENDIF} - {$IFDEF GRAPHCTL_HOTTRACK} - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fMouseLeaveProc ) then - {$ENDIF} - Self_.EV.fMouseLeaveProc( Self_ ); - {$ENDIF} - {$IFDEF NIL_EVENTS} - if Assigned( Self_.EV.fOnMouseLeave ) then - {$ENDIF} - Self_.EV.fOnMouseLeave( Self_ ); - Self_.Invalidate; - end; - end; - end; - Result := False; -end; -{$ENDIF PAS_VERSION} - -procedure ProvideMouseEnterLeave( Self_: PControl ); -begin - InitCommonControls; - Self_.AttachProc( WndProcMouseEnterLeave ); -end; - -procedure TControl.SetFlat(const Value: Boolean); -begin - {$IFDEF USE_FLAGS} - if Value then - include( fFlagsG3, G3_Flat ) - else exclude( fFlagsG3, G3_Flat ); - exclude( fFlagsG3, G3_MouseInCtl ); - {$ELSE} - fFlat := Value; - fMouseInControl := FALSE; - {$ENDIF} - ProvideMouseEnterLeave( @Self ); - Invalidate; -end; - -procedure TControl.SetOnMouseEnter(const Value: TOnEvent); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnMouseEnter := Value; - ProvideMouseEnterLeave( @Self ); -end; - -procedure TControl.SetOnMouseLeave(const Value: TOnEvent); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnMouseLeave := Value; - ProvideMouseEnterLeave( @Self ); -end; - -procedure TControl.SetOnTestMouseOver(const Value: TOnTestMouseOver); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnTestMouseOver := Value; - ProvideMouseEnterLeave( @Self ); -end; - -function WndProcEdTransparent( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - if (Msg.message = WM_KEYDOWN) or - (Msg.message = WM_MOUSEMOVE) and (GetKeyState( VK_LBUTTON ) < 0) or - (Msg.message = WM_LBUTTONUP) or (Msg.message = WM_LBUTTONDOWN) then - Self_.Invalidate; - Result := False; // continue handling of a message anyway -end; - -procedure TControl.EdSetTransparent(const Value: Boolean); -begin - Transparent := Value; - AttachProc( WndProcEdTransparent ); -end; - -var LastHWnd: HWnd; // + Don -function WndProcSpeedButton( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := False; - if Msg.message = WM_SETFOCUS then - begin - Result := TRUE; - Rslt := 0; - LastHWnd := Msg.wParam; // + don - end else // + Don - if (Msg.message = WM_CAPTURECHANGED) and - (Msg.lParam = 0) and - (LastHwnd <> 0) then - begin - SetFocus(LastHwnd); - LastHwnd := 0; - end; -end; - -function TControl.LikeSpeedButton: PControl; -var Form: PControl; -begin - AttachProc( WndProcSpeedButton ); - {$IFDEF USE_FLAGS} - {$ELSE} fTabstop := False; {$ENDIF} - Style := Style and not WS_TABSTOP; - Form := ParentForm; - if Form <> nil then - if Form.DF.fCurrentControl = @Self then - begin - Form.GotoControl( VK_TAB ); - if Form.DF.fCurrentControl = @Self then - Form.DF.fCurrentControl := nil; - end; - Result := @Self; -end; - -{ -- Unicode -- } -function TControl.SetUnicode(Unicode: Boolean): PControl; -begin - Perform( CCM_SETUNICODEFORMAT, Integer( Unicode ), 0 ); - Result := @ Self; -end; - -{ -- TabControl -- } - -function TControl.GetPages(Idx: Integer): PControl; -var Item: TTCItem; -begin - Item.mask := TCIF_PARAM; - if Perform( TCM_GETITEM, Idx, Integer( @Item ) ) = 0 then - Result := nil - else - Result := Pointer( Item.lParam ); -end; - -function TControl.TCGetItemText(Idx: Integer): KOLString; -var TI: TTCItem; - Buffer: array[ 0..1023 ] of KOLChar; -begin - TI.mask := TCIF_TEXT; - TI.pszText := @Buffer[ 0 ]; - TI.cchTextMax := sizeof( Buffer ); - Buffer[ 0 ] := #0; - Perform( TCM_GETITEM, Idx, Integer( @TI ) ); - Result := PKOLChar( @ Buffer[ 0 ] ); -end; - -procedure TControl.TCSetItemText(Idx: Integer; const Value: KOLString); -var TI: TTCItem; -begin - TI.mask := TCIF_TEXT; - TI.pszText := PKOLChar( Value ); - Perform( TCM_SETITEM, Idx, Integer( @TI ) ); -end; - -function TControl.TCGetItemImgIDx(Idx: Integer): Integer; -var TI: TTCItem; -begin - TI.mask := TCIF_IMAGE; - if Perform( TCM_GETITEM, Idx, Integer( @TI ) ) = 0 then - Result := -1 - else Result := TI.iImage; -end; - -procedure TControl.TCSetItemImgIdx(Idx: Integer; const Value: Integer); -var TI: TTCItem; -begin - TI.mask := TCIF_IMAGE; - TI.iImage := Value; - Perform( TCM_SETITEM, Idx, Integer( @TI ) ); -end; - -function TControl.TCGetItemRect(Idx: Integer): TRect; -begin - if Perform( TCM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then - begin - Result.Left := 0; - Result.Right := 0; - Result.Top := 0; - Result.Bottom := 0; - end; -end; - -procedure TControl.TC_SetPadding(cx, cy: Integer); -begin - Perform( TCM_SETPADDING, 0, cx or (cy shl 16) ); -end; - -function TControl.TC_TabAtPos(x, y: Integer): Integer; -type TTCHittestInfo = packed record - Pt: TPoint; - Fl: DWORD; - end; -var HTI: TTCHitTestInfo; -begin - HTI.Pt.x := x; - HTI.Pt.y := y; - Result := Perform( TCM_HITTEST, 0, Integer( @HTI ) ); -end; - -function TControl.TC_DisplayRect: TRect; -begin - Windows.GetClientRect( fHandle, Result ); - Perform( TCM_ADJUSTRECT, 0, Integer( @Result ) ); -end; - -function TControl.TC_IndexOf(const S: KOLString): Integer; -begin - Result := TC_SearchFor( S, -1, FALSE ); -end; - -function TControl.TC_SearchFor(const S: KOLString; StartAfter: Integer; - Partial: Boolean): Integer; -var I: Integer; -begin - Result := -1; - for I := StartAfter+1 to Count-1 do - begin - if Partial and ( Copy( TC_Items[ I ], 1, Length( S ) ) = S ) or - ( TC_Items[ I ] = S ) then - begin - Result := I; - break; - end; - end; -end; - -function TControl.TC_Insert(Idx: Integer; const TabText: KOLString; - TabImgIdx: Integer): PControl; -var TI: TTCItem; -begin - Result := NewPanel( @Self, esNone ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TControl:TabPage'; - {$ENDIF} - {$IFDEF OLD_ALIGN} - Result.FAlign := caClient; //+ Galkov - {$IFDEF USE_FLAGS} Result.fFlagsG4 := Result.fFlagsG4 + - [G4_VisibleWOParent, G4_NotUseAlign]; - {$ELSE} Result.fVisibleWoParent := TRUE; - Result.fNotUseAlign := True; - {$ENDIF} - {$ELSE NEW_ALIGN} - Result.Align := caClient; //+ Galkov - {$ENDIF} - Result.Visible := CurIndex<0; - TI.mask := TCIF_TEXT or TCIF_IMAGE or TCIF_PARAM; - TI.iImage := TabImgIdx; - TI.pszText := PKOLChar( TabText ); - TI.lParam := Integer( Result ); - Perform( TCM_INSERTITEM, Idx, Integer( @TI ) ); - {$IFDEF OLD_ALIGN} - Result.BoundsRect := TC_DisplayRect;//+ Galkov - {$ENDIF} - Perform(WM_SIZE,0,0); //May be changes of margins for TabControl - {$IFDEF GRAPHCTL_XPSTYLES} - Attach_WM_THEMECHANGED(Result, XP_Themes_For_TabPanel); - {$ENDIF} -end; - -procedure TControl.TC_Delete(Idx: Integer); -var Page: PControl; -begin - Page := TC_Pages[ Idx ]; - if Page = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Perform( TCM_DELETEITEM, Idx, 0 ); - Page.Free; - Perform(WM_SIZE,0,0); //May be changes of margins for TabControl -end; - -{$IFNDEF OLD_ALIGN} -procedure TControl.TC_InsertControl( Idx: Integer; const TabText: KOLString; - TabImgIdx: Integer; Page: PControl); -var TI: TTCItem; -begin - Page.Visible := CurIndex<0; - TI.mask := TCIF_TEXT or TCIF_IMAGE or TCIF_PARAM; - TI.iImage := TabImgIdx; - TI.pszText := PKOLChar( TabText ); - TI.lParam := Integer( Page ); - Perform( TCM_INSERTITEM, Idx, Integer( @TI ) ); - Perform(WM_SIZE,0,0); //May be changes of margins for TabControl -end; - -function TControl.TC_Remove( Idx: Integer ):PControl; -begin - Result := TC_Pages[ Idx ]; - if Result = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Perform( TCM_DELETEITEM, Idx, 0 ); - Perform(WM_SIZE,0,0); //May be changes of margins for TabControl -end; -{$ENDIF} - -{ -- TreeView -- } - -function TControl.TVGetItemIdx(const Index: Integer): THandle; -begin - Result := Perform( TVM_GETNEXTITEM, Index, 0 ); -end; - -procedure TControl.TVSetItemIdx(const Index: Integer; - const Value: THandle); -begin - Perform( TVM_SELECTITEM, Index, Value ); -end; - -function TControl.TVGetItemNext(Item: THandle; const Index: Integer): THandle; -begin - Result := Perform( TVM_GETNEXTITEM, Index, Item ); -end; - -function TControl.TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect; -begin - Result.Left := Item; - if Perform( TVM_GETITEMRECT, Integer( TextOnly ), Integer( @Result ) ) = 0 then - begin - Result.Left := 0; - Result.Right := 0; - Result.Top := 0; - Result.Bottom := 0; - end; -end; - -function TControl.TVGetItemVisible(Item: THandle): Boolean; -var R: TRect; -begin - R := TVItemRect[ Item, False ]; - Result := R.Bottom > R.Top; -end; - -procedure TControl.TVSetItemVisible(Item: THandle; const Value: Boolean); -begin - if Value then - Perform( TVM_ENSUREVISIBLE, 0, Item ); -end; - -function TControl.TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean; -var TVI: TTVItem; -begin - TVI.mask := TVIF_HANDLE or TVIF_STATE; - TVI.hItem := Item; - TVI.stateMask := Index; - Result := False; - if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then - Result := (TVI.state and Index) <> 0; -end; - -procedure TControl.TVSetItemStateFlg(Item: THandle; const Index: Integer; - const Value: Boolean); -var TVI: TTVItem; -begin - TVI.mask := TVIF_HANDLE or TVIF_STATE; - TVI.hItem := Item; - TVI.stateMask := Index; - TVI.state := $FFFFFFFF and Index; - if not Value then - TVI.state := 0; - Perform( TVM_SETITEM, 0, Integer( @TVI ) ); -end; - -function TControl.TVGetItemImage(Item: THandle; const Index: Integer): Integer; -var TVI: TTVItem; -begin - TVI.mask := TVIF_HANDLE or Loword( Index ); - TVI.hItem := Item; - if Hiword( Index ) <> 0 then - begin - TVI.mask := TVIF_STATE or TVIF_HANDLE; - TVI.stateMask := Loword( Index ); - end; - Result := -1; - if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then - begin - if Hiword( Index ) <> 0 then - Result := (TVI.state shr Hiword( Index )) and $F - else if Loword( Index ) = TVIF_IMAGE then - Result := TVI.iImage - else Result := TVI.iSelectedImage; - end; -end; - -procedure TControl.TVSetItemImage(Item: THandle; const Index: Integer; - const Value: Integer); -var TVI: TTVItem; -begin - TVI.mask := TVIF_HANDLE or Loword( Index ); - TVI.hItem := Item; - TVI.iImage := Value; - TVI.iSelectedImage := Value; - if Hiword( Index ) <> 0 then - begin - TVI.mask := TVIF_STATE or TVIF_HANDLE; - TVI.stateMask := Loword( Index ); - TVI.state := Value shl Hiword( Index ); - end; - Perform( TVM_SETITEM, 0, Integer( @TVI ) ); -end; - -function TControl.TVGetItemText(Item: THandle): KOLString; -var TVI: TTVItem; - Buffer: array[ 0..4095 ] of KOLChar; -begin - TVI.mask := TVIF_HANDLE or TVIF_TEXT; - TVI.hItem := Item; - TVI.pszText := @Buffer[ 0 ]; - Buffer[ 0 ] := #0; - TVI.cchTextMax := Sizeof( Buffer ) {$IFDEF UNICODE_CTRLS} div Sizeof( KOLChar ) {$ENDIF}; - Perform( TVM_GETITEM, 0, Integer( @TVI ) ); - Result := PKOLChar( @ Buffer[ 0 ] ); -end; - -procedure TControl.TVSetItemText(Item: THandle; const Value: KOLString); -var TVI: TTVItem; -begin - TVI.mask := TVIF_HANDLE or TVIF_TEXT; - TVI.hItem := Item; - TVI.pszText := PKOLChar( Value ); - Perform( TVM_SETITEM, 0, Integer( @TVI ) ); -end; - -function TControl.TVItemPath(Item: THandle; Delimiter: KOLChar): KOLString; -begin - if Item = 0 then - Item := TVSelected; - Result := ''; - while Item <> 0 do - begin - if Result <> '' then - Result := KOLString(Delimiter) + Result; - Result := TVItemText[ Item ] + Result; - Item := TVItemParent[ Item ]; - end; -end; - -function TControl.TV_GetItemHasChildren(Item: THandle): Boolean; -var TVI: TTVItem; -begin - TVI.mask := TVIF_HANDLE or TVIF_CHILDREN; - TVI.hItem := Item; - Perform( TVM_GETITEM, 0, Integer( @TVI ) ); - Result := TVI.cChildren = 1; -end; - -function TControl.TV_GetItemChildCount(Item: THandle): Integer; -var Node: THandle; -begin - Result := 0; - Node := TVItemChild[ Item ]; - while Node <> 0 do - begin - Inc( Result ); - Node := TVItemNext[ Node ]; - end; -end; - -procedure TControl.TV_SetItemHasChildren(Item: THandle; - const Value: Boolean); -var TVI: TTVItem; -begin - TVI.mask := TVIF_HANDLE or TVIF_CHILDREN; - TVI.hItem := Item; - TVI.cChildren := 1 and Integer( Value ); - Perform( TVM_SETITEM, 0, Integer( @TVI ) ); -end; - -function TControl.TVItemAtPos(x, y: Integer; var Where: DWORD): THandle; -var HTI: TTVHitTestInfo; -begin - HTI.pt.x := x; - HTI.pt.y := y; - Result := Perform( TVM_HITTEST, 0, Integer( @HTI ) ); - Where := HTI.fl; -end; - -type - TTVInsertStruct = packed Record - hParent: THandle; - hAfter : THandle; - item: TTVItem; - end; - TTVInsertStructEx = packed Record - hParent: THandle; - hAfter : THandle; - item: TTVItemEx; - end; - -function TControl.TVInsert(nParent, nAfter: THandle; - const Txt: KOLString): THandle; -var TVIns: TTVInsertStruct; -begin - TVIns.hParent := nParent; - TVIns.hAfter := nAfter; - TVIns.item.mask := TVIF_TEXT; - TVIns.item.pszText := PKOLChar( Txt ); - Result := Perform( TVM_INSERTITEM, 0, Integer( @TVIns ) ); - if fUpdateCount <= 0 then - Invalidate; -end; - -procedure TControl.TVExpand(Item: THandle; Flags: DWORD); -begin - Perform( TVM_EXPAND, Flags, Item ); -end; - -procedure TControl.TVSort( N: THandle ); -var a: Cardinal; - b: Boolean; -begin - b := N = 0; - if b then - N := TVRoot; - while N <> 0 do - begin - a := TVItemChild[N]; - if a > 0 then TVSort(a); - Perform(TVM_SORTCHILDREN, 0, N); - N := TVItemNext[N]; - end; - if b then //moved by Tr"]f - Perform(TVM_SORTCHILDREN, 0, 0); //+ by YS -end; - -procedure TControl.TVDelete(Item: THandle); -begin - Perform( TVM_DELETEITEM, 0, Item ); - Invalidate; -end; - -function TControl.TVGetItemData(Item: THandle): Pointer; -var TVI: TTVItem; -begin - TVI.mask := TVIF_HANDLE or TVIF_PARAM; - TVI.hItem := Item; - Result := nil; - if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then - Result := Pointer( TVI.lParam ); -end; - -procedure TControl.TVSetItemData(Item: THandle; const Value: Pointer); -var TVI: TTVItem; -begin - TVI.mask := TVIF_HANDLE or TVIF_PARAM; - TVI.hItem := Item; - TVI.lParam := Integer( Value ); - Perform( TVM_SETITEM, 0, Integer( @TVI ) ); -end; - -procedure TControl.TVEditItem(Item: THandle); -begin - Perform( TVM_EDITLABEL, 0, Item ); -end; - -procedure TControl.TVStopEdit(Cancel: Boolean); -begin - Perform( TVM_ENDEDITLABELNOW, Integer( Cancel ), 0 ); -end; - -function WndProcTVRightClickSelect( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean; -var I: Integer; - Where: DWORD; -begin - if Msg.message = WM_RBUTTONDOWN then - begin - I := Sender.TVItemAtPos( SmallInt( Msg.lParam and $FFFF ), - SmallInt( Msg.lParam shr 16 ), Where ); - if I <> 0 then - Sender.TVSelected := I; - end; - Result := FALSE; -end; - -procedure TControl.SetTVRightClickSelect(const Value: Boolean); -begin - DF.fTVRightClickSelect := Value; - if Value then - AttachProc( @WndProcTVRightClickSelect ); -end; - -procedure TControl.SetOnTVDelete( const Value: TOnTVDelete ); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnTVDelete := Value; - if fParent <> nil then - begin - fParent.Add2AutoFreeEx( Clear ); - fParent.DetachProc( WndProcNotify ); - fParent.AttachProcEx( WndProcNotify, TRUE ); - end; - AttachProcEx( ProcTVDeleteItem, TRUE ); -end; - -function ClipboardHasText: Boolean; -begin - Result := false; - if OpenClipboard( 0 ) then - begin - if IsClipboardFormatAvailable( CF_TEXT ) then - Result := TRUE; - CloseClipboard; - end; -end; - -function Clipboard2Text: AnsiString; -var gbl: THandle; - str: PAnsiChar; -begin - Result := ''; - if OpenClipboard( 0 ) then - begin - if IsClipboardFormatAvailable( CF_TEXT ) then - begin - gbl := GetClipboardData( CF_TEXT ); - if gbl <> 0 then - begin - str := GlobalLock( gbl ); - if str <> nil then - begin - Result := str; - GlobalUnlock( gbl ); - end; - end; - end; - CloseClipboard; - end; -end; - -{$IFNDEF _D2} -function Clipboard2WText: KOLWideString; -var gbl: THandle; - str: PWideChar; -begin - Result := ''; - if OpenClipboard( 0 ) then - begin - if IsClipboardFormatAvailable( CF_UNICODETEXT ) then - begin - gbl := GetClipboardData( CF_UNICODETEXT ); - if gbl <> 0 then - begin - str := GlobalLock( gbl ); - if str <> nil then - begin - Result := str; - GlobalUnlock( gbl ); - end; - end; - end; - CloseClipboard; - end; -end; -{$ENDIF} - -function Text2Clipboard( const S: AnsiString ): Boolean; -var gbl: THandle; - str: PAnsiChar; -begin - Result := False; - if not OpenClipboard( 0 ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - EmptyClipboard; - if S <> '' then - begin - gbl := GlobalAlloc( GMEM_DDESHARE, Length( S ) + 1 ); - if gbl <> 0 then - begin - str := GlobalLock( gbl ); - Move( S[ 1 ], str^, Length( S ) + 1 ); - GlobalUnlock( gbl ); - Result := SetClipboardData( CF_TEXT, gbl ) <> 0; - end; - end - else - Result := True; - CloseClipboard; -end; - -{$IFNDEF _D2} -function WText2Clipboard( const WS: KOLWideString ): Boolean; -var gbl: THandle; - str: PAnsiChar; -begin - Result := False; - if not OpenClipboard( 0 ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - EmptyClipboard; - if WS <> '' then - begin - gbl := GlobalAlloc( GMEM_DDESHARE, (Length( WS ) + 1) * 2 ); - if gbl <> 0 then - begin - str := GlobalLock( gbl ); - Move( WS[ 1 ], str^, (Length( WS ) + 1) * 2 ); - GlobalUnlock( gbl ); - Result := SetClipboardData( CF_UNICODETEXT, gbl ) <> 0; - end; - end - else - Result := True; - CloseClipboard; -end; -{$ENDIF} - -function TControl.Size(W, H: Integer): PControl; -var C, P: PControl; - dW, dH: Integer; -begin - C := @Self; - while True do - begin - dW := 0; dH := 0; - P := C.FParent; - if C.ToBeVisible then - begin - if C.fAlign in [caLeft, caRight, caClient] then - begin - if H > 0 then - begin - dH := H - C.Height; H := 0; - end; - end; - if C.fAlign in [caTop, caBottom, caClient] then - begin - if W > 0 then - begin - dW := W - C.Width; W := 0; - end; - end; - end; - if (W > 0) or (H > 0) then - begin - C.SetSize( W, H ); - if (P <> nil) // {Ralf Junker} - and not P.IsApplet then - C.ResizeParent; - end; - if (dW = 0) and (dH = 0) then break; - C := P; //C.FParent; - if C = nil then break; - //if not C.fIsControl then break; - if C.IsApplet then break; - W := C.Width + dW; - H := C.Height + dH; - end; - Result := @Self; -end; -{$ENDIF WIN_GDI} - -{$IFDEF GDI} -procedure AutoSzProc( Self_: PObj ); -var DeltaX, DeltaY: Integer; - SZ: TSize; PT: TPoint; - Txt: KOLString; - Chg: Boolean; - R: TRect; - Flags: DWORD; -{+ecm} - OldFont: HFONT; - CtlHavingFont: PControl; -{/+ecm} -begin - Txt := PControl( Self_ ).fCaption; - SZ.cx := 0; - SZ.cy := 0; - if Txt <> '' then - begin - if ( PControl( Self_ ).fFont <> nil ) then - if PControl( Self_ ).fFont.fData.Font.Italic then - Txt := Txt + ' '; - PControl( Self_ ).GetWindowHandle; // this line must be here. - //-- otherwise, when handle is not yet allocated, - // it is requested in TCanvas.GetHandle, and in result - // of unpredictable recursion some memory can be currupted. - PControl( Self_ ).Canvas.TextArea( Txt, SZ, PT ); - if {$IFDEF USE_FLAGS} (G1_WordWrap in PControl(Self_).fFlagsG1) - {$ELSE} PControl( Self_ ).fWordWrap {$ENDIF} - and (PControl( Self_ ).fAlign <> caClient) then - begin - R := PControl( Self_ ).ClientRect; - Flags := DT_CALCRECT or DT_EXPANDTABS or DT_WORDBREAK; - CASE PControl( Self_ ).fTextAlign OF - taCenter: Flags := Flags or DT_CENTER; - taRight : Flags := Flags or DT_RIGHT; - END; - {-ecm} -// CASE Self_.fVerticalAlign OF -// vaCenter: Flags := Flags or DT_VCENTER; -// vaBottom: Flags := Flags or DT_BOTTOM; -// END; - {/-ecm} - {+ecm} - CtlHavingFont := PControl( Self_ ); - while (CtlHavingFont <> nil) - and ( CtlHavingFont.FFont = nil ) do - CtlHavingFont := CtlHavingFont.Parent; - OldFont := 0; - if ( CtlHavingFont ) <> nil then - OldFont := SelectObject( PControl( Self_ ).Canvas.Handle, CtlHavingFont.Font.Handle ); - {/+ecm} - // DrawText return the height of the text ! - SZ.cy := DrawText( PControl( Self_ ).fCanvas.Handle, PKOLChar( Txt ), Length( Txt ), R, Flags ); - {+ecm} - if ( CtlHavingFont <> nil ) then - SelectObject(PControl( Self_ ).Canvas.fHandle,OldFont); - {/+ecm} - SZ.cx := R.Right - R.Left; - //SZ.cy := R.Bottom - R.Top; - end; - end; - Chg := FALSE; - if PControl( Self_ ).FAlign in [ caNone, caLeft, caRight ] then - begin - DeltaX := PControl( Self_ ).aAutoSzX; - if PControl( Self_ ).Width <> SZ.cx + DeltaX then - begin - PControl( Self_ ).Width := SZ.cx + DeltaX; - Chg := TRUE; - end; - if PControl( Self_ ).fMinWidth > PControl( Self_ ).Width then - begin - PControl( Self_ ).Width := PControl( Self_ ).fMinWidth; - Chg := TRUE; - end; - end; - if PControl( Self_ ).FAlign in [ caNone, caTop, caBottom ] then - begin - DeltaY := PControl( Self_ ).aAutoSzY; - if PControl( Self_ ).Height <> SZ.cy + DeltaY then - begin - PControl( Self_ ).Height := SZ.cy + DeltaY; - Chg := TRUE; - end; - if PControl( Self_ ).FMinHeight > PControl( Self_ ).Height then - begin - PControl( Self_ ).Height := PControl( Self_ ).FMinHeight; - Chg := TRUE; - end; - end; - if Chg then - begin - {$IFDEF OLD_ALIGN} - if PControl( Self_ ).fParent <> nil then - Global_Align( PControl( Self_ ).fParent ); - {$ENDIF} - Global_Align( Self_ ); - end; -end; -{$ENDIF GDI} -{$IFDEF _X_} -{$IFDEF GTK} -PROCEDURE AutoSzProc( Self_: PObj ); -VAR SZ: TSize; - //Txt: KOLString; - Chg: Boolean; - req_captn, req_evbox: TGtkRequisition; -BEGIN - //Txt := PControl( Self_ ).fCaption; - SZ.cx := 0; - SZ.cy := 0; - //if Txt <> '' then - BEGIN - gtk_widget_size_request( PControl( Self_ ).fCaptionHandle, @ req_captn ); - IF (PControl( Self_ ).fDeltaX = 0) AND - (PControl( Self_ ).fDeltaY = 0) THEN - BEGIN - gtk_widget_size_request( PControl( Self_ ).fEventboxHandle, @ req_evbox ); - PControl( Self_ ).fDeltaX := Max( 0, req_evbox.width - req_captn.width ); - PControl( Self_ ).fDeltaY := Max( 0, req_evbox.height - req_captn.height ); - END; - Sz.cx := req_captn.width + PControl( Self_ ).fDeltaX; - Sz.cy := req_captn.height + PControl( Self_ ).fDeltaY; - //gtk_widget_get_size_request( PControl( Self_ ).fHandle, @ Sz.cx, @ Sz.cy ); - END; - Chg := FALSE; - IF PControl( Self_ ).FAlign in [ caNone, caLeft, caRight ] THEN - BEGIN - //DeltaX := PControl( Self_ ).fCommandActions.aAutoSzX; - if PControl( Self_ ).Width <> SZ.cx {+ DeltaX} then - BEGIN - PControl( Self_ ).Width := SZ.cx {+ DeltaX}; - Chg := TRUE; - END; - IF PControl( Self_ ).fMinWidth > PControl( Self_ ).Width THEN - BEGIN - PControl( Self_ ).Width := PControl( Self_ ).fMinWidth; - Chg := TRUE; - END; - END; - IF PControl( Self_ ).FAlign in [ caNone, caTop, caBottom ] THEN - begin - //DeltaY := PControl( Self_ ).fCommandActions.aAutoSzY; - IF PControl( Self_ ).Height <> SZ.cy {+ DeltaY} THEN - BEGIN - PControl( Self_ ).Height := SZ.cy {+ DeltaY}; - Chg := TRUE; - END; - IF PControl( Self_ ).FMinHeight > PControl( Self_ ).Height THEN - BEGIN - PControl( Self_ ).Height := PControl( Self_ ).FMinHeight; - Chg := TRUE; - END; - END; - IF Chg THEN - BEGIN - {$IFDEF OLD_ALIGN} - if PControl( Self_ ).fParent <> nil then - Global_Align( PControl( Self_ ).fParent ); - {$ENDIF} - Global_Align( Self_ ); - END; -END; -{$ENDIF GTK} -{$ENDIF _X_} - -function TControl.AutoSize(AutoSzOn: Boolean): PControl; -begin - if AutoSzOn then - begin - PP.fAutoSize := AutoSzProc; - DoAutoSize; - end - else - PP.fAutoSize := DummyObjProc; - Result := @Self; -end; - -{$IFDEF WIN_GDI} -function TControl.IsAutoSize: Boolean; -begin - Result := Assigned( PP.fAutoSize ); -end; - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -function TControl.GetToBeVisible: Boolean; -begin - Result := {$IFDEF USE_FLAGS} (F3_Visible in fStyle.f3_Style) - {$ELSE} fVisible {$ENDIF} - or {$IFDEF USE_FLAGS} ([G4_CreateHidden, G4_VisibleWOParent] - * fFlagsG4 <> []) - or (G3_IsForm in fFlagsG3) - {$ELSE} fCreateHidden or fVisibleWoParent or IsForm {$ENDIF}; - if {$IFDEF USE_FLAGS} G3_IsControl in fFlagsG3 - {$ELSE} fIsControl {$ENDIF} then - if Parent <> nil then - begin - {$IFDEF OLD_ALIGN} - if {$IFDEF USE_FLAGS} G4_VisibleWOParent in fFlagsG4 - {$ELSE} fVisibleWoParent {$ENDIF} then - Result := {$IFDEF USE_FLAGS} F3_Visible in fStyle.f3_Style - {$ELSE} fVisible {$ENDIF} - else - {$ENDIF} - begin - if Result then - begin - Parent.Visible; // needed to provide correct fVisible for a form! - //todo: check if necessary for USE_FLAGS ??? - Result := Parent.ToBeVisible; - end; - end; - end; -end; -{$ENDIF PAS_VERSION} - -/////////////////////////////////////////////////////////////////////// -// W I N D O W S -/////////////////////////////////////////////////////////////////////// - -{ -- Set of window-related utility functions. -- } -type - PGUIThreadInfo = ^TGUIThreadInfo; - tagGUITHREADINFO = packed record - cbSize: DWORD; - flags: DWORD; - hwndActive: HWND; - hwndFocus: HWND; - hwndCapture: HWND; - hwndMenuOwner: HWND; - hwndMoveSize: HWND; - hwndCaret: HWND; - rcCaret: TRect; - end; - TGUIThreadInfo = tagGUITHREADINFO; - -const - GUI_CARETBLINKING = $00000001; - GUI_INMOVESIZE = $00000002; - GUI_INMENUMODE = $00000004; - GUI_SYSTEMMENUMODE = $00000008; - GUI_POPUPMENUMODE = $00000010; - -{function GetGUIThreadInfo (idThread: DWORD; var pgui: TGUIThreadinfo): BOOL; stdcall; - external user32 name 'GetGUIThreadInfo';} - -type TGUIThreadInfo_Proc = function( ThreadID: THandle; var GTI: TGUIThreadInfo ) - : Boolean; stdcall; - -var Proc_GetGUIThreadInfo: TGuiThreadInfo_Proc; - -function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd; -var GTI: TGuiThreadInfo; - ThreadID: THandle; - Module: THandle; -begin - if not Assigned( Proc_GetGUIThreadInfo ) then - begin - Module := GetModuleHandle( 'User32' ); - Proc_GetGUIThreadInfo := GetProcAddress( Module, 'GetGUIThreadInfoA' ); - if not Assigned( Proc_GetGUIThreadInfo ) then - Proc_GetGUIThreadInfo := Pointer( -1 ); - end; - Result := Wnd; - if Integer( @Proc_GetGUIThreadInfo ) = -1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>} - Result := 0; - if Wnd = 0 then - ThreadID := GetCurrentThreadID - else - ThreadID := GetWindowThreadProcessID( Wnd, nil ); - if ThreadID = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - GTI.cbSize := Sizeof( GTI ); - if Proc_GetGUIThreadInfo( ThreadId, GTI ) then - begin - case Kind of - wcActive: Result := GTI.hwndActive; - wcFocus: Result := GTI.hwndFocus; - wcCapture: Result := GTI.hwndCapture; - wcMenuOwner: Result := GTI.hwndMenuOwner; - wcMoveSize: Result := GTI.hwndMoveSize; - wcCaret: Result := GTI.hwndCaret; - end; - end; -end; - -function GetFocusedChild( Wnd: HWnd ): HWnd; -var Tr1, Tr2: THandle; -begin - Result := 0; - Tr1 := GetCurrentThreadId; - Tr2 := GetWindowThreadProcessId( Wnd, nil ); - if Tr1 = Tr2 then - Result := GetFocus - else - if AttachThreadInput( Tr2, Tr1, True ) then - begin - Result := GetFocus; - AttachThreadInput( Tr2, Tr1, False ); - end; -end; - -function WaitFocusedWndChild( Wnd: HWnd ): HWnd; -var T1, T2: Integer; - W: HWnd; -begin - Sleep( 50 ); - T1 := GetTickCount; - while True do - begin - W := GetTopWindow( Wnd ); - if W = 0 then W := Wnd; - W := GetFocusedChild( W ); - if W <> 0 then - begin - Wnd := W; - break; - end; - T2 := GetTickCount; - if Abs( T1 - T2 ) > 100 then break; - end; - Result := Wnd; -end; - -function Stroke2Window( Wnd: HWnd; const S: AnsiString ): Boolean; -var P: PAnsiChar; -begin - Result := False; - Wnd := WaitFocusedWndChild( Wnd ); - if Wnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - P := PAnsiChar( S ); - while P^ <> #0 do - begin - PostMessage( Wnd, WM_CHAR, Integer( P^ ), 1 ); - Inc( P ); - end; - Result := True; -end; - -function Stroke2WindowEx( Wnd: HWnd; const S: AnsiString; Wait: Boolean ): Boolean; -var P: PAnsiChar; - EndChar: AnsiChar; - MsgDn, MsgUp, SCA: Integer; - - function Compare( Pattern: PAnsiChar ): Boolean; - var Pos: PAnsiChar; - C1, C2: AnsiChar; - begin - Pos := P; - while Pattern^ <> #0 do - begin - C1 := Pattern^; - C2 := Pos^; - if (C1 >= 'a') and (C1 <= 'z') then - C1 := AnsiChar( Ord( C1 ) - $20 ); - if (C2 >= 'a') and (C2 <= 'z') then - C2 := AnsiChar( Ord( C2 ) - $20 ); - if C1 <> C2 then - begin - Result := False; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Inc( Pos ); - Inc( Pattern ); - end; - while Pos^ = ' ' do Inc( Pos ); - P := Pos; - Result := True; - end; - - procedure Send( Msg, KeyCode: Integer ); - var lParam: Integer; - begin - Wnd := WaitFocusedWndChild( Wnd ); - if Wnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - lParam := 1; - if longBool( SCA and 4 ) then - lParam := $20000001; - if Msg = MsgUp then - lParam := lParam or Integer($D0000000); - PostMessage( Wnd, Msg, KeyCode, lParam ); - Applet.ProcessMessages; - if Wait then - Sleep( 50 ); - end; - - function CompareSend( Pattern: PAnsiChar; Value2Send: Integer ): Boolean; - begin - if Compare( Pattern ) then - begin - Send( MsgDn, Value2Send ); - Send( MsgUp, Value2Send ); - Result := True; - end - else - Result := False; - end; - - function ParseKeys( EndChar: AnsiChar ): PAnsiChar; - var FN: Integer; - begin - SCA := 0; - while not (P^ in [ #0, EndChar ]) do - begin - if Compare( 'Shift' ) then SCA := SCA or 1 - else - if Compare( 'Ctrl' ) then SCA := SCA or 2 - else - if Compare( 'Alt' ) then SCA := SCA or 4 - else - break; - end; - MsgDn := WM_KEYDOWN; - MsgUp := WM_KEYUP; - if LongBool( SCA and 4 ) then - begin - MsgDn := WM_SYSKEYDOWN; - MsgUp := WM_SYSKEYUP; - keybd_event( VK_MENU, 0, 0, 0 ); - Send( WM_SYSKEYDOWN, VK_MENU ); - end; - if LongBool( SCA and 2 ) then - begin - keybd_event( VK_CONTROL, 0, 0, 0 ); - Send( WM_KEYDOWN, VK_CONTROL ); - end; - if Longbool( SCA and 1 ) then - begin - keybd_event( VK_SHIFT, 0, 0, 0 ); - Send( WM_KEYDOWN, VK_SHIFT ); - end; - while not (P^ in [ #0, EndChar ]) do - begin - if (P^ = 'F') and (P[ 1 ] in [ '1'..'9' ]) then - begin - Inc( P ); - FN := Ord( P^ ) - Ord( '0' ); - if (FN = 1) and (P[ 1 ] in [ '0'..'2' ]) then - begin - Inc( P ); - FN := 10 + Ord( P^ ) - Ord( '0' ); - end; - repeat Inc( P ) until P^ <> ' '; - FN := FN + $6F; - Send( MsgDn, FN ); - Send( MsgUp, FN ); - end - else - if Compare( 'Numpad' ) then - begin - if P^ in [ '0'..'9' ] then - begin - FN := Ord( P^ ) - Ord( '0' ) + $60; - repeat Inc( P^ ) until P^ <> ' '; - Send( MsgDn, FN ); - Send( MsgUp, FN ); - end; - end - else - if not (CompareSend( 'Add', $6B ) or - CompareSend( 'Gray+', $6B ) or - CompareSend( 'Apps', $5D ) or - CompareSend( 'BackSpace', $08 ) or - CompareSend( 'BkSp', $08 ) or - CompareSend( 'BS', $08 ) or - CompareSend( 'Break', $13 ) or - CompareSend( 'CapsLock', $14 ) or - CompareSend( 'Clear', $0C ) or - CompareSend( 'Decimal', $6E ) or - CompareSend( 'Del', $2E ) or - CompareSend( 'Delete', $2E ) or - CompareSend( 'Divide', $6F ) or - CompareSend( 'Gray/', $6F ) or - CompareSend( 'Down', $28 ) or - CompareSend( 'End', $23 ) or - CompareSend( 'Enter', $0D ) or - CompareSend( 'Return', $0D ) or - CompareSend( 'CR', $0D ) or - CompareSend( 'Esc', $1B ) or - CompareSend( 'Escape', $1B ) or - CompareSend( 'Help', $2F ) or - CompareSend( 'Home', $24 ) or - CompareSend( 'Ins', $2D ) or - CompareSend( 'Insert', $2D ) or - CompareSend( 'Left', $25 ) or - CompareSend( 'LWin', $5B ) or - CompareSend( 'Multiply', $6A ) or - CompareSend( 'Gray*', $6A ) or - CompareSend( 'NumLock', $90 ) or - CompareSend( 'PgDn', $22 ) or - CompareSend( 'PgUp', $21 ) or - CompareSend( 'PrintScrn', $2C ) or - CompareSend( 'Right', $27 ) or - CompareSend( 'RWin', $5C ) or - CompareSend( 'Separator', $6C ) or - CompareSend( 'ScrollLock', $91 ) or - CompareSend( 'Subtract', $6D ) or - CompareSend( 'Tab', $09 ) or - CompareSend( 'Gray-', $6D ) or - CompareSend( 'Up', $26 )) then break; - end; - while not (P^ in [ #0, EndChar ]) do - begin - if P^ in [ 'A'..'Z', '0'..'9' ] then - begin - Send( MsgDn, Integer( P^ ) ); - Send( MsgUp, Integer( P^ ) ); - end - else - if P^ in [ #1..#255 ] then - Stroke2Window( Wnd, AnsiString('') + P^ ); - repeat Inc( P ) until (P^ <> AnsiString(' ')); - end; - if P^ = EndChar then - Inc( P ); - if Longbool( SCA and 1 ) then - begin - Send( WM_KEYUP, VK_SHIFT ); - keybd_event( VK_SHIFT, 0, KEYEVENTF_KEYUP, 0 ); - end; - if LongBool( SCA and 2 ) then - begin - Send( WM_KEYUP, VK_CONTROL ); - keybd_event( VK_CONTROL, 0, KEYEVENTF_KEYUP, 0 ); - end; - if LongBool( SCA and 4 ) then - begin - Send( WM_SYSKEYUP, VK_MENU ); - keybd_event( VK_MENU, 0, KEYEVENTF_KEYUP, 0 ); - end; - Result := P; - end; - -begin - Result := False; - Wnd := GetTopWindow( Wnd ); - Wnd := GetFocusedChild( Wnd ); - if Wnd = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - P := PAnsiChar( S ); - while P^ <> #0 do - begin - if not (P^ in [ '[', '{' ]) then - begin - Stroke2Window( Wnd, AnsiString('') + P^ ); // TODO: adjust compile options? - Inc( P ); - end - else - begin - if P^ = '[' then - EndChar := ']' - else - EndChar := '}'; - Inc( P ); - P := ParseKeys( EndChar ); - end; - end; - Result := True; -end; - -type - PHWnd = ^HWnd; - - TFindWndRec = packed Record - ThreadID : DWord; - WndFound : HWnd; - end; - PFindWndRec = ^TFindWndRec; - -function EnumWindowsProc( Wnd : HWnd; Find : PFindWndRec ) : Boolean; -stdcall; -var Id : DWord; -begin - Result := True; - Id := GetWindowThreadProcessId( Wnd, @Id ); - if Id = Find.ThreadID then - begin - Find.WndFound := Wnd; - Result := False; - end; -end; - -function FindWindowByThreadID( ThreadID : DWORD ) : HWnd; -var Find : TFindWndRec; -begin - Find.ThreadID := ThreadID; - Find.WndFound := 0; - EnumWindows( @EnumWindowsProc, Integer( @Find ) ); - Result := Find.WndFound; -end; - -function DesktopPixelFormat: TPixelFormat; -var DC: HDC; - Nbits_per_pixel, Nplanes: Integer; -begin - DC := GetDC( 0 ); - Nbits_per_pixel := GetDeviceCaps( DC, BITSPIXEL ); - Nplanes := GetDeviceCaps( DC, PLANES ); - ReleaseDC( 0, DC ); - CASE Nplanes * Nbits_per_pixel OF - 1: Result := pf1bit; - 4: Result := pf4bit; - 8: Result := pf8bit; - 16: Result := pf16bit; - 24, 32: Result := pf32bit; - else Result := pfDevice; - END; -end; - -function GetDesktopRect : TRect; -var W1, W2 : HWnd; -begin - if WinVer >= wvVista then - begin - Result := GetWorkArea; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) ); - W2 := findwindow('Progman',nil); - W1 := findwindowex(W2,0,'SHELLDLL_DefView',nil); - if W1 = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - GetWindowRect( W1, Result ); -end; - -function GetWorkArea: TRect; -begin - SystemParametersInfo( SPI_GETWORKAREA, 0, @ Result, 0 ); -end; - -function ExecuteWait( const AppPath, CmdLine, DfltDirectory: KOLString; - Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean; -var Flags: DWORD; - Startup: TStartupInfo; - ProcInf: TProcessInformation; - DfltDir: PKOLChar; - App: KOLString; -begin - Result := FALSE; - Flags := CREATE_NEW_CONSOLE; - if Show = SW_HIDE then - Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF}; - ZeroMemory( @Startup, SizeOf( Startup ) ); - Startup.cb := Sizeof( Startup ); - Startup.wShowWindow := Show; - Startup.dwFlags := STARTF_USESHOWWINDOW; - if ProcID <> nil then - ProcID^ := 0; - DfltDir := nil; - if DfltDirectory <> '' then - DfltDir := PKOLChar( DfltDirectory ); - App := AppPath; - //if (pos( KOLString(' '), App ) > 0) and (pos( KOLString('"'), App ) <= 0) then - if (App <> '') and (App[1] <> '"') and (pos( KOLString(' '), App ) > 0) then - App := '"' + App + '"'; - if (App <> '') and (CmdLine <> '') then - App := App + ' '; - if CreateProcess( nil, PKOLChar( App + CmdLine ), nil, - nil, FALSE, Flags, nil, DfltDir, Startup, - ProcInf ) then - begin - if WaitForSingleObject( ProcInf.hProcess, TimeOut ) = WAIT_OBJECT_0 then - begin - CloseHandle( ProcInf.hProcess ); - Result := TRUE; - end - else - begin - if ProcID <> nil then - ProcID^ := ProcInf.hProcess; - end; - CloseHandle( ProcInf.hThread ); - end; -end; - -function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString; - Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean; -var Flags: DWORD; - Startup: TStartupInfo; - ProcInf: TProcessInformation; - DfltDir: PKOLChar; - SecurityAttributes: TSecurityAttributes; - SaveStdOut, SaveStdIn: THandle; - ChildStdOutRd, ChildStdOutWr: THandle; - ChildStdInRd, ChildStdInWr: THandle; - ChildStdOutRdDup: THandle; - ChildStdInWrDup: THandle; - - procedure Do_CloseHandle( var Handle: THandle ); - begin - if Handle <> 0 then - begin - CloseHandle( Handle ); - Handle := 0; - end; - end; - - procedure Close_Handles; - begin - Do_CloseHandle( ChildStdOutRd ); - Do_CloseHandle( ChildStdOutWr ); - Do_CloseHandle( ChildStdInRd ); - Do_CloseHandle( ChildStdInWr ); - end; - - function RedirectInputOutput: Boolean; - begin - Result := FALSE; - if (OutPipeRd <> nil) or (OutPipeWr <> nil) then - begin - // redirect output - SaveStdOut := GetStdHandle(STD_OUTPUT_HANDLE); - if not CreatePipe( ChildStdOutRd, ChildStdOutWr, @ SecurityAttributes, 0 ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if not SetStdHandle( STD_OUTPUT_HANDLE, ChildStdOutWr ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if not DuplicateHandle( GetCurrentProcess, ChildStdOutRd, - GetCurrentProcess, @ ChildStdOutRdDup, 0, FALSE, - 2 {DUPLICATE_SAME_ACCESS} ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Do_CloseHandle( ChildStdOutRd ); - if OutPipeRd <> nil then - OutPipeRd^ := ChildStdOutRdDup; - if OutPipeWr <> nil then - OutPipeWr^ := ChildStdOutWr; - end; - if InPipe <> nil then - begin - // redirect input - SaveStdIn := GetStdHandle(STD_INPUT_HANDLE); - if not CreatePipe( ChildStdInRd, ChildStdInWr, @ SecurityAttributes, 0 ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if not SetStdHandle( STD_INPUT_HANDLE, ChildStdInRd ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if not DuplicateHandle( GetCurrentProcess, ChildStdInWr, - GetCurrentProcess, @ ChildStdInWrDup, 0, FALSE, - 2 {DUPLICATE_SAME_ACCESS} ) then - Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Do_CloseHandle( ChildStdInWr ); - if InPipe <> nil then - InPipe^ := ChildStdInWrDup; - Do_CloseHandle( ChildStdInRd ); - end; - Result := TRUE; - end; - - procedure Restore_Saved_StdInOut; - begin - SetStdHandle( STD_OUTPUT_HANDLE, SaveStdOut ); - SetStdHandle( STD_INPUT_HANDLE, SaveStdIn ); - end; - -var Cmd: KOLString; -begin - Result := FALSE; - Flags := 0; - if Show = SW_HIDE then - Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF}; - ZeroMemory( @Startup, SizeOf( Startup ) ); - Startup.cb := Sizeof( Startup ); - if ProcID <> nil then - ProcID^ := 0; - DfltDir := nil; - SecurityAttributes.nLength := Sizeof( SecurityAttributes ); - SecurityAttributes.lpSecurityDescriptor := nil; - SecurityAttributes.bInheritHandle := TRUE; - SaveStdOut := 0; - SaveStdIn := 0; - ChildStdOutRd := 0; - ChildStdOutWr := 0; - ChildStdInRd := 0; - ChildStdInWr := 0; - if not RedirectInputOutput then - begin - Close_Handles; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if DfltDirectory <> '' then - DfltDir := PKOLChar( DfltDirectory ); - Cmd := '"' + AppPath + '" ' + CmdLine; - if CreateProcess( nil, PKOLChar( Cmd ), nil, nil, TRUE, Flags, nil, - DfltDir, Startup, ProcInf ) then - begin - if ProcID <> nil then - ProcID^ := ProcInf.hProcess - else - CloseHandle( ProcInf.hProcess ); - CloseHandle( ProcInf.hThread ); - Restore_Saved_StdInOut; - Result := TRUE; - end else - begin - Restore_Saved_StdInOut; - Close_Handles; - end; -end; - -function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString; - Show: DWORD; const InStr: KOLString; var OutStr: KOLString; WaitTimeout: DWORD ): Boolean; -var PipeIn, PipeOutRd, PipeOutWr: THandle; - ProcID: DWORD; - BytesCount: DWORD; - Buffer: Array[ 0..4096 ] of KOLChar; // KOL_ANSI - BufStr: KOLString; - PPipeIn: PHandle; -begin - Result := FALSE; - PPipeIn := @ PipeIn; - if InStr = '' then - PPipeIn := nil; - PipeOutRd := 0; - PipeOutWr := 0; - if not ExecuteIORedirect( AppPath, CmdLine, DfltDirectory, Show, @ ProcID, - PPipeIn, @ PipeOutWr, @ PipeOutRd ) then Exit; {>>>>>>>>>>} - if PPipeIn <> nil then - begin - if InStr <> '' then - WriteFile( PipeIn, InStr[ 1 ], Length( InStr ), BytesCount, nil ); - CloseHandle( PipeIn ); - end; - OutStr := ''; - if WaitForSingleObject( ProcID, WaitTimeOut ) = WAIT_OBJECT_0 then - begin - CloseHandle( ProcID ); - CloseHandle( PipeOutWr ); - while ReadFile( PipeOutRd, Buffer, Sizeof( Buffer ), BytesCount, nil ) do - begin - SetLength( BufStr, BytesCount ); - Move( Buffer[ 0 ], BufStr[ 1 ], BytesCount ); - OutStr := OutStr + BufStr; - end; - end - else - CloseHandle( PipeOutWr ); - CloseHandle( PipeOutRd ); - Result := TRUE; -end; - -{$IFDEF _D2} -function OpenProcessToken(ProcessHandle: THandle; DesiredAccess: DWORD; - var TokenHandle: THandle): BOOL; stdcall; - external advapi32 name 'OpenProcessToken'; -{$ENDIF} - -function WindowsShutdown( const Machine : KOLString; Force, Reboot : Boolean ) : Boolean; -var - hToken: THandle; - tkp, tkp_prev: TTokenPrivileges; - dwRetLen :DWORD; - Flags: Integer; -begin - Result := False; - if Integer( GetVersion ) < 0 then // Windows95/98/Me - begin - if Machine <> '' then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Flags := EWX_SHUTDOWN; - if Reboot then - Flags := Flags or EWX_REBOOT; - if Force then - Flags := Flags or EWX_FORCE; - Result := ExitWindowsEx( Flags, 0 ); Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - OpenProcessToken(GetCurrentProcess(), - TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, - hToken); - if not LookupPrivilegeValue(PKOLChar(Machine), 'SeShutdownPrivilege', - tkp.Privileges[0].Luid) then Exit; {>>>>>>>>>>>>>} - tkp_prev:=tkp; - tkp.PrivilegeCount:=1; - tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED; - AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev, -dwRetLen); - if not LookupPrivilegeValue(PKOLChar(Machine), - 'SeRemoteShutdownPrivilege', - tkp.Privileges[0].Luid) then Exit; {>>>>>>>>>>>>} - tkp.PrivilegeCount:=1; - tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED; - AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev, dwRetLen); - Result := InitiateSystemShutdown(PKOLChar(Machine),nil, 0, Force, Reboot); -end; - -function WindowsLogoff( Force : Boolean ) : Boolean; -var Flags: Integer; -begin - Flags := 0; - if Force then - Flags := EWX_FORCE; - Result := ExitWindowsEx( Flags, 0 ); -end; - -var SaveWinVer: Byte = $FF; - -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} // asm version by MTsv DN (v 2.90) -function WinVer : TWindowsVersion; -var MajorVersion, MinorVersion: Byte; - dwVersion: Integer; -begin - if SaveWinVer <> $FF then Result := TWindowsVersion( SaveWinVer ) - else - begin - dwVersion := GetVersion; - MajorVersion := LoByte( dwVersion ); - MinorVersion := HiByte( LoWord( dwVersion ) ); - if dwVersion >= 0 then - begin - Result := wvNT; - if (MajorVersion >= 6) then begin - if (MinorVersion >= 1) then - Result := wvSeven - else - Result := wvVista; - end else begin - if MajorVersion >= 5 then - if MinorVersion >= 1 then - begin - Result := wvXP; - if MinorVersion >= 2 then - Result := wvServer2003; - end - else Result := wvY2K; - end; - end - else - begin - Result := wv95; - if (MajorVersion > 4) or - (MajorVersion = 4) and (MinorVersion >= 10) then - begin - Result := wv98; - if (MajorVersion = 4) and (MinorVersion >= $5A) then - Result := wvME; - end - else - if MajorVersion <= 3 then - Result := wv31; - end; - SaveWinVer := Ord( Result ); - end; -end; -{$ENDIF PAS_VERSION} - -function IsWinVer( Ver : TWindowsVersions ) : Boolean; -{* Returns True if Windows version is in given range of values. } -begin - Result := WinVer in Ver; -end; - -procedure TControl.SetAlphaBlend(const Value: Byte); -const - LWA_COLORKEY=$00000001; - LWA_ALPHA=$00000002; - ULW_COLORKEY=$00000001; - ULW_ALPHA=$00000002; - ULW_OPAQUE=$00000004; - WS_EX_LAYERED=$00080000; -type - TSetLayeredWindowAttributes= - function( hwnd: Integer; crKey: TColor; bAlpha: Byte; dwFlags: DWORD ) - : Boolean; stdcall; -var - SetLayeredWindowAttributes: TSetLayeredWindowAttributes; - User32: THandle; - dw: DWORD; -begin - if Value = fAlphaBlend then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - fAlphaBlend := Value; - User32 := GetModuleHandle( 'User32' ); - SetLayeredWindowAttributes := GetProcAddress( User32, - 'SetLayeredWindowAttributes' ); - if Assigned( SetLayeredWindowAttributes ) then - begin - dw := GetWindowLong( GetWindowHandle, GWL_EXSTYLE ); - if Value < 255 then - begin - SetWindowLong( fHandle, GWL_EXSTYLE, dw or WS_EX_LAYERED ); - SetLayeredWindowAttributes( fHandle, 0, Value {and $FF}, LWA_ALPHA); - end else - SetWindowLong( fHandle, GWL_EXSTYLE, dw and not WS_EX_LAYERED ); - end; -end; - -{$ENDIF WIN_GDI} -function TControl.SetPosition( X, Y: Integer ): PControl; -begin - Left := X; - Top := Y; - Result := @Self; -end; -{$IFDEF WIN_GDI} - -function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog; -var I: Integer; -begin - New( Result, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fObjKind := 'TColorDialog'; - {$ENDIF} - Result.ColorCustomOption := FullOpen; - for I := 1 to 16 do - Result.CustomColors[ I ] := clWhite; -end; - -{ TColorDialog } - -function TColorDialog.Execute: Boolean; -var CD: TChooseColor; -begin - CD.lStructSize := Sizeof( CD ); - CD.hWndOwner := OwnerWindow; - //CD.hInstance := 0; - CD.rgbResult := Color2RGB( Color ); - CD.lpCustColors := @CustomColors[ 1 ]; - CD.Flags := CC_RGBINIT; - case ColorCustomOption of - ccoFullOpen: CD.Flags := CD.Flags or CC_FULLOPEN; - ccoPreventFullOpen: CD.Flags := CD.Flags or CC_PREVENTFULLOPEN; - end; - Result := ChooseColor( CD ); - if Result then - Color := CD.rgbResult; -end; - -procedure TControl.SetMaxProgress(const Index, Value: Integer); -begin - // ignore index, and set Value via PBM_SETRANGE32: () - Perform( PBM_SETRANGE32, 0, Value ); -end; - -procedure TControl.SetDroppedWidth(const Value: Integer); -begin - DF.fDroppedWidth := Value; - Perform( CB_SETDROPPEDWIDTH, Value, 0 ); -end; - -function TControl.LVGetItemState(Idx: Integer): TListViewItemState; -type - PListViewItemState = ^TListViewItemState; -var I: Byte; -begin - I := Perform( LVM_GETITEMSTATE, Idx, - LVIS_CUT or LVIS_DROPHILITED or LVIS_FOCUSED or LVIS_SELECTED ); - Result := PListViewItemState( @ I )^; -end; - -procedure TControl.LVSetItemState(Idx: Integer; const Value: TListViewItemState); -var Data: TLVItem; -begin - Data.stateMask := LVIS_FOCUSED or LVIS_SELECTED or LVIS_CUT or LVIS_DROPHILITED; - Data.state := PByte( @ Value )^; - Perform( LVM_SETITEMSTATE, Idx, Integer( @Data ) ); -end; - -procedure TControl.LVSelectAll; -begin - LVSetItemState( -1, [ lvisSelect ] ); -end; - -function TControl.LVItemInsert(Idx: Integer; const aText: KOLString): Integer; -var LVI: TLVItem; -begin - LVI.mask := LVIF_TEXT or LVIF_DI_SETITEM; - LVI.iItem := Idx; - LVI.iSubItem := 0; - LVI.pszText := PKOL_Char( aText ); - Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) ); -end; - -function TControl.LVItemAdd(const aText: KOLString): Integer; -begin - Result := LVItemInsert( Count, aText ); -end; - -function TControl.LVGetSttImgIdx(Idx: Integer): Integer; -begin - Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_STATEIMAGEMASK ) shr 12; -end; - -procedure TControl.LVSetSttImgIdx(Idx: Integer; const Value: Integer); -var LVI: TLVItem; -begin - LVI.stateMask := LVIS_STATEIMAGEMASK; - LVI.state := Value shl 12; - Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) ); -end; - -function TControl.LVGetOvlImgIdx(Idx: Integer): Integer; -begin - Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_OVERLAYMASK ) shr 8; -end; - -procedure TControl.LVSetOvlImgIdx(Idx: Integer; const Value: Integer); -var LVI: TLVItem; -begin - LVI.stateMask := LVIS_OVERLAYMASK; - LVI.state := Value shl 8; - Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) ); -end; - -function TControl.LVGetItemData(Idx: Integer): DWORD; -var LVI: TLVItem; -begin - LVI.mask := LVIF_PARAM; - LVI.iItem := Idx; - LVI.iSubItem := 0; - Perform( LVM_GETITEM, 0, Integer( @LVI ) ); - Result := LVI.lParam; -end; - -procedure TControl.LVSetItemData(Idx: Integer; const Value: DWORD); -var LVI: TLVItem; -begin - LVI.mask := LVIF_PARAM; - LVI.iItem := Idx; - LVI.iSubItem := 0; - LVI.lParam := Value; - Perform( LVM_SETITEM, 0, Integer( @LVI ) ); -end; - -function TControl.LVGetItemIndent(Idx: Integer): Integer; -var LI: TLVItem; -begin - LI.mask := LVIF_INDENT; - LI.iItem := Idx; - LI.iSubItem := 0; - Perform( LVM_GETITEM, 0, Integer( @LI ) ); - Result := LI.iIndent; -end; - -procedure TControl.LVSetItemIndent(Idx: Integer; const Value: Integer); -var LI: TLVItem; -begin - LI.mask := LVIF_INDENT or LVIF_DI_SETITEM; - LI.iItem := Idx; - LI.iSubItem := 0; - LI.iIndent := Value; - Perform( LVM_SETITEM, 0, Integer( @LI ) ); -end; - -type - TNMLISTVIEW = packed Record - hdr: TNMHDR; - iItem: Integer; - iSubItem: Integer; - uNewState: Integer; - uOldState: Integer; - uChanged: Integer; - ptAction: Integer; - lParam: DWORD; - end; - PNMLISTVIEW = ^TNMLISTVIEW; - -function WndProc_LVDeleteItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; -var Hdr: PNMHDR; - LV: PNMListView; -begin - Result := FALSE; - if Msg.message = WM_NOTIFY then - begin - Hdr := Pointer(Msg.lParam); - if Hdr.hwndFrom = Sender.Handle then - begin - LV := Pointer( Hdr ); - if Hdr.code = LVN_DELETEITEM then - begin - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnDeleteLVItem ) then - {$ENDIF} - Sender.EV.fOnDeleteLVItem( Sender, LV.iItem ); - Result := TRUE; - end - else - if Hdr.code = LVN_DELETEALLITEMS then - begin - if Assigned( Sender.DF.fOnDeleteAllLVItems ) then - begin - Sender.DF.fOnDeleteAllLVItems( Sender ); - Rslt := 0; - if Assigned( Sender.EV.fOnDeleteLVItem ) then - Rslt := 1; - end; - Result := TRUE; - end; - end; - end; -end; - -procedure TControl.SetOnDeleteAllLVItems(const Value: TOnEvent); -begin - DF.fOnDeleteAllLVItems := Value; - AttachProc( @WndProc_LVDeleteItem ); -end; - -procedure TControl.SetOnDeleteLVItem(const Value: TOnDeleteLVItem); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnDeleteLVItem := Value; - AttachProc( @WndProc_LVDeleteItem ); -end; - -function WndProc_LVData( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; -var Hdr: PNMHDR; - DI: PLVDispInfo; - Store: Boolean; - Txt: KOL_String; - LV: PControl; -begin - Result := FALSE; - if Msg.message = WM_NOTIFY then - begin - Hdr := Pointer(Msg.lParam); - if Hdr.hwndFrom = Sender.Handle then - begin - if (Hdr.code = LVN_GETDISPINFO) - {$IFDEF UNICODE_CTRLS} - or (Hdr.code = LVN_GETDISPINFOW) - {$ENDIF UNICODE_CTRLS} - then - begin - DI := Pointer( Hdr ); - LV := Sender; - if LV <> nil then - begin - Txt := ''; - DI.item.iImage := -1; - DI.item.state := 0; - if {$IFDEF NIL_EVENTS} Assigned( LV.EV.fOnLVData ) and {$ENDIF} - (DI.item.iItem >= 0) then - begin - Store := FALSE; - LV.EV.fOnLVData( LV, DI.item.iItem, DI.item.iSubItem, Txt, - DI.item.iImage, DWORD( DI.item.state ), Store ); - LV.fCaption := Txt; - DI.item.pszText := PKOL_Char( PKOLChar( LV.fCaption ) ); - if Store then - DI.item.mask := DI.item.mask or LVIF_DI_SETITEM; - end; - Result := TRUE; - end; - end; - end; - end; -end; - -procedure TControl.SetOnLVData(const Value: TOnLVData); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnLVData := Value; - AttachProc( @WndProc_LVData ); - Perform( LVM_SETCALLBACKMASK, LVIS_OVERLAYMASK or LVIS_STATEIMAGEMASK, 0 ); -end; - -{$IFDEF ENABLE_DEPRECATED} -{$DEFINE implementation} {$I KOL_deprecated.inc} {$UNDEF implementation} -{$ENDIF DISABLE_DEPRECATED} - -function WndProc_LVCustomDraw( Sender: PControl; var Msg: TMsg; - var Rslt: Integer ): Boolean; -var NMCustDraw: PNMLVCustomDraw; - NMHdr: PNMHdr; - ItemIdx, SubItemIdx: Integer; - S: TListViewItemState; - ItemState: TDrawState; -begin - Result := FALSE; - if Msg.message = WM_NOTIFY then - begin - NMHdr := Pointer( Msg.lParam ); - if (NMHdr.code = NM_CUSTOMDRAW) - {$IFDEF NIL_EVENTS} and Assigned( Sender.EV.fOnLVCustomDraw ) {$ENDIF} - then - begin - NMCustDraw := Pointer( Msg.lParam ); - ItemIdx := -1; - SubItemIdx := -1; - if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_ITEM ) then - ItemIdx := NMCustDraw.nmcd.dwItemSpec; - if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_SUBITEM ) then - SubItemIdx := NMCustDraw.iSubItem; - ItemState := [ ]; - if ItemIdx >= 0 then - begin - S := Sender.LVItemState[ ItemIdx ]; - if lvisFocus in S then - include( ItemState, odsFocused ); - if lvisSelect in S then - include( ItemState, odsSelected ); - if lvisBlend in S then - include( ItemState, odsGrayed ); - if lvisHighlight in S then - include( ItemState, odsMarked ); - end; - Rslt := Sender.EV.FOnLVCustomDraw( Sender, {Sender.fPaintDC} NMCustDraw.nmcd.hdc, - NMCustDraw.nmcd.dwDrawStage, ItemIdx, SubItemIdx, NMCustDraw.nmcd.rc, - ItemState, TColor( NMCustDraw.clrText ), TColor( NMCustDraw.clrTextBk ) ); - - Result := TRUE; - end; - end; -end; - -procedure TControl.SetOnLVCustomDraw(const Value: TOnLVCustomDraw); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnLVCustomDraw := Value; - AttachProc( @WndProc_LVCustomDraw ); -end; - -function CompareLVItems( Idx1, Idx2: Integer; ListView: PControl ): Integer; stdcall; -begin - {$IFDEF NIL_EVENTS} - if Assigned( ListView.EV.fOnCompareLVItems ) then - {$ENDIF} - Result := ListView.EV.fOnCompareLVItems( ListView, Idx1, Idx2 ) - {$IFDEF NIL_EVENTS} - else - Result := 0 - {$ENDIF} ; -end; - -procedure TControl.LVSort; -begin - Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVItems) ); -end; - -function CompareLVItemsData( D1, D2: DWORD; ListView: PControl ): Integer; stdcall; -begin - {$IFDEF NIL_EVENTS} - if Assigned( ListView.EV.fOnCompareLVItems ) then - {$ENDIF} - Result := ListView.EV.fOnCompareLVItems( ListView, D1, D2 ) - {$IFDEF NIL_EVENTS} - else - Result := 0 - {$ENDIF} ; -end; - -procedure TControl.LVSortData; -begin - Perform( LVM_SORTITEMS, Integer( @Self ), Integer( @CompareLVItemsData ) ); -end; - -function WndProc_LVColumnClick( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; -var Hdr: PNMHDR; - LV: PNMListView; -begin - Result := FALSE; - if Msg.message = WM_NOTIFY then - begin - Hdr := Pointer(Msg.lParam); - if Hdr.hwndFrom = Sender.Handle then - begin - LV := Pointer( Hdr ); - if Hdr.code = LVN_COLUMNCLICK then - begin - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnColumnClick ) then - {$ENDIF} - Sender.EV.fOnColumnClick( Sender, LV.iSubItem ); - Result := TRUE; - end; - end; - end; -end; - -procedure TControl.SetOnColumnClick(const Value: TOnLVColumnClick); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnColumnClick := Value; - AttachProc( @WndProc_LVColumnClick ); -end; - -function WndProc_LVStateChange( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean; -var NMOD: PNMLVODStateChange; - NMLV: PNMLISTVIEW; -begin - if Msg.message = WM_NOTIFY then - begin - NMOD := Pointer( Msg.lParam ); - NMLV := Pointer( Msg.lParam ); - if NMOD.hdr.code = LVN_ODSTATECHANGED then - begin - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnLVStateChange ) then - {$ENDIF} - Sender.EV.fOnLVStateChange( Sender, NMOD.iFrom, NMOD.iTo, - NMOD.uOldState, NMOD.uNewState ); - end - else - if NMLV.hdr.code = LVN_ITEMCHANGED then - begin - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnLVStateChange ) then - {$ENDIF} - Sender.EV.fOnLVStateChange( Sender, NMLV.iItem, NMLV.iItem, - NMLV.uOldState, NMLV.uNewState ); - end; - end; - Result := FALSE; -end; - -procedure TControl.SetOnLVStateChange(const Value: TOnLVStateChange); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .FOnLVStateChange := Value; - AttachProc( WndProc_LVStateChange ); -end; - -function CompareLVColumns( Idx1, Idx2: Integer; Sender: PControl ): Integer; stdcall; -var S1, S2: KOLString; -begin - //--- changed by Mike Gerasimov: - S1 := Sender.LVItems[ Idx1, Sender.DF.fColumn ]; - S2 := Sender.LVItems[ Idx2, Sender.DF.fColumn ]; - If lvoSortAscending in Sender.DF.fLVOptions Then - Result := AnsiCompareStrNoCase( S1, S2 ) - Else - If lvoSortDescending in Sender.DF.fLVOptions Then - Result := AnsiCompareStrNoCase( S2, S1 ) - Else - Result:=0; -end; - -procedure TControl.LVSortColumn(Idx: Integer); -begin - DF.fColumn := Idx; - Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVColumns) ); -end; - -function TControl.LVIndexOf(const S: KOLString): Integer; -begin - Result := LVSearchFor( S, -1, FALSE ); -end; - -function TControl.LVSearchFor(const S: KOLString; StartAfter: Integer; - Partial: Boolean): Integer; -var f: TLVFindInfo; -begin - f.lParam := 0; - f.flags := LVFI_STRING; - if Partial then - f.flags := LVFI_STRING or LVFI_PARTIAL; - f.psz := @s[1]; - result := Perform(LVM_FINDITEM,StartAfter,integer(@f)); -end; - -function WndProcLVMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var - pMI: PMeasureItemStruct; - P: PControl; - H: Integer; - wId: DWORD; - i: Integer; -begin - Result := FALSE; - if Msg.message = WM_MEASUREITEM then begin - pMI := Pointer(Msg.lParam); - with pMI^ do begin - for i:=0 to Sender.ChildCount-1 do begin - P := Sender.Children[i]; - if P <> nil then begin - wId := GetWindowLong(P.Handle,GWL_ID); - if CtlID = wId then begin - H := P.Perform(WM_MEASUREITEM,0,0); - if H > 0 then begin - itemHeight := H; - Rslt:=1; - Result := TRUE; - end; - break; - end; - end; - end; - end; - end; -end; - -function WndProcLVMeasureItem2( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := FALSE; - if (Msg.message = WM_MEASUREITEM) and (Msg.wParam = 0) then begin - Rslt := Sender.DF.fLVItemHeight; - Result := TRUE; - end; - -end; - -function TControl.SetLVItemHeight(Value: Integer): PControl; -begin - Set_LVItemHeight( Value ); - Result := @ Self; -end; - -procedure TControl.Set_LVItemHeight(Value: Integer); -begin - if DF.fLVItemHeight <> Value then - begin - if DF.fLVItemHeight = 0 then - begin - Parent.AttachProc(WndProcLVMeasureItem); - AttachProc(WndProcLVMeasureItem2); - end; - DF.fLVItemHeight := Value; - end; -end; - -function TControl.IndexOf(const S: KOLString): Integer; -begin - Result := SearchFor( S, -1, FALSE ); -end; - -function TControl.SearchFor(const S: KOLString; StartAfter: Integer; - Partial: Boolean): Integer; -var Cmd: Integer; - I: Integer; -begin - Cmd := fCommandActions.aFindItem; - if Partial then - Cmd := fCommandActions.aFindPartial; - if Cmd <> 0 then - Result := Perform( Cmd, StartAfter, Integer( PKOLChar( S ) ) ) - else - begin - Result := -1; - for I := StartAfter+1 to Count-1 do - begin - if Partial and ( Copy( Items[ I ], 1, Length( S ) ) = S ) or - ( Items[ I ] = S ) then - begin - Result := I; - break; - end; - end; - end; -end; - -{$UNDEF ASM_LOCAL} -{$IFDEF ASM_VERSION} - {$IFDEF USE_FLAGS} - {$IFDEF EVENTS_DYNAMIC} - //{$IFNDEF NIL_EVENTS} - {$IFNDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY} - {$DEFINE ASM_LOCAL} - {$ENDIF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY} - //{$ENDIF NIL_EVENTS} - {$ENDIF EVENTS_DYNAMIC} - {$ENDIF USE_FLAGS} -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_LOCAL} -function TControl.DefaultBtnProc(var Msg: TMsg; var Rslt: Integer): Boolean; -asm - PUSH EBX - PUSH ESI - PUSH EDI - PUSH ECX // save @Rslt - PUSH EDX // save Msg - MOV EBX, EDX // EBX = @ Msg - XCHG ESI, EAX // ESI = @ Self - MOV EAX, [ESI].TControl.EV - MOV EDI, [EAX].TEvents.fOldOnMessage.TMethod.Code - MOV EAX, [EAX].TEvents.fOldOnMessage.TMethod.Data - {$IFDEF NIL_EVENTS} - TEST EDI, EDI - JZ @@cont - {$ELSE} - {$ENDIF} - CALL EDI - TEST AL, AL - JNZ @@exit1 -@@cont: - CMP [AppletTerminated], AL - JNZ @@exit - MOV AX, word ptr [EBX].TMsg.message - //SUB AX, WM_KEYDOWN - DEC AH - CMP AX, WM_CHAR - WM_KEYDOWN - JA @@exit - XCHG EAX, EBX - MOV EBX, [EAX].TMsg.message - SHL EBX, 16 - MOV BL, byte ptr [EAX].TMsg.wParam - CMP BL, 13 - JE @@ok1327 - CMP BL, 27 - JNE @@exit -@@ok1327: - MOV EDI, [Applet] - TEST [EDI].TControl.fFlagsG3, 1 shl G3_IsForm - JNZ @@1 - MOV EDI, [EDI].DF.fCurrentControl -@@1: - TEST EDI, EDI - JZ @@exit - - PUSH EBP - XOR EBP, EBP // Btn := nil; - - MOV BH, 13 - MOV EDX, offset[DFLT_BTN] -@@findButton: - MOV EAX, EDI - CALL TControl.Get_Prop_Int - TEST EAX, EAX - JZ @@notFromProp - CMP BL, BH - JNZ @@notFromProp - MOV EBP, EAX - CALL TControl.GetToBeVisible - TEST AL, AL - JZ @@notFromProp - MOV EAX, EBP - CALL TControl.GetEnabled - TEST AL, AL - JZ @@notFromProp - CMP BL, 13 - JNZ @@yesFound - MOV ECX, [EDI].TControl.DF.fCurrentControl - JECXZ @@yesFound - TEST word ptr [ECX].TControl.fFlagsG5, (1 shl G6_CancelBtn) shl 8 or(1 shl G5_IgnoreDefault) - JZ @@yesFound - CMP EBP, ECX - JZ @@yesFound -@@notFromProp: - XOR EBP, EBP - CMP BL, 13 - JNZ @@notFound - MOV AL, [EDI].TControl.DF.fAllBtnReturnClick - OR AL, [ESI].TControl.DF.fAllBtnReturnClick - JZ @@notFound - MOV ECX, [EDI].DF.fCurrentControl - JECXZ @@notFound - MOV AL, [ECX].TControl.fFlagsG5 - AND AL, (1 shl G5_IsButton) or (1 shl G5_IsGroupbox) - CMP AL, (1 shl G5_IsButton) - JNZ @@notFound - MOV EBP, EAX - CALL TControl.GetToBeVisible - TEST AL, AL - JNZ @@yesFound -@@notFound: - XOR EBP, EBP -@@yesFound: - CMP BH, 13 - MOV BH, 27 - MOV EDX, offset[CNCL_BTN] - JNZ @@check_Found - TEST EBP, EBP - JZ @@findButton -@@check_Found: - MOV ECX, EBP - POP EBP - JECXZ @@exit - - MOV ESI, ECX - XCHG EAX, ECX - - SHR EBX, 16 - CMP BX, WM_KEYDOWN - JNZ @@doclick - - MOV DL, 1 - CALL TControl.SetFocused - -@@doclick: - POP EDI - POP EBX - - PUSH [EDI].TMsg.lParam - PUSH 32 - PUSH [EDI].TMsg.message - PUSH ESI - CALL TControl.Perform - - XOR EAX, EAX - AND [EDI].TMsg.wParam, EAX - AND [EBX], EAX - INC EAX - PUSH EAX - PUSH EAX - JMP @@exit1 - -@@exit: XOR EAX, EAX -@@exit1: - POP EDX - POP ECX - POP EDI - POP ESI - POP EBX -end; -{$ELSE PAS_VERSION} -function TControl.DefaultBtnProc(var Msg: TMsg; - var Rslt: Integer): Boolean; -var Btn: PControl; - F: PControl; - - procedure FindBtn( key: Word; s: PKOLChar; for_dflt: Boolean ); - var Ctl: PControl; - begin - Ctl := Pointer( F.PropInt[ s ] ); - if (Msg.wParam = key) and - (Ctl <> nil) and - Ctl.ToBeVisible and - Ctl.Enabled and - ( not for_dflt or - for_dflt and - ( (F.DF.fCurrentControl=nil) or - ({$IFDEF USE_FLAGS} not(G6_CancelBtn in F.DF.fCurrentControl.fFlagsG6) - {$ELSE} not F.DF.fCurrentControl.fCancelBtn {$ENDIF} and - {$IFDEF USE_FLAGS} not(G5_IgnoreDefault in F.DF.fCurrentControl.fFlagsG5) - {$ELSE} not F.DF.fCurrentControl.fIgnoreDefault {$ENDIF}) - or (F.DF.fCurrentControl = Ctl) - ) ) then - Btn := Ctl - else - if for_dflt - AND (Msg.wParam = VK_RETURN) and - (F.DF.fAllBtnReturnClick or DF.fAllBtnReturnClick) - and (F.ActiveControl <> nil) and - (F.ActiveControl.ToBeVisible) and - {$IFDEF USE_FLAGS} (G5_IsButton in F.ActiveControl.fFlagsG5) - and not(G5_IsGroupbox in F.ActiveControl.fFlagsG5) - {$ELSE} (F.ActiveControl.IsButton and not F.ActiveControl.fIsGroupbox) {$ENDIF} - {and (F.ActiveControl.Count = 0)} then - Btn := F.ActiveControl; - end; -begin - {$IFDEF NIL_EVENTS} - if Assigned( EV.fOldOnMessage ) then - {$ENDIF} - begin - Result := EV.fOldOnMessage( Msg, Rslt ); - if Result then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := FALSE; - if AppletTerminated then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - F := Applet; - if {$IFDEF USE_FLAGS} not(G3_IsForm in F.fFlagsG3) - {$ELSE} not F.fIsForm {$ENDIF} then - F := F.DF.fCurrentControl; - if F = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Btn := nil; - if //((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or (Msg.message = WM_CHAR)) and - ((Msg.message >= WM_KEYDOWN) and (Msg.message <= WM_CHAR)) and - ((Msg.wParam = VK_RETURN) or (Msg.wParam = VK_ESCAPE)) then - begin - FindBtn( VK_RETURN, @DFLT_BTN, TRUE ); - FindBtn( VK_ESCAPE, @CNCL_BTN, FALSE ); - if Btn <> nil then - begin - if Msg.message = WM_KEYDOWN then - begin - {$IFDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY} - {$IFDEF NIL_EVENTS} - if Assigned( Btn.EV.fOnClick ) then - {$ENDIF} - Btn.EV.fOnClick( Btn ); - {$ELSE} - Btn.Focused := TRUE; - {$ENDIF} - end; - {$IFDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY} - {$ELSE} - Btn.Perform( Msg.message, DWORD( ' ' ), Msg.lParam ); - {$ENDIF} - Msg.wParam := 0; - Result := TRUE; - Rslt := 0; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end - end; - Result := FALSE; -end; -{$ENDIF PAS_VERSION} - -{$UNDEF ASM_LOCAL} -{$IFDEF ASM_VERSION} - {$IFDEF USE_FLAGS} - {$IFNDEF DEFAULT_CANCEL_BTN_EXCLUSIVE} - {$IFDEF EVENTS_DYNAMIC} - {$DEFINE ASM_LOCAL} - {$ENDIF EVENTS_DYNAMIC} - {$ENDIF DEFAULT_CANCEL_BTN_EXCLUSIVE} - {$ENDIF USE_FLAGS} -{$ENDIF PAS_VERSION} - -{$IFDEF ASM_LOCAL} -procedure TControl.SetDefaultBtn(const Index: Integer; - const Value: Boolean); -asm - PUSH EBX - PUSH EDI - PUSH ESI - MOV BL, DL // index - MOV BH, CL // value - MOV ESI, EAX // @Self - ADD ECX, ECX // DL = 2 - CMP BL, 13 - JZ @@1 - CMP BL, 27 - JNZ @@2 - ADD ECX, ECX // DL := Index = 13 ? 2 : 4 -@@1: CMP BH, 0 - JNZ @@set_flag - NOT CL - AND [ESI].fFlagsG6, CL - MOV CL, 0 -@@set_flag: - OR [ESI].fFlagsG6, CL -@@2: - CMP [Applet], 0 - JZ @@exit - CALL TControl.ParentForm - TEST EAX, EAX - JZ @@exit - - XCHG EDI, EAX // EDI = ParentForm - MOV AL, BH - SHR EAX, 1 - SBB ECX, ECX - AND ECX, ESI // ECX = Value ? @ Self : 0 - MOV EDX, offset[DFLT_BTN] - CMP BL, 13 - JZ @@3 - MOV EDX, offset[CNCL_BTN] -@@3: - XCHG EAX, EDI - CALL TControl.Set_Prop_Int - - {$IFnDEF NO_DEFAULT_BUTTON_BOLD} - XCHG EAX, ESI //---- больше @Self не нужен - MOV EDX, [EAX].TControl.fStyle - AND DL, not BS_DEFPUSHBUTTON //---- BS_DEFPUSHBUTTON = 1, BH = Value = 1 : 0 - OR DL, BH - CALL TControl.SetStyle - {$ENDIF} - - TEST BH, BH - MOV ESI, [Applet] // ESI = Applet - MOV EBX, [ESI].TControl.EV - JZ @@notValue - - MOV EDX, [EBX].TEvents.fOnMessage.TMethod.Code - CMP EDX, offset[TControl.DefaultBtnProc] - JZ @@setDefaultBtnProc - - MOV [EBX].TEvents.fOldOnMessage.TMethod.Code, EDX - MOV EDX, [EBX].TEvents.fOnMessage.TMethod.Data - MOV [EBX].TEvents.fOldOnMessage.TMethod.Data, EDX - -@@setDefaultBtnProc: - MOV [EBX].TEvents.fOnMessage.TMethod.Code, offset[TControl.DefaultBtnProc] - MOV [EBX].TEvents.fOnMessage.TMethod.Data, ESI - JMP @@exit - -@@notValue: - LEA ESI, [EBX].TEvents.fOldOnMessage - LEA EDI, [EBX].TEvents.fOnMessage - MOVSD - MOVSD - MOV [EBX].TEvents.fOldOnMessage.TMethod.Code, offset[DummyProc123_0] - -@@exit: POP ESI - POP EDI - POP EBX -end; -{$ELSE notASM_VERSION} -procedure TControl.SetDefaultBtn(const Index: Integer; - const Value: Boolean); -var F, C: PControl; -begin - if Index = 13 then - begin - {$IFDEF USE_FLAGS} if Value - then include( fFlagsG6, G6_DefaultBtn ) - else exclude( fFlagsG6, G6_DefaultBtn ); - {$ELSE} fDefaultBtn := Value; {$ENDIF} - {$IFDEF DEFAULT_CANCEL_BTN_EXCLUSIVE} - {$IFDEF USE_FLAGS} Exclude( fFlagsG6, G6_CancelBtn ); - {$ELSE} fCancelBtn := FALSE; {$ENDIF} - {$ENDIF} - end else - if Index = 27 then // this check is necessary still could be Index = 0 to reset both ! - begin - {$IFDEF USE_FLAGS} if Value - then include( fFlagsG6, G6_CancelBtn ) - else exclude( fFlagsG6, G6_CancelBtn ); - {$ELSE} fCancelBtn := Value; {$ENDIF} - - {$IFDEF DEFAULT_CANCEL_BTN_EXCLUSIVE} - {$IFDEF USE_FLAGS} Exclude( fFlagsG6, G6_DefaultBtn ); - {$ELSE} fDefaultBtn := FALSE; {$ENDIF} - {$ENDIF} - end; - if Applet = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - F := ParentForm; - if F <> nil then - begin - C := nil; - if Value then C := @ Self; - if Index = 13 then - begin - F.PropInt[ @DFLT_BTN ] := Integer( C ); - {$IFDEF NO_DEFAULT_BUTTON_BOLD} - {$ELSE} - if Value then - Style := fStyle.Value or BS_DEFPUSHBUTTON - else - Style := fStyle.Value and not BS_DEFPUSHBUTTON; - {$ENDIF} - end - else if Index = 27 then - F.PropInt[ @CNCL_BTN ] := Integer( C ); - - if Value then - begin - if @ Applet.EV.fOnMessage <> @ TControl.DefaultBtnProc then - Applet.EV.fOldOnMessage := Applet.EV.fOnMessage; // fixed by YS - Applet.EV.fOnMessage := Applet.DefaultBtnProc; - end else - begin - Applet.EV.fOnMessage := Applet.EV.fOldOnMessage; - Applet.EV.fOldOnMessage := - {$IFDEF SAFEST_CODE} TOnMessage( MakeMethod( nil, @ DummyProc123_0 ) ) - {$ELSE} nil {$ENDIF}; - end; - end; -end; -{$ENDIF PAS_VERSION} - -function TControl.GetDefaultBtn(const Index: Integer): Boolean; -begin - CASE Index OF - 13 : Result := {$IFDEF USE_FLAGS} G6_DefaultBtn in fFlagsG6 - {$ELSE} fDefaultBtn {$ENDIF}; - else Result := {$IFDEF USE_FLAGS} G6_CancelBtn in fFlagsG6 - {$ELSE} fCancelBtn {$ENDIF}; - END; -end; - -function TControl.AllBtnReturnClick: PControl; -{$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} -begin - // nothing: already implemented in WndProcBtnReturnClick - Result := @ Self; -end; -{$ELSE} -var F: PControl; -begin - {$IFDEF SAFE_CODE} - if {$IFDEF USE_FLAGS} [G3_IsForm, G3_IsApplet] * fFlagsG3 <> [] - {$ELSE} fIsForm or fIsApplet {$ENDIF} then - {$ENDIF} - begin - SetDefaultBtn( 0, TRUE ); - F := ParentForm; - if F <> nil then - F.DF.fAllBtnReturnClick := TRUE; - end; - Result := @ Self; -end; -{$ENDIF} - -function WndProc_CNDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; -type PDrawAction = ^TDrawAction; - PDrawState = ^TDrawState; -var DI: PDrawItemStruct; -begin - Result := FALSE; - if Msg.message = CN_DRAWITEM then - begin - DI := Pointer( Msg.lParam ); - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.fOnDrawItem ) then - {$ENDIF} - begin - if Sender.EV.fOnDrawItem( Sender, DI.hDC, DI.rcItem, DI.itemID, - PDrawAction( @ DI.itemAction )^, - PDrawState( @ DI.itemState )^ ) - then Rslt := 1 - else Rslt := 0; - Result := TRUE; - end - {$IFDEF NIL_EVENTS} - else Rslt := 0 - {$ENDIF} - ; - end; -end; - -procedure TControl.SetOnDrawItem(const Value: TOnDrawItem); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnDrawItem := Value; - if Parent <> nil then - Parent.AttachProc( @WndProc_DrawItem ); - AttachProc( @WndProc_CNDrawItem ); -end; - -function WndProc_MeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ) - : Boolean; -var MI: PMeasureItemStruct; - Control: PControl; - I: Integer; -begin - Result := FALSE; - if Msg.message = WM_MEASUREITEM then - begin - MI := Pointer( Msg.lParam ); - for I := 0 to Sender.ChildCount - 1 do - begin - Control := Sender.Children[ I ]; - if Control.Menu = MI.CtlID then - begin - {$IFDEF NIL_EVENTS} - if Assigned( Control.EV.fOnMeasureItem ) then - {$ENDIF} - begin - MI.itemHeight := Control.EV.fOnMeasureItem( Control, MI.itemID ); - if MI.itemHeight > 0 then - begin - Rslt := 1; - Result := TRUE; - end; - end; - break; - end; - end; - end; -end; - -procedure TControl.SetOnMeasureItem(const Value: TOnMeasureItem); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnMeasureItem := Value; - if Parent <> nil then - Parent.AttachProc( @WndProc_MeasureItem ); -end; - -function TControl.GetItemData(Idx: Integer): DWORD; -begin - Result := 0; - if fCommandActions.aGetItemData <> 0 then - Result := Perform( fCommandActions.aGetItemData, Idx, 0 ); -end; - -procedure TControl.SetItemData(Idx: Integer; const Value: DWORD); -begin - if fCommandActions.aSetItemData <> 0 then - Perform( fCommandActions.aSetItemData, Idx, Value ); -end; - -function TControl.GetLVCurItem: Integer; -begin - Result := Perform( LVM_GETNEXTITEM, -1, LVNI_SELECTED ); -end; - -procedure TControl.SetLVCurItem(const Value: Integer); -begin - if (lvoMultiselect in LVOptions) or (Value <> LVCurItem ) then - LVItemState[ -1 ] := [ ]; - if Value >= 0 then - LVItemState[ Value ] := [ lvisSelect, lvisFocus ]; -end; - -function TControl.LVNextItem(IdxPrev: Integer; Attrs: DWORD): Integer; -begin - Result := Perform( LVM_GETNEXTITEM, IdxPrev, Attrs ); -end; - -function TControl.LVNextSelected(IdxPrev: Integer): Integer; -begin - Result := Perform( LVM_GETNEXTITEM, IdxPrev, LVNI_SELECTED ); -end; - -function TControl.GetLVFocusItem: Integer; -begin - Result := Perform( LVM_GETNEXTITEM, -1, LVNI_FOCUSED ); -end; - -procedure TControl.Close; -begin - PostMessage( Handle, WM_CLOSE, 0, 0 ); -end; - -function WndProcMinimize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Wnd: PControl; -begin - Result := FALSE; - if (Msg.message = WM_SYSCOMMAND) and ((Msg.wParam and $FFF0) = SC_MINIMIZE)then - begin - if Applet <> nil then - begin - Wnd := Pointer( Applet.PropInt[ @MIN_WND ] ); // fMinimizeWnd; - if Wnd <> nil then - SetWindowPos( Applet.Handle, 0, Wnd.Left, Wnd.Top, Wnd.Width, 0, - SWP_NOZORDER or SWP_NOREDRAW); - end; - end; -end; - -function WndProcRestore( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := FALSE; - CASE Msg.message OF - WM_SHOWWINDOW: - begin - case Msg.lParam of - SW_PARENTCLOSING: - begin - if IsIconic( Self_.fHandle ) then - Self_.DF.fShowAction := SW_SHOWMINNOACTIVE - else - if IsZoomed( Self_.fHandle ) then - Self_.DF.fShowAction := SW_SHOWMAXIMIZED - else - Self_.DF.fShowAction := SW_SHOWNOACTIVATE; - end; - SW_PARENTOPENING: - begin - if Self_.DF.fShowAction <> 0 then - begin - ShowWindow( Self_.fHandle, Self_.DF.fShowAction ); - Self_.DF.fShowAction := 0; - end; - Rslt := 0; - end; - end; - end; - END; -end; - -procedure TControl.MinimizeNormalAnimated; -var App: PControl; -begin - App := Applet; - if App = nil then - App := @Self; - App.PropInt[ @MIN_WND ] // fMinimizeWnd - := Integer( @Self ); - App.AttachProc( @WndProcMinimize ); - AttachProc( @WndProcRestore ); -end; - -procedure TControl.RestoreNormalMaximized; -begin - AttachProc( @WndProcRestore ); -end; - -function WndProcDropFiles( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var hDrop: THandle; - Pt: TPoint; - FList: KOLString; - I, N: Integer; - Buf: array[ 0..MAX_PATH ] of KOLChar; -begin - if Msg.message = WM_DROPFILES then - if TMethod(Sender.EV.fOnDropFiles).Code <> nil then - begin - hDrop := Msg.wParam; - DragQueryPoint( hDrop, Pt ); - N := DragQueryFile( hDrop, $FFFFffff, nil, 0 ); - FList := ''; - for I := 0 to N-1 do - begin - if FList <> '' then - FList := FList + #13; - DragQueryFile( hDrop, I, Buf, Sizeof( Buf ) ); - FList := FList + KOLString(Buf); - end; - DragFinish( hDrop ); - Sender.EV.FOnDropFiles( Sender, FList, Pt ); - Rslt := 0; - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - Result := FALSE; -end; - -procedure TControl.SetOnDropFiles(const Value: TOnDropFiles); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .FOnDropFiles := Value; - AttachProc( @WndProcDropFiles ); - DragAcceptFiles( GetWindowHandle, Assigned( Value ) ); -end; - -function WndProcShowHide( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var IsVisible: Boolean; -begin - if Msg.message = WM_SHOWWINDOW then - if Msg.hwnd = Sender.Handle then - begin - IsVisible := IsWindowVisible( Sender.Handle ); - if LongBool( Msg.wParam ) then - begin - {$IFDEF USE_FLAGS} include( Sender.fStyle.f3_Style, F3_Visible ); - {$ELSE} Sender.fVisible := TRUE; {$ENDIF} - if not IsVisible then - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.FOnShow ) then - {$ENDIF} - Sender.EV.FOnShow( Sender ); - end else - begin - {$IFDEF USE_FLAGS} exclude( Sender.fStyle.f3_Style, F3_Visible ); - {$ELSE} Sender.fVisible := FALSE; {$ENDIF} - if IsVisible then - {$IFDEF NIL_EVENTS} - if Assigned( Sender.EV.FOnHide ) then - {$ENDIF} - Sender.EV.FOnHide( Sender ); - end; - end; - Sender.UpdateWndStyles; - Result := FALSE; -end; - -procedure TControl.SetOnHide(const Value: TOnEvent); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .FOnHide := Value; - AttachProc( WndProcShowHide ); -end; - -procedure TControl.SetOnShow(const Value: TOnEvent); -begin - {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .FOnShow := Value; - AttachProc( WndProcShowHide ); -end; - -function TControl.BringToFront: PControl; -begin - SetWindowPos( GetWindowHandle, HWND_TOP, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or - SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_SHOWWINDOW ); - Result := @Self; -end; - -function TControl.SendToBack: PControl; -begin - SetWindowPos( GetWindowHandle, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or - SWP_NOACTIVATE or SWP_NOOWNERZORDER ); - Result := @Self; -end; - -procedure TControl.DragStart; -begin - PostMessage( GetWindowHandle, WM_SYSCOMMAND, $F012, 0 ); -end; - -function WndProcDragWindow( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var P: TPoint; - Delta: DWORD; - dX, dY: Integer; -begin - if Msg.message = WM_MOUSEMOVE then - begin - if {$IFDEF USE_FLAGS} G6_Dragging in Sender.fFlagsG6 - {$ELSE} Sender.FDragging {$ENDIF} then - begin - GetCursorPos( P ); - Delta := Sender.PropInt[ @DRAG_XY ]; - dX := SmallInt( LoWord( Delta ) ); - dY := SmallInt( HiWord( Delta ) ); - P.x := P.x + dX; // - Sender.fMouseStartPos.x + Sender.fDragStartPos.x; - P.y := P.y + dY; // - Sender.fMouseStartPos.y + Sender.fDragStartPos.y; - Sender.Position := P; - end; - end; - Result := FALSE; -end; - -procedure TControl.DragStartEx; -var StartBounds: TRect; - MSP: TPoint; - dX, dY: Integer; - Delta: Integer; -begin - {$IFNDEF SMALLEST_CODE} - if {$IFDEF USE_FLAGS} G6_Dragging in fFlagsG6 - {$ELSE} fDragging {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - {$ENDIF} - GetCursorPos( MSP ); - StartBounds := BoundsRect; - dX := StartBounds.Left - MSP.X; - dY := StartBounds.Top - MSP.Y; - Delta := (dX and $FFFF) or (dY shl 16); - PropInt[ @DRAG_XY ] := Delta; - SetCapture( GetWindowHandle ); - {$IFDEF USE_FLAGS} include( fFlagsG6, G6_Dragging ); - {$ELSE} fDragging := TRUE; {$ENDIF} - AttachProc( WndProcDragWindow ); -end; - -procedure TControl.DragStopEx; -begin - if {$IFDEF USE_FLAGS} G6_Dragging in fFlagsG6 - {$ELSE} FDragging {$ENDIF} then - begin - ReleaseCapture; - {$IFDEF USE_FLAGS} exclude( fFlagsG6, G6_Dragging ); - {$ELSE} FDragging := FALSE; {$ENDIF} - end; -end; - -function CallDragCallBack( Sender: PControl; var Stop: Boolean ): Boolean; -var P: TPoint; - Shape, ShapeWas: Integer; -begin - Sender.AttachProc( WndProcSetCursor ); - GetCursorPos( P ); - Shape := LoadCursor( 0, PKOLChar(IDC_HAND) ); - ShapeWas := Shape; - Result := Sender.EV.fDragCallback( Sender, P.x, P.y, Shape, Stop ); - if not Stop then - begin - if not Result then - if Shape = ShapeWas then - Shape := LoadCursor( 0, IDC_NO ); - ScreenCursor := Shape; - end - else - begin - ScreenCursor := 0; - Shape := Sender.fCursor; - end; - Windows.SetCursor( Shape ); -end; - -function WndProcDrag( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Stop: Boolean; -begin - if {$IFDEF USE_FLAGS} G6_Dragging in Sender.fFlagsG6 - {$ELSE} Sender.fDragging {$ENDIF} then - begin - Stop := FALSE; - case Msg.message of - WM_MOUSEMOVE: - CallDragCallBack( Sender, Stop ); - WM_LBUTTONUP, WM_RBUTTONUP: - begin - Stop := TRUE; - CallDragCallBack( Sender, Stop ); - end; - else Result := FALSE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - if Stop then - begin - ReleaseCapture; - {$IFDEF USE_FLAGS} exclude( Sender.fFlagsG6, G6_Dragging ); - {$ELSE} Sender.fDragging := FALSE; {$ENDIF} - end else - begin - Result := TRUE; exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - Result := FALSE; -end; - -procedure TControl.DragItem(OnDrag: TOnDrag); -begin - EV.fDragCallback := OnDrag; - {$IFDEF USE_FLAGS} include( fFlagsG6, G6_Dragging ); - {$ELSE} fDragging := TRUE; {$ENDIF} - SetCapture( GetWindowHandle ); - AttachProc( WndProcDrag ); -end; - -{$IFDEF USE_CONSTRUCTORS} //****************************************************// - // -constructor TControl.CreateWindowed(AParent: PControl; AClassName: PKOLChar; // - ACtl3D: Boolean); // -begin // - CreateParented( AParent ); // - fOnDynHandlers := WndProcDummy; // - fWndProcKeybd := WndProcDummy; // - //{-2.95}//fWndProcResizeFlicks := WndProcDummy; // - fCommandActions.aClear := ClearText; // - //fWindowed := True; // is set in TControl.Init - fControlClassName := AClassName; // - // - fControlClick := DummyObjProc; // - // - fColor := clBtnFace; // - fTextColor := clWindowText; // - fMargin := 2; // - fCtl3D := True; // - fCtl3Dchild := True; // - if AParent <> nil then // - begin // - //{-2.95}//fWndProcResizeFlicks := AParent.fWndProcResizeFlicks; // - fGotoControl := AParent.fGotoControl; // - {$IFDEF USE_FLAGS} - exc fFlagsG2 := fFlagsG2 - [G2_DoubleBuffered, G2_Transparent] + - (AParent.fFlagsG2 * [G2_DoubleBuffered, G2_Transparent]); - {$ELSE} fDoubleBuffered := AParent.fDoubleBuffered; - fTransparent := AParent.fTransparent; // - {$ENDIF} - fCtl3Dchild := AParent.fCtl3Dchild; // - if AParent.fCtl3Dchild then // - fCtl3D := ACtl3D // - else fCtl3D := False; // - fMargin := AParent.fMargin; // - with fBoundsRect do // - begin // - Left := AParent.fMargin + AParent.fClientLeft; // - Top := AParent.fMargin + AParent.fClientTop; // - Right := Left + 64; // - Bottom := Top + 64; // - end; // - fTextColor := AParent.fTextColor; // - fFont := fFont.Assign( AParent.fFont ); // - if fFont <> nil then // - begin // - fFont.fOnGTChange := FontChanged; // - FontChanged( fFont ); // - end; // - fColor := AParent.fColor; // - fBrush := fBrush.Assign( AParent.fBrush ); // - if fBrush <> nil then // - begin // - fBrush.fOnGTChange := BrushChanged; // - BrushChanged( fBrush ); // - end; // - end; // -end; // - // -constructor TControl.CreateApplet(const ACaption: AnsiString); // -begin // - AppButtonUsed := True; // - CreateWindowed( nil, 'App', TRUE ); // - {$IFDEF USE_FLAGS} include( fFlagsG3, G3_IsApplet ); - {$ELSE} FIsApplet := TRUE; {$ENDIF} - fStyle := WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX // - or WS_CAPTION; // - fExStyle := WS_EX_APPWINDOW; // - FCreateWndExt := CreateAppButton; // - AttachProc( WndProcApp ); // - Caption := ACaption; // -end; // - // -constructor TControl.CreateForm(AParent: PControl; const ACaption: AnsiString); // -begin // - CreateWindowed( AParent, 'Form', TRUE ); // - AttachProc( WndProcForm ); // - AttachProc( WndProcDoEraseBkgnd ); // - Caption := ACaption; // -end; // - // -constructor TControl.CreateControl(AParent: PControl; AClassName: PAnsiChar; // - AStyle: DWORD; ACtl3D: Boolean; Actions: PCommandActions); // -var Form: PControl; // -begin // - CreateWindowed( AParent, AClassName, ACtl3D ); // - if Actions <> nil then // - fCommandActions := Actions^; // - fIsControl := True; // - fStyle := AStyle or WS_CLIPSIBLINGS or WS_CLIPCHILDREN; // - fVisible := (Style and WS_VISIBLE) <> 0; // - fTabstop := (Style and WS_TABSTOP) <> 0; // - if (AParent <> nil) then // - begin // - Inc( AParent.ParentForm.fTabOrder ); // - fTabOrder := AParent.ParentForm.fTabOrder; // - end; // - fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ]; // - if fCtl3D then // - begin // - fStyle := fStyle and not WS_BORDER; // - fExStyle := fExStyle or WS_EX_CLIENTEDGE; // - end; // - if (Style and WS_TABSTOP) <> 0 then // - begin // - Form := ParentForm; // - if Form <> nil then // - if Form.FCurrentControl = nil then // - Form.FCurrentControl := @Self; // - end; // - //fCreateParamsExt := CreateParams2; // - fMenu := CtlIdCount; // - Inc( CtlIdCount ); // - AttachProc( WndProcCtrl ); // -end; // - // -constructor TControl.CreateButton(AParent: PControl; // - const ACaption: AnsiString); // -begin // - CreateControl( AParent, 'BUTTON', // - WS_VISIBLE or WS_CHILD or // - BS_PUSHLIKE or WS_TABSTOP, False, @ButtonActions ); // - with fBoundsRect do // - Bottom := Top + 22; // - fTextAlign := taCenter; // - Caption := ACaption; // -end; // - // -constructor TControl.CreateBitBtn(AParent: PControl; // - const ACaption: AnsiString; AOptions: TBitBtnOptions; ALayout: TGlyphLayout; // - AGlyphBitmap: HBitmap; AGlyphCount: Integer); // -var // - B: TBitmapInfo; // - W, H: Integer; // -begin // - CreateControl( AParent, 'BUTTON', WS_VISIBLE or WS_CHILD or // - WS_TABSTOP or BS_OWNERDRAW, False, @ButtonActions ); // - fBitBtnOptions := AOptions; // - fGlyphLayout := ALayout; // - fGlyphBitmap := AGlyphBitmap; // - with fBoundsRect do // - begin // - Bottom := Top + 22; // - W := 0; H := 0; // - if AGlyphBitmap <> 0 then // - begin // - if bboImageList in AOptions then // - ImageList_GetIconSize( AGlyphBitmap, W, H ) // - else // - begin // - if GetObject( AGlyphBitmap, Sizeof(B), @B ) > 0 then // - begin // - W := B.bmiHeader.biWidth; // - H := B.bmiHeader.biHeight; // - if AGlyphCount = 0 then // - AGlyphCount := W div H; // - if AGlyphCount > 1 then // - W := W div AGlyphCount; // - end; // - end; // - if W > 0 then // - if ACaption = '' then // - Right := Left + W // - else Right := Right + W; // - if H > 0 then // - Bottom := Top + H; // - if not ( bboNoBorder in AOptions ) then // - begin // - if W > 0 then Inc( Right, 2 ); // - if H > 0 then Inc( Bottom, 2 ); // - end; // - end; // - fGlyphWidth := W; // - fGlyphHeight := H; // - end; // - fGlyphCount := AGlyphCount; // - if AParent <> nil then // - AParent.AttachProc( WndProc_DrawItem ); // - AttachProc( WndProcBitBtn ); // - fTextAlign := taCenter; // - Caption := ACaption; // -end; // - // -constructor TControl.CreateLabel(AParent: PControl; // - const ACaption: AnsiString); // -begin // - CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or // - SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, // - False, @LabelActions ); - aAutoSzX := 1; - aAutoSzY := 1; - {$IFDEF USE_FLAGS} fFlagsG1 := fFlagsG1 + [G1_SizeRedraw, G1_IsStaticControl]; - {$ELSE} fSizeRedraw := True; - fIsStaticControl := 1; // - {$ENDIF} // - fBoundsRect.Bottom := fBoundsRect.Top + 22; // - Caption := ACaption; // -end; // - // -constructor TControl.CreateWordWrapLabel(AParent: PControl; // - const ACaption: AnsiString); // -begin // - CreateLabel( AParent, ACaption ); // - fBoundsRect.Bottom := fBoundsRect.Top + 44; // - fStyle := fStyle and not SS_LEFTNOWORDWRAP; // -end; // - // -constructor TControl.CreateLabelEffect(AParent: PControl; ACaption: AnsiString; // - AShadowDeep: Integer); // -begin // - CreateLabel( AParent, ACaption ); // - {$IFDEF USE_FLAGS} exclude( fFlagsG1, G1_IsStaticControl ); - {$ELSE} fIsStaticControl := 0; {$ENDIF} - AttachProc( WndProcLabelEffect ); // - fTextAlign := taCenter; // - fTextColor := clBtnShadow; // - fShadowDeep := AShadowDeep; // - {$IFDEF USE_FLAGS} include( fFlagsG1, G1_IgnoreWndCaption ); - {$ELSE} fIgnoreWndCaption := True; {$ENDIF} // - with fBoundsRect do // - begin // - Bottom := Top + 40; // - end; // -end; // - // -constructor TControl.CreatePaintBox(AParent: PControl); // -begin // - CreateLabel( AParent, '' ); // - with fBoundsRect do // - begin // - Right := Left + 40; // - Bottom := Top + 40; // - end; // -end; // - // -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal // -constructor TControl.CreateGradientPanel(AParent: PControl; AColor1, // - AColor2: TColor); // -begin // - CreateLabel( AParent, '' ); // - AttachProc( WndProcGradient ); // - fColor2 := AColor2; // - fColor1 := AColor1; // - with fBoundsRect do // - begin // - Right := Left + 40; // - Bottom := Top + 40; // - end; // -end; // -{$ENDIF PAS_VERSION} // - // -constructor TControl.CreateGradientPanelEx(AParent: PControl; AColor1, // - AColor2: TColor; AStyle: TGradientStyle; ALayout: TGradientLayout); // -begin // - CreateLabel( AParent, '' ); // - AttachProc( WndProcGradientEx ); // - fColor2 := AColor2; // - fColor1 := AColor1; // - fGradientStyle := AStyle; // - fGradientLayout := ALayout; // - with fBoundsRect do // - begin // - Right := Left + 40; // - Bottom := Top + 40; // - end; // -end; // - // -constructor TControl.CreateGroupbox(AParent: PControl; // - const ACaption: AnsiString); // -begin // - CreateButton( AParent, ACaption ); // - with fBoundsRect do // - begin // - Right := Left + 100; // - Bottom := Top + 100; // - end; // - fStyle := WS_VISIBLE or WS_CHILD or BS_GROUPBOX or WS_TABSTOP; // - fClientTop := 22; // - fClientLeft := 2; // - fClientBottom := 2; // - fClientRight := 2; // - fTabstop := False; // -end; // - // -constructor TControl.CreateCheckbox(AParent: PControl; // - const ACaption: AnsiString); // -begin // - CreateButton( AParent, ACaption ); // - with fBoundsRect do // - begin // - Right := Left + 72; // - end; // - fStyle := WS_VISIBLE or WS_CHILD or // - BS_AUTOCHECKBOX or WS_TABSTOP; // -end; // - // -constructor TControl.CreateRadiobox(AParent: PControl; // - const ACaption: AnsiString); // -begin // - CreateCheckbox( AParent, ACaption ); // - fStyle := WS_VISIBLE or WS_CHILD or // - BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP; // - fControlClick := ClickRadio; // - if AParent <> nil then // - begin // - AParent.fRadioLast := fMenu; // - if AParent.fRadio1st = 0 then // - begin // - AParent.fRadio1st := fMenu; // - SetRadioChecked; // - end; // - end; // -end; // - // -constructor TControl.CreateEditbox(AParent: PControl; // - AOptions: TEditOptions); // -var Flags: Integer; // -begin // - Flags := MakeFlags( @AOptions, EditFlags ); // - if not(eoMultiline in AOptions) then // - Flags := Flags and not(WS_HSCROLL or WS_VSCROLL); // - CreateControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP // - or WS_BORDER or Flags, True, @EditActions ); // - aAutoSzY := 6; -//YS fCursor := LoadCursor( 0, IDC_IBEAM ); // //YS - with fBoundsRect do // - begin // - Right := Left + 100; // - Bottom := Top + 22; // - if eoMultiline in AOptions then // - begin // - Right := Right + 100; // - Bottom := Top + 200; // - end; // - end; // - fColor := clWindow; // - fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ]; // - if eoMultiline in AOptions then // - fLookTabKeys := [ tkTab ]; // - if eoWantTab in AOptions then // - exclude( fLookTabKeys, tkTab ); -end; // - // -constructor TControl.CreatePanel(AParent: PControl; AStyle: TEdgeStyle); // -begin // - CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or // - SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, False, // - @LabelActions ); - aAutoSzX := 1; - aAutoSzY := 1; - with fBoundsRect do // - begin // - Right := Left + 100; // - Bottom := Top + 100; // - end; // - Style := Style or Edgestyles[ AStyle ]; // - ExStyle := ExStyle or WS_EX_CONTROLPARENT; // -end; // - // -constructor TControl.CreateSplitter(AParent: PControl; AMinSizePrev, // - AMinSizeNext: Integer; EdgeStyle: TEdgeStyle); // -var PrevCtrl: PControl; // - Sz0: Integer; // -begin // - CreatePanel( AParent, EdgeStyle ); // - fSplitMinSize1 := AMinSizePrev; // - fSplitMinSize2 := AMinSizeNext; // - Sz0 := 4; // - with fBoundsRect do // - begin // - Right := Left + Sz0; // - Bottom := Top + Sz0; // - end; // - if AParent <> nil then // - begin // - if AParent.fChildren.fCount > 1 then // - begin // - PrevCtrl := AParent.fChildren.{$IFDEF TLIST_FAST} Items {$ELSE} fItems {$ENDIF}[ AParent.fChildren.fCount - 2 ]; // - case PrevCtrl.FAlign of // - caLeft, caRight: // - begin // - fCursor := LoadCursor( 0, IDC_SIZEWE ); // - end; // - caTop, caBottom: // - begin // - fCursor := LoadCursor( 0, IDC_SIZENS ); // - end; // - end; // - Align := PrevCtrl.FAlign; // - end; // - end; // - AttachProc( WndProcSplitter ); // -end; // - // -constructor TControl.CreateListbox(AParent: PControl; // - AOptions: TListOptions); // -var Flags: Integer; // -begin // - Flags := MakeFlags( @AOptions, ListFlags ); // - CreateControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP // - or WS_BORDER or WS_VSCROLL // - or LBS_NOTIFY or Flags, True, @ListActions ); // - with fBoundsRect do // - begin // - Right := Right + 100; // - Bottom := Top + 200; // - end; // - fColor := clWindow; // - fLookTabKeys := [ tkTab, tkLeftRight ]; // -end; // - // -constructor TControl.CreateCombobox(AParent: PControl; // - AOptions: TComboOptions); // -var Flags: Integer; // -begin // - Flags := MakeFlags( @AOptions, ComboFlags ); // - CreateControl( AParent, 'COMBOBOX', // - WS_VISIBLE or WS_CHILD or WS_VSCROLL or // - CBS_DROPDOWN or CBS_HASSTRINGS or WS_TABSTOP or Flags, // - True, @ComboActions ); // - aAutoSzY := 6; - fCreateWndExt := CreateComboboxWnd; // - //fDropDownProc := ComboboxDropDown; // - fClsStyle := fClsStyle or CS_DBLCLKS; // - with fBoundsRect do // - begin // - Right := Left + 100; // - Bottom := Top + 22; // - end; // - fColor := clWindow; // - fLookTabKeys := [ tkTab ]; // - if coReadOnly in AOptions then // - fLookTabKeys := [ tkTab, tkLeftRight ]; // -end; // - // -constructor TControl.CreateCommonControl(AParent: PControl; // - AClassName: PAnsiChar; AStyle: DWORD; ACtl3D: Boolean; // - Actions: PCommandActions); // -begin // - {*************} DoInitCommonControls( ICC_WIN95_CLASSES ); // - CreateControl( AParent, AClassName, AStyle, ACtl3D, Actions ); // - {$IFDEF USE_FLAGS} include( fFlagsG2, G2_IsCommonCtl ); - {$ELSE} fIsCommonControl := True; {$ENDIF} - if AParent <> nil then // - begin // - AttachProc( WndProcParentResize ); // - AParent.AttachProc( WndProcResize ); // - AttachProc( WndProcCommonNotify ); // - AParent.AttachProc( WndProcNotify ); // - end; // -end; // - // -constructor TControl.CreateRichEdit1(AParent: PControl; // - AOptions: TEditOptions); // -var Flags, I: Integer; // -begin // - if FRichEditModule = 0 then // - begin // - for I := 0 to High( RichEditLibnames ) do // - begin // - FRichEditModule := LoadLibrary( RichEditLibnames[ I ] ); // - if FRichEditModule > HINSTANCE_ERROR then break; // - RichEditClass := RichEditClasses[ I ]; // - end; // - if FRichEditModule <= HINSTANCE_ERROR then // - FRichEditModule := 0; // - end; // - Flags := MakeFlags( @AOptions, RichEditFlags ); // - CreateCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD // - or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags, // - True, @RichEditActions ); // - // - AttachProc( WndProcRichEditNotify ); // - {$IFDEF USE_FLAGS} exclude( fFlagsG2, G2_DoubleBuffered ); - {$ELSE} fDoubleBuffered := False; {$ENDIF} - {$IFDEF USE_FLAGS} include( fFlagsG1, G1_CanNotDoublebuf ); - {$ELSE} fCannotDoubleBuf := True; {$ENDIF} // - with fBoundsRect do // - begin // - Right := Right + 100; // - Bottom := Top + 200; // - end; // - fColor := clWindow; // - fLookTabKeys := [ tkTab ]; // - if eoWantTab in AOptions then // - fLookTabKeys := [ ]; // - Perform( EM_SETEVENTMASK, 0, // - ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or // - ENM_PROTECTED or $04000000 {ENM_LINK} ); // - Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(fColor)); // -end; // - // -constructor TControl.CreateRichEdit(AParent: PControl; // - AOptions: TEditOptions); // -var OldRichEditClass, OldRichEditLib: PAnsiChar; // -begin // - if OleInit then // - begin // - OldRichEditClass := RichEditClass; // - OldRichEditLib := RichEditLib; // - CreateRichEdit1( AParent, AOptions ); // - fCharFmtDeltaSz := 24; // - fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat ); // - RichEditClass := OldRichEditClass; // - RichEditLib := OldRichEditLib; // - end else // - CreateRichEdit1( AParent, AOptions ); // -end; // - // -constructor TControl.CreateProgressbar(AParent: PControl); // -const ProgressBarFlags: array[ TProgressbarOption ] of Integer = // - (PBS_VERTICAL, PBS_SMOOTH ); // -begin // - CreateCommonControl( AParent, PROGRESS_CLASS, // - WS_CHILD or WS_VISIBLE, True, nil ); // - with fBoundsRect do // - begin // - Right := Left + 300; // - Bottom := Top + 20; // - end; // - fMenu := 0; // - fTextColor := clHighlight; // -end; // - // -constructor TControl.CreateProgressbarEx(AParent: PControl; // - AOptions: TProgressbarOptions); // -const ProgressBarFlags: array[ TProgressbarOption ] of Integer = // - (PBS_VERTICAL, PBS_SMOOTH ); // -begin // - CreateProgressbar( AParent ); // - fStyle := fStyle or DWORD( MakeFlags( @AOptions, ProgressBarFlags ) ); // -end; // - // -constructor TControl.CreateListView(AParent: PControl; // - AStyle: TListViewStyle; AOptions: TListViewOptions; AImageListSmall, // - AImageListNormal, AImageListState: PImageList); // -begin // - CreateCommonControl( AParent, WC_LISTVIEW, ListViewStyles[ AStyle ] or // - LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP, // - True, @ListViewActions ); // - fLVOptions := AOptions; // - fLVStyle := AStyle; // - fCreateWndExt := ApplyImageLists2ListView; // - with fBoundsRect do // - begin // - Right := Left + 200; // - Bottom := Top + 150; // - end; // - ImageListSmall := AImageListSmall; // - ImageListNormal := AImageListNormal; // - ImageListState := AImageListState; // - fLVTextBkColor := clWindow; // - fLookTabKeys := [ tkTab ]; // -end; // - // -constructor TControl.CreateTreeView(AParent: PControl; // - AOptions: TTreeViewOptions; AImgListNormal, AImgListState: PImageList); // -var Flags: Integer; // -begin // - Flags := MakeFlags( @AOptions, TreeViewFlags ); // - CreateCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or // - WS_CHILD or WS_TABSTOP, True, @TreeViewActions ); // - fCreateWndExt := ApplyImageLists2Control; // - fColor := clWindow; // - AttachProc( WndProcTreeView ); // - with fBoundsRect do // - begin // - Right := Left + 150; // - Bottom := Top + 200; // - end; // - ImageListNormal := AImgListNormal; // - ImageListState := AImgListState; // - fLookTabKeys := [ tkTab ]; // -end; /////////////////////////////////////////////////////////////////////////// -constructor TControl.CreateTabControl(AParent: PControl; ATabs: array of String;// - AOptions: TTabControlOptions; // - AImgList: PImageList; AImgList1stIdx: Integer); // -var I, II : Integer; // - Flags: Integer; // -begin Flags := MakeFlags( @AOptions, TabControlFlags ); // - if tcoFocusTabs in AOptions then // - Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN); // - CreateCommonControl( AParent, WC_TABCONTROL, // - Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or // - WS_VISIBLE), True, @TabControlActions ); // - if not( tcoBorder in AOptions ) then // - fExStyle := fExStyle and not WS_EX_CLIENTEDGE; // - AttachProc( WndProcTabControl ); // - with fBoundsRect do // - begin // - Right := Left + 100; // - Bottom := Top + 100; // - end; // - if AImgList <> nil then // - Perform( TCM_SETIMAGELIST, 0, AImgList.Handle ); // - II := AImgList1stIdx; // - for I := 0 to High( ATabs ) do // - begin // - TC_Insert( I, ATabs[ I ], II ); // - Inc( II ); // - end; // - fLookTabKeys := [ tkTab ]; // -end; /////////////////////////////////////////////////////////////////////////// -constructor TControl.CreateToolbar(AParent: PControl; // - AAlign: TControlAlign; AOptions: TToolbarOptions; ABitmap: HBitmap; // - AButtons: array of PAnsiChar; ABtnImgIdxArray: array of Integer); // -var Flags: DWORD; // -begin // - if not( tboTextBottom in AOptions ) then // - include( AOptions, tboTextRight ); - if tboTextRight in AOptions then // - exclude( AOptions, tboTextBottom ); - Flags := MakeFlags( @AOptions, ToolbarOptions ); // - CreateCommonControl( AParent, TOOLBARCLASSNAME, ToolbarAligns[ Align ] or // - WS_CHILD or WS_VISIBLE {or WS_TABSTOP} // - or TBSTYLE_TOOLTIPS or Flags, // - (not (Align in [caNone])) and // - not (tboNoDivider in AOptions), nil ); // - fCommandActions.aClear := ClearToolbar; // - fCommandActions.aGetCount := TB_BUTTONCOUNT; // - with fBoundsRect do // - begin if AAlign in [ caNone ] then // - begin Bottom := Top + 26; // - Right := Left + 1000; // - end else // - begin Left := 0; Right := 0; // - Top := 0; Bottom := 0; // - end; // - end; // - Perform(TB_SETEXTENDEDSTYLE, 0, Perform(TB_GETEXTENDEDSTYLE, 0, 0) or // - TBSTYLE_EX_DRAWDDARROWS); // - AttachProc( WndProcToolbarCtrl ); // - Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 ); // - Perform( TB_SETINDENT, fMargin, 0 ); // - with fBoundsRect do // - begin // - if AAlign in [ caLeft, caRight ] then // - Right := Left + 24 // - else if not (AAlign in [caNone]) then // - Bottom := Top + 22; // - end; // - if ABitmap <> 0 then // - TBAddBitmap( ABitmap ); // - TBAddButtons( AButtons, ABtnImgIdxArray ); // - Perform( WM_SIZE, 0, 0 ); // -end; /////////////////////////////////////////////////////////////////////////// -constructor TImageList.CreateImageList(POwner: Pointer); // -var AOwner: PControl; // -begin {*************} DoInitCommonControls( ICC_WIN95_CLASSES ); // - Create; // - FAllocBy := 1; // - FMasked := True; // - if POwner = nil then exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - FBkColor := TColor( CLR_NONE ); - AOwner := POwner; // - FControl := AOwner; // - fNext := PImageList( AOwner.fImageList ); // - if AOwner.fImageList <> nil then // - PImageList( AOwner.fImageList ).fPrev := @Self; // - AOwner.fImageList := @Self; // -end;//////////////////////////////////////////////////////////////////////////// -constructor TThread.ThreadCreate; // -begin IsMultiThread := True; // - Create; // - FSuspended := True; // - FHandle := CreateThread( nil, // no security // - 0, // the same stack size // - @ThreadFunc, // thread entry point // - @Self, // parameter to pass to ThreadFunc // - CREATE_SUSPENDED, // always SUSPENDED // - FThreadID ); // receive thread ID // -end;//////////////////////////////////////////////////////////////////////////// -constructor TThread.ThreadCreateEx( const Proc: TOnThreadExecute ); // -begin // - ThreadCreate; // - OnExecute := Proc; // - Resume; // -end; // -{$ENDIF USE_CONSTRUCTORS} //****************************************************// -procedure InvalidateExW( Wnd: HWnd ); -begin InvalidateRect( Wnd, nil, TRUE ); - Wnd := GetWindow( Wnd, GW_CHILD ); - while Wnd <> 0 do - begin - InvalidateExW( Wnd ); - Wnd := GetWindow( Wnd, GW_HWNDNEXT ); - end; -end; /////////////////////////////////////////////////////////////////////////// -procedure TControl.InvalidateEx; -begin if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - InvalidateExW( fHandle ); -end; /////////////////////////////////////////////////////////////////////////// -procedure InvalidateNCW( Wnd: HWnd; Recursive: Boolean ); -begin SendMessage( Wnd, WM_NCPAINT, 1, 0 ); - if not Recursive then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Wnd := GetWindow( Wnd, GW_CHILD ); - while Wnd <> 0 do - begin - InvalidateNCW( Wnd, Recursive ); - Wnd := GetWindow( Wnd, GW_HWNDNEXT ); - end; -end; /////////////////////////////////////////////////////////////////////////// -procedure TControl.InvalidateNC(Recursive: Boolean); -begin - if fHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - InvalidateNCW( fHandle, Recursive ); -end; /////////////////////////////////////////////////////////////////////////// -procedure TControl.SetClientMargin(const Index: Integer; Value: ShortInt); -begin - case Index of - 1: fClientTop := Value; - 2: fClientBottom := Value; - 3: fClientLeft := Value; - 4: fClientRight := Value; - end; - {$IFNDEF OLD_ALIGN}include(fAligning,oaFromSelf);{$ENDIF}//??? - Global_Align( @Self ); -end; -{$IFDEF F_P} -function TControl.GetClientMargin(const Index: Integer): Integer; -begin - CASE Index OF - 1: Result := fClientTop; - 2: Result := fClientBottom; - 3: Result := fClientLeft; - 4: Result := fClientRight; - END; -end; -{$ENDIF F_P} -{------------------------------------------------------------------------------} -{ G R A P H C O N T R O L S } -{------------------------------------------------------------------------------} -type TGrayTextData = packed record - Ctl: PControl; - W, H: Integer; - Flags: DWORD; - end; - PGrayTextData = ^TGrayTextData; /////////////////////////////////////////// -function DrawTextGrayed( DC: HDC; lData, wData, cX, cY: Integer ): BOOL; stdcall; -var GDT: PGrayTextData; - R: TRect; -begin - GDT := Pointer( lData ); - R := MakeRect( 0, 0, cX, cY ); - DrawFormattedText( GDT.Ctl, DC, R, GDT.Flags or $80000000 ); - Result := TRUE; -end; /////////////////////////////////////////////////////////////////////////// -procedure DrawFormattedText( Ctl: PControl; DC: HDC; var R: TRect; Flags: DWORD {EditCtl: Boolean} ); -var Fmt: DWORD; - OldFont: Integer; - OldBrush: Integer; - OldBk: Integer; - ParentHavingFont: PControl; - GTD: TGrayTextData; - dX, dY: Integer; - R1: TRect; -begin Fmt := DT_EXPANDTABS or Flags and $7FFFFFFF; - if Ctl.WordWrap then - Fmt := Fmt or DT_WORDBREAK; - if Flags and DT_EDITCONTROL <> 0 then - Inc( R.Left, 4 ); - ParentHavingFont := Ctl; - while (ParentHavingFont <> nil) and ( ParentHavingFont.FFont = nil ) - and {$IFDEF USE_FLAGS} not(G3_IsForm in ParentHavingFont.fFlagsG3) - {$ELSE} not ParentHavingFont.IsForm {$ENDIF} do - ParentHavingFont := ParentHavingFont.Parent; - OldFont := 0; - if ( ParentHavingFont <> nil ) then - begin OldFont := SelectObject( DC, ParentHavingFont.Font.Handle ); - SetTextColor( DC, ParentHavingFont.Font.FColorRGB ); - end; - R1 := R; - {$IFDEF UNICODE_CTRLS}Windows.DrawTextW - {$ELSE} Windows.DrawTextA - {$ENDIF}( DC, PKOLChar( Ctl.Caption ), Length( Ctl.Caption ), R, - Fmt or DT_CALCRECT ); // TODO: fixme (Length('kanji') != WStrLen('kanji')) - CASE Ctl.fTextAlign OF - taCenter: dX := (R1.Right - R1.Left - (R.Right - R.Left)) div 2; - taRight: dX := R1.Right - R.Right; - else dX := 0; - END; - CASE Ctl.fVerticalAlign OF - vaCenter: dY := (R1.Bottom - R1.Top - (R.Bottom - R.Top)) div 2; - vaBottom: dY := R1.Bottom - R.Bottom; - else dY := 0; - END; - OffsetRect( R, dX, dY ); - if {$IFDEF USE_FLAGS} not(F3_Disabled in Ctl.fStyle.f3_Style) - {$ELSE} Ctl.fEnabled {$ENDIF} - or (Flags and $80000000 <> 0) then - begin OldBk := SetBkMode( DC, TRANSPARENT ); - OldBrush := SelectObject( DC, GetStockObject( NULL_BRUSH ) ); - {$IFDEF UNICODE_CTRLS}Windows.DrawTextW - {$ELSE} Windows.DrawTextA - {$ENDIF}( DC, PKOLChar( Ctl.Caption ), Length( Ctl.Caption ), R, Fmt ); - SelectObject( DC, OldBrush ); - SetBkMode( DC, OldBk ); - end else - begin GTD.Ctl := Ctl; - GTD.W := R.Right - R.Left; - GTD.H := R.Bottom - R.Top; - GTD.Flags := Flags; - Windows.DrawState( DC, GetStockObject( NULL_BRUSH ), @ DrawTextGrayed, - Integer( @ GTD ), Length( Ctl.fCaption ), R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, - DST_COMPLEX or DSS_DISABLED ); - end; - if ( ParentHavingFont <> nil ) then - SelectObject( DC, OldFont ); -end; - -{$IFDEF USE_GRAPHCTLS} -{$IFDEF GRAPHCTL_XPSTYLES} -type TOpenThemeDataProc = function( Wnd: HWnd; pszClassList: PWideChar ): THandle; - stdcall; - TDrawThemeBackground = function( Theme: THandle; DC: HDC; iPartId: Integer; - iStateId: Integer; Rect, ClipRect: PRect ): Integer; - stdcall; - TGetThemeBackgroundContentRect = function( Theme: THandle; DC: HDC; - iPartId, iStateId: Integer; Rect, ContentRect: PRect ): - Integer; stdcall; - TDrawThemeText = function( Theme: THandle; DC: HDC; iPartId, iStateId: Integer; - pszText: PWideChar; iCharCount: Integer; - dwTextFlags, dwTextFlags2: DWORD; Rect: PRect ): Integer; - stdcall; - TCloseThemeData = function( Theme: THandle ): Integer; stdcall; -var fOpenThemeDataProc: TOpenThemeDataProc; - fDrawthemeBackground: TDrawThemeBackground; - fGetThemeBackgroundcontentRect: TGetThemeBackgroundContentRect; - fDrawThemeText: TDrawThemeText; - fCloseThemeData: TCloseThemeData; - uxtheme_lib: THandle; -function OpenThemeDataProc: TOpenThemeDataProc; -begin Result := nil; - if Integer(uxtheme_lib) = -1 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if uxtheme_lib = 0 then - uxtheme_lib := LoadLibrary( 'uxtheme' ); - if uxtheme_lib = 0 then - begin uxtheme_lib := DWORD( -1 ); Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - fOpenThemeDataProc := GetProcAddress( uxtheme_lib, 'OpenThemeData' ); - fDrawthemeBackground := GetProcAddress( uxtheme_lib, 'DrawThemeBackground' ); - fGetThemeBackgroundcontentRect := GetProcAddress( uxtheme_lib, 'GetThemeBackgroundContentRect' ); - fDrawThemeText := GetProcAddress( uxtheme_lib, 'DrawThemeText' ); - fCloseThemeData := GetProcAddress( uxtheme_lib, 'CloseThemeData' ); - if not Assigned( fOpenThemeDataProc ) or - not Assigned( fDrawThemeBackground ) or - not Assigned( fGetThemeBackgroundcontentRect ) or - not Assigned( fDrawThemeText ) or - not Assigned( fCloseThemeData ) then - begin - FreeLibrary( uxtheme_lib ); - uxtheme_lib := DWORD( -1 ); - fOpenThemeDataProc := nil; - fDrawThemeBackground := nil; - fGetThemeBackgroundcontentRect := nil; - fDrawThemeText := nil; - fCloseThemeData := nil; - end; - Result := fOpenThemeDataProc; -end; - -procedure DrawFormattedTextXP( Theme: THandle; Ctl: PControl; DC: HDC; - var R: TRect; CtlType, CtlStates, Flags1, Flags2: Integer ); -var OldFont: Integer; - OldBrush: Integer; - ParentHavingFont: PControl; -begin ParentHavingFont := Ctl; - while (ParentHavingFont <> nil) and ( ParentHavingFont.FFont = nil ) - and {$IFDEF USE_FLAGS} not(G3_IsForm in ParentHavingFont.fFlagsG3) - {$ELSE} not ParentHavingFont.IsForm {$ENDIF} do - ParentHavingFont := ParentHavingFont.Parent; - OldFont := 0; - if ( ParentHavingFont <> nil ) then - OldFont := SelectObject( DC, ParentHavingFont.Font.Handle ); - OldBrush := SelectObject( DC, GetStockObject( NULL_BRUSH ) ); - fDrawThemeText( Theme, DC, CtlType, CtlStates, @ KOLWideString( Ctl.fCaption )[ 1 ], - Length( Ctl.fCaption ), Flags1, Flags2, @ R ); - SelectObject( DC, OldBrush ); - if ( ParentHavingFont <> nil ) then SelectObject( DC, OldFont ); -end; -{$ENDIF} - -procedure PaintGraphicChildren( Self_, _Sender: PControl; DC: HDC ); -var i, sav: Integer; - C: PControl; - R: TRect; - rgn: HRgn; -begin - for i := Self_.ChildCount-1 downto 0 do - begin - C := Self_.Children[ i ]; - if not C.Visible then continue; - R := C.BoundsRect; - if (C.Handle = 0) - and {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6) - {$ELSE} not C.fWindowed {$ENDIF} - {$IFDEF SAFE_CODE} and Assigned( C.EV.fPaintProc ) {$ENDIF} then - begin - sav := SaveDC( DC ); - rgn := CreateRectRgnIndirect( R ); - ExtSelectClipRgn( DC, rgn, RGN_AND ); - SelectClipRgn( DC, rgn ); - DeleteObject( rgn ); - Free_And_Nil( C.fCanvas ); - C.fCanvas := Self_.Canvas; - Self_.Canvas.Brush.Assign( Self_.Brush ); - Self_.Canvas.Font.Assign( Self_.Font ); // не присваивается? - Self_.fCanvas.DeselectHandles; // не помогает??? - {$IFDEF NIL_EVENTS} - if Assigned( C.EV.fOnPrepaint ) then - {$ENDIF} - C.EV.fOnPrePaint( C, DC ); - C.EV.fPaintProc( DC ); - if Assigned( C.EV.fOnPaint ) then - C.EV.fOnPaint( C, DC ); - {$IFDEF NIL_EVENTS} - if Assigned( C.EV.fOnPostPaint ) then - {$ENDIF} - C.EV.fOnPostPaint( C, DC ); - C.fCanvas := nil; - Self_.Canvas.Brush.Assign( Self_.Brush ); - Self_.Canvas.Font.Assign( Self_.Font ); - RestoreDC( DC, sav ); - ExcludeClipRect( DC, R.Left, R.Top, R.Right, R.Bottom ); - end; - end; - if {$IFDEF USE_FLAGS} G5_IsGroupbox in Self_.fFlagsG5 - {$ELSE} Self_.fIsGroupBox {$ENDIF} then - begin - Self_.DF.fErasingBkgnd := TRUE; - R := Self_.BoundsRect; - OffsetRect( R, -R.Left, -R.Top ); - Self_.Canvas.FillRect( R ); - Self_.GroupBoxPaint( DC ); - Self_.DF.fErasingBkgnd := FALSE; - end else - if Assigned( Self_.EV.fOnPaint2 ) then - Self_.EV.fOnPaint2( Self_, DC ) - else Self_.Canvas.FillRect( Self_.ClientRect ); -end; - -function WndProc_ParentOfGraphicCtl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var WasOnPaint: TOnPaint; - i: Integer; - C: PControl; - Pt: TPoint; - PF: PControl; - save_Paint2: TOnPaint; -begin - Result := FALSE; - if (Msg.message = WM_PAINT) {or (Msg.message = WM_PRINT)} then - begin WasOnPaint := Self_.EV.fOnPaint; - Self_.{$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} - .fOnPaint2 := Self_.EV.fOnPaint; - //Self_.fPaintMsg := Msg; - {$IFDEF MAKE_METHOD} - TMethod( Self_.EV.fOnPaint ) := MakeMethod( Self_, @ PaintGraphicChildren ); - {$ELSE} - TMethod( Self_.EV.fOnPaint ).Code := @ PaintGraphicChildren; - TMethod( Self_.EV.fOnPaint ).Data := Self_; - {$ENDIF} - save_Paint2 := Self_.EV.fOnPaint2; - if not Assigned( Self_.EV.fOnPaint2 ) then - begin - {$IFDEF MAKE_METHOD} - Self_.EV.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintClear ) ); - {$ELSE} - TMethod( Self_.EV.fOnPaint2 ).Code := @ DummyPaintClear; - //TMethod( Self_.EV.fOnPaint2 ).Data := nil; - {$ENDIF} - end; - i := Self_.fDynHandlers.fCount; - Self_.fDynHandlers.fCount := Self_.fDynHandlers.IndexOf( @ WndProc_ParentOfGraphicCtl ); - Result := EnumDynHandlers( Self_, Msg, Rslt ); - Self_.fDynHandlers.fCount := i; - if not Result then - {Result :=} WndProcPaint( Self_, Msg, Rslt ); - Self_.EV.fOnPaint := WasOnPaint; - Result := TRUE; - end else - if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= WM_MOUSELAST) then - begin - Pt.X := SmallInt( LoWord( Msg.lParam ) ); - Pt.Y := SmallInt( HiWord( Msg.lParam ) ); - for i := 0 to Self_.ChildCount-1 do - begin - if (i = 0) and (Self_.fPushedBtn <> nil) then - C := Self_.fPushedBtn - else C := Self_.Children[ i ]; - if (C = Self_.fPushedBtn) OR - {$IFDEF USE_FLAGS} - (F3_Visible in C.fStyle.f3_Style) - and not (F3_Disabled in C.fStyle.f3_Style) - {$ELSE} C.fVisible and C.fEnabled {$ENDIF} - and PtInRect( C.BoundsRect, Pt ) then - begin - if {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6) - {$ELSE} not C.fWindowed {$ENDIF} - and (C.fCursor <> 0) and (C.fCursor <> Self_.fCursor) and - (ScreenCursor = 0) then - begin if Self_.fSaveCursor = 0 then - begin Self_.fSaveCursor := Self_.fCursor; - if Self_.fCursor = 0 then - Self_.fSaveCursor := LoadCursor( 0, IDC_ARROW ); - end; - Self_.Cursor := C.fCursor; - Windows.SetCursor( C.fCursor ); - end; - {$IFDEF GRAPHCTL_HOTTRACK} - if {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6) - {$ELSE} not C.fWindowed {$ENDIF} - and (Applet.DF.fHotCtl <> C) then - begin - if Applet.DF.fHotCtl <> nil then - begin - {$IFDEF USE_FLAGS} - exclude( Applet.DF.fHotCtl.fFlagsG4, G4_Hot ); - {$ELSE} Applet.DF.fHotCtl.fHot := FALSE; {$ENDIF} - if {$IFDEF USE_FLAGS} (G6_GraphicCtl in Applet.DF.fHotCtl.fFlagsG6) - {$ELSE} not Applet.DF.fHotCtl.fWindowed {$ENDIF} then - begin - Applet.DF.fHotCtl.Invalidate; - {$IFDEF NIL_EVENTS} - if Assigned( Applet.DF.fHotCtl.EV.fOnMouseLeave ) then - {$ENDIF} - Applet.DF.fHotCtl.EV.fOnMouseLeave( Applet.DF.fHotCtl ); - end; - Applet.DF.fHotCtl.RefDec; - end; - C.RefInc; - Applet.DF.fHotCtl := C; - {$IFDEF USE_FLAGS} include( C.fFlagsG4, G4_Hot ); - {$ELSE} C.fHot := TRUE; {$ENDIF} - C.Invalidate; - Self_.EV.fMouseLeaveProc := Self_.MouseLeaveFromParentOfGraphCtl; - ProvideMouseEnterLeave( Self_ ); - {$IFDEF NIL_EVENTS} - if Assigned( C.EV.fOnMouseEnter ) then - {$ENDIF} - C.EV.fOnMouseEnter( C ); - end; - {$ENDIF GRAPHCTL_HOTTRACK} - if {$IFDEF USE_FLAGS} not(G6_GraphicCtl in C.fFlagsG6) - {$ELSE} C.fWindowed {$ENDIF} then - begin - Msg.hwnd := C.fHandle; - Pt := Self_.Client2Screen( Pt ); - Pt := C.Screen2Client( Pt ); - Msg.lParam := Pt.Y shl 16 or (Pt.X and $FFFF); - end; - Rslt := C.WndProc( Msg ); - if {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6) - {$ELSE} not C.fWindowed {$ENDIF} then - {$IFDEF NIL_EVENTS} - if Assigned( C.EV.fGraphCtlMouseEvent ) then - {$ENDIF} - C.EV.fGraphCtlMouseEvent( Msg ) - else if (Msg.message = WM_LBUTTONDOWN) or - (Msg.message = WM_RBUTTONDOWN) or - (Msg.message = WM_MBUTTONDOWN) then C.DoClick; - Result := TRUE; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - end; - {$IFDEF GRAPHCTL_HOTTRACK} - Self_.MouseLeaveFromParentOfGraphCtl( Self_ ); - {$ENDIF GRAPHCTL_HOTTRACK} - if {$IFDEF USE_FLAGS} (G5_IsGroupbox in Self_.fFlagsG5) - {$ELSE} Self_.fIsGroupBox {$ENDIF} - and ( - (Msg.message = WM_LBUTTONDOWN) or - (Msg.message = WM_LBUTTONDBLCLK) or - (Msg.message = WM_LBUTTONUP) - ) then - begin - Self_.Invalidate; - end; - if Self_.fSaveCursor <> 0 then - begin Self_.Cursor := Self_.fSaveCursor; - Self_.fSaveCursor := 0; - if ScreenCursor = 0 then Windows.SetCursor( Self_.fCursor ); - end; - end else - if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then - begin - if Self_.IsControl then - PF := Self_.ParentForm - else PF := Self_; - if (PF.DF.fCurrentControl <> nil) - and {$IFDEF USE_FLAGS} (G6_GraphicCtl in PF.DF.fCurrentControl.fFlagsG6) - {$ELSE} not PF.DF.fCurrentControl.fWindowed {$ENDIF} then - begin if Assigned( PF.DF.fCurrentControl.fKeyboardProcess ) and - PF.DF.fCurrentControl.fKeyboardProcess( Msg, Rslt ) then - else Rslt := PF.DF.fCurrentControl.WndProc( Msg ); - Result := TRUE; - end else - begin - if {$IFDEF USE_FLAGS} (G5_IsGroupbox in Self_.fFlagsG5) - {$ELSE} Self_.fIsGroupBox {$ENDIF} - and (Msg.wParam = WORD( ' ' )) and - ( - (Msg.message = WM_KEYDOWN) or - (Msg.message = WM_SYSKEYDOWN) or - (Msg.message = WM_KEYUP) or - (Msg.message = WM_SYSKEYUP) or - (Msg.message = WM_CHAR) or - (Msg.message = WM_SYSCHAR) - ) then - begin - Self_.Invalidate; - end; - end; - end else - if Msg.message = CM_QUIT then - begin - C := Pointer( Msg.wParam ); - C.Free; - end else - if Msg.message = CM_FOCUSGRAPHCTL then - begin - C := Pointer( Msg.wParam ); - PF := C.ParentForm; - if (PF.DF.fCurrentControl <> nil) and (PF.DF.fCurrentControl <> C) then - begin - {$IFDEF USE_FLAGS} - exclude( PF.DF.fCurrentControl.fFlagsG6, G6_Focused ); - {$ELSE} PF.DF.fCurrentControl.fFocused := FALSE; {$ENDIF} - PF.DF.fCurrentControl.Invalidate; - end; - PF.DF.fCurrentControl := C; - C.Parent.DF.fCurrentControl := C; - //C.Parent.fFocusHandle := C.Parent.fHandle; - {$IFDEF USE_FLAGS} include( C.fFlagsG6, G6_Focused ); - {$ELSE} C.fFocused := TRUE; {$ENDIF} - if Assigned( C.EV.fOnEnter ) then - C.EV.fOnEnter( C ); - C.Invalidate; - C.EV.fLeave := C.LeaveGraphButton; - C.RefDec; - end; -end;//////////////////////////////////////////////////////////////////////////// -function WndProc_FormHavingGraphCtl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var Msg2: TMsg; -begin Result := FALSE; - if Msg.message = WM_ACTIVATE then - begin if Self_.DF.fCurrentControl <> nil then - Self_.DF.fCurrentControl.Invalidate; - end else - if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then - begin if (Self_.DF.fCurrentControl <> nil) - and {$IFDEF USE_FLAGS} (G6_GraphicCtl in Self_.DF.fCurrentControl.fFlagsG6) - {$ELSE} not Self_.DF.fCurrentControl.fWindowed {$ENDIF} then - begin if (Msg.message = WM_KEYDOWN) and ((Msg.wParam = 32) or (Msg.wParam = 13)) then - begin if not PeekMessage( Msg2, Msg.hwnd, WM_CHAR, WM_CHAR, pm_noRemove ) - or (Msg2.wParam <> Msg.wParam) then - Msg.message := WM_CHAR; - end else - if (Msg.message = WM_SYSKEYDOWN) and ((Msg.wParam = 32) or (Msg.wParam = 13)) then - begin if not PeekMessage( Msg2, Msg.hwnd, WM_SYSCHAR, WM_SYSCHAR, pm_noRemove ) or - (Msg2.wParam <> Msg.wParam) then - Msg.message := WM_SYSCHAR; - end; - if Assigned( Self_.DF.fCurrentControl.fKeyboardProcess ) and - Self_.DF.fCurrentControl.fKeyboardProcess( Msg, Rslt ) then - else Rslt := Self_.DF.fCurrentControl.WndProc( Msg ); - Result := TRUE; - end; - end; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF GRAPHCTL_HOTTRACK} -procedure TControl.MouseLeaveFromParentOfGraphCtl(Sender: PObj); -var C: PControl; - Pt: TPoint; -begin - if AppletTerminated then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - GetCursorPos( Pt ); - Pt := Screen2Client( Pt ); - if (Applet.DF.fHotCtl <> nil) and (fChildren.IndexOf( Applet.DF.fHotCtl ) >= 0) then - begin - C := Applet.DF.fHotCtl; - if PtInRect( C.BoundsRect, Pt ) then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Applet.DF.fHotCtl := nil; - {$IFDEF USE_FLAGS} exclude( C.fFlagsG4, G4_Hot ); - {$ELSE} C.fHot := FALSE; {$ENDIF} - if {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6) - {$ELSE} not C.fWindowed {$ENDIF} then - C.Invalidate; - if Assigned( C.OnMouseLeave ) then - C.OnMouseLeave( C ); - C.RefDec; - end; -end; -{$ENDIF GRAPHCTL_HOTTRACK} - -procedure NotifyGraphCtlAboutNewParent(Prnt, Chld: PControl); -begin - if (Chld <> nil) and (Prnt <> nil) then - Prnt.AttachProc( WndProc_ParentOfGraphicCtl ); -end; - -function _NewGraphCtl( AParent: PControl; ATabStop: Boolean; - ACommandActions: TCommandActionsParam ): PControl; -var IdxActions: Integer; -begin new( Result, Create ); - {$IFDEF DEBUG_OBJKIND} Result.fObjKind := 'TControl:GraphicControl'; - {$ENDIF} - {$IFDEF COMMANDACTIONS_OBJ} - IdxActions := Integer( ACommandActions ); - if IdxActions >= 120 then - IdxActions := PByte( ACommandActions )^; - if AllActions_Objs[IdxActions] <> nil then - begin Result.fCommandActions := AllActions_Objs[IdxActions]; - Result.fCommandActions.RefInc; - end else - begin new( Result.fCommandActions, Create ); - {$IFDEF DEBUG_OBJKIND} - Result.fCommandActions.fObjKind := 'TCommandActionsObj'; - {$ENDIF} - AllActions_Objs[IdxActions] := Result.fCommandActions; - {$IFDEF SAFE_CODE} - if ACommandActions <> nil then - {$ENDIF} - Move( ACommandActions^, Result.fCommandActions.aClear, Sizeof( TCommandActions ) ); - end; - Result.Add2AutoFree( Result.fCommandActions ); - {$ELSE} {$IFDEF SAFE_CODE} - if ACommandActions <> nil then - {$ENDIF} - Result.fCommandActions := ACommandActions^; - {$ENDIF} - Result.PP.fDoInvalidate := InvalidateNonWindowed; - {$IFDEF USE_FLAGS} include( Result.fFlagsG6, G6_GraphicCtl ); - {$ELSE} Result.fWindowed := FALSE; {$ENDIF} - {$IFDEF USE_FLAGS} - include( Result.fFlagsG3, G3_IsControl ); - include( Result.fFlagsG4, G4_CreateVisible ); - if ATabStop then - include( Result.fStyle.f2_Style, F2_TabStop ); - {$ELSE} Result.fCreateVisible := TRUE; - Result.fVisible := TRUE; - Result.fIsControl := TRUE; - Result.fTabstop := ATabStop; - {$ENDIF} - Result.fMenu := CtlIdCount; - Inc( CtlIdCount ); - Result.DF.fBitBtnOptions := [ bboFixed ]; // to return Checked = fChecked w/o window handle - {$IFDEF USE_FLAGS} - Result.fFlagsG1 := Result.fFlagsG1 + [ G1_IgnoreWndCaption, G1_SizeRedraw ]; - {$ELSE} Result.fIgnoreWndCaption := TRUE; - Result.fSizeRedraw := TRUE; - {$ENDIF} - Result.PP.fNotifyChild := @ NotifyGraphCtlAboutNewParent; - if ATabStop then - Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ]; - if AParent <> nil then - begin Result.Parent := AParent; - Result.Border := AParent.Border; - AParent.AttachProc( WndProc_ParentOfGraphicCtl ); - if ATabStop then - begin Inc( AParent.ParentForm.fTabOrder ); - Result.fTabOrder := AParent.ParentForm.fTabOrder; - end; - if {$IFDEF USE_FLAGS} G3_IsControl in AParent.fFlagsG3 - {$ELSE} AParent.fIsControl {$ENDIF} then - AParent.ParentForm.AttachProc( WndProc_FormHavingGraphCtl ); - if {$IFDEF USE_FLAGS} G5_IsGroupbox in APArent.fFlagsG5 - {$ELSE} AParent.fIsGroupBox {$ENDIF} then - begin AParent.Style := AParent.Style and - not BS_GROUPBOX; // otherwise the groupbox is flickering A LOT! - AParent.Parent.AttachProc( WndProc_ParentOfGraphicCtl ); - end; - - Result.fFont := Result.fFont.Assign( AParent.fFont ); - if Result.fFont <> nil then - begin Result.fFont.fParentGDITool := AParent.fFont; - Result.fFont.fOnGTChange := Result.FontChanged; - Result.FontChanged( Result.fFont ); - end; - end; - Result.fBoundsRect.Right := Result.fBoundsRect.Left + 64; - Result.fBoundsRect.Bottom := Result.fBoundsRect.Top + 22; - Result.EV.fOnPaint := nil; - - {$IFDEF GRAPHCTL_XPSTYLES} - if WinVer < wvXP then - DoNotDrawGraphCtlsUsingXPStyles := TRUE; - {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -function NewGraphLabel( AParent: PControl; const ACaption: AnsiString ): PControl; -begin {$IFDEF INPACKAGE} Result := NewLabel( AParent, ACaption ); - {$ELSE} Result := _NewGraphCtl( AParent, FALSE, - {$IFDEF PACK_COMMANDACTIONS} LabelActions_Packed - {$ELSE} @LabelActions {$ENDIF} ); - Result.aAutoSzX := 1; - Result.aAutoSzY := 1; - Result.EV.fPaintProc := Result.GraphicLabelPaint; - Result.Caption := ACaption; - {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -function NewWordWrapGraphLabel( AParent: PControl; const ACaption: KOLString ): PControl; -begin {$IFDEF INPACKAGE} Result := NewWordWrapLabel( AParent, ACaption ); - {$ELSE} Result := NewGraphLabel( AParent, ACaption ); - {$IFDEF USE_FLAGS} include( Result.fFlagsG1, G1_WordWrap ); - {$ELSE} Result.fWordWrap := TRUE; {$ENDIF} - {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -function NewGraphPaintBox( AParent: PControl ): PControl; -begin {$IFDEF INPACKAGE} Result := NewPaintbox( AParent ); - {$ELSE} Result := NewGraphLabel( AParent, '' ); {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -procedure ClickGraphCheck(Sender: PObj); -var Ctl: PControl; -begin Ctl := Pointer( Sender ); - if not Ctl.Enabled then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Ctl.Focused := TRUE; - if Assigned( Ctl.OnEnter ) then - Ctl.OnEnter( Ctl ); - {$IFDEF USE_FLAGS} - if G4_Checked in Ctl.fFlagsG4 then - exclude( Ctl.fFlagsG4, G4_Checked ) - else include( Ctl.fFlagsG4, G4_Checked ); - {$ELSE} Ctl.fChecked := not Ctl.fChecked; {$ENDIF} - Ctl.Invalidate; - if Assigned( Ctl.OnClick ) then - Ctl.OnClick( Ctl ); -end;//////////////////////////////////////////////////////////////////////////// -function NewGraphCheckBox( AParent: PControl; const ACaption: KOLString ): PControl; -begin {$IFDEF INPACKAGE} Result := NewCheckbox( AParent, ACaption ); - {$ELSE} Result := NewGraphButton( AParent, ACaption ); - Result.TextAlign := taLeft; - Result.aAutoSzX := GetSystemMetrics( SM_CXMENUCHECK ) + 4; - Result.EV.fPaintProc := Result.GraphicCheckBoxPaint; - Result.EV.fGraphCtlMouseEvent := Result.GraphicCheckBoxMouse; - Result.PP.fControlClick := @ ClickGraphCheck; - {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -procedure ClickGraphRadio(Sender: PObj); -var Ctl, C: PControl; - i: Integer; -begin Ctl := Pointer( Sender ); - if not Ctl.Enabled then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - Ctl.Focused := TRUE; - Ctl.Checked := TRUE; - if Ctl.Parent <> nil then - for i := 0 to Ctl.Parent.ChildCount-1 do - begin C := Ctl.Parent.Children[ i ]; - if (C <> Ctl) and (@ C.PP.fControlClick = @ ClickGraphRadio) then - C.Checked := FALSE; - end; -end;//////////////////////////////////////////////////////////////////////////// -function NewGraphRadioBox( AParent: PControl; const ACaption: KOLString ): PControl; -begin {$IFDEF INPACKAGE} Result := NewRadiobox( AParent, ACaption ); - if (@ ClickGraphRadio) <> nil then; - {$ELSE} Result := NewGraphButton( AParent, ACaption ); - Result.TextAlign := taLeft; - Result.aAutoSzX := GetSystemMetrics( SM_CXMENUCHECK ) + 4; - Result.EV.fPaintProc := Result.GraphicRadioBoxPaint; - Result.PP.fControlClick := @ ClickGraphRadio; - {$IFDEF USE_FLAGS} - if not(G1_HasRadio in AParent.fFlagsG1) then - begin - include( AParent.fFlagsG1, G1_HasRadio ); - Result.SetRadioChecked; - end; - {$ELSE} - AParent.PropInt[ @RADIO_LAST ] := Result.fMenu; - if AParent.PropInt[ @RADIO_1ST ] = 0 then - begin - AParent.PropInt[ @RADIO_1ST ] := Result.fMenu; - Result.SetRadioChecked; - end; - {$ENDIF} - {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -procedure GraphButtonSetFocus(Ctl: PControl); -var PF, CC: PControl; - W: HWnd; -begin if {$IFDEF USE_FLAGS} not(F2_Tabstop in Ctl.fStyle.f2_Style) - {$ELSE} not Ctl.fTabStop {$ENDIF} then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>} - PF := Ctl.ParentForm; - if (PF.DF.fCurrentControl <> nil) and (PF.DF.fCurrentControl <> Ctl) and - (PF.DF.fCurrentControl <> Ctl.fParent) then - begin CC := PF.DF.fCurrentControl; - CC.RefInc; - Ctl.fParent.Focused := TRUE; - if Assigned( CC.EV.fLeave ) then - CC.EV.fLeave( PF.DF.fCurrentControl ) - else - Windows.SetFocus( 0 ); - CC.RefDec; - end else - begin W := GetFocus; - if (W <> Ctl.Parent.fHandle) and (W <> 0) then - begin Windows.SetFocus( 0 ); - Ctl.fParent.Focused := TRUE; - end; - end; - if Ctl.fParent.fHandle <> 0 then - begin {$IFDEF USE_FLAGS} include( Ctl.fFlagsG6, G6_Focused ); - {$ELSE} Ctl.fFocused := TRUE; {$ENDIF} - Ctl.fParent.Postmsg( CM_FOCUSGRAPHCTL, Integer( Ctl ), 0 ); - Ctl.RefInc; - end; - if Assigned( Ctl.EV.fOnEnter ) then - Ctl.EV.fOnEnter( Ctl ); -end;//////////////////////////////////////////////////////////////////////////// -function NewGraphButton( AParent: PControl; const ACaption: KOLString ): PControl; -begin {$IFDEF INPACKAGE} - Result := NewButton( AParent, ACaption ); - {$ELSE} - Result := _NewGraphCtl( AParent, TRUE, - {$IFDEF PACK_COMMANDACTIONS} ButtonActions_Packed - {$ELSE} @ButtonActions {$ENDIF} ); - Result.EV.fPaintProc := Result.GraphicButtonPaint; - Result.Caption := ACaption; - Result.TextAlign := taCenter; - Result.VerticalAlign := vaCenter; - Result.EV.fGraphCtlMouseEvent := Result.GraphicButtonMouse; - Result.fSetFocus := @GraphButtonSetFocus; - Result.fKeyboardProcess := Result.GraphButtonKeyboardProcess; - {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -function EditGraphEdit(Ctl: PControl): PControl; -var E: PControl; -begin E := NewEditBox( Ctl.fParent, Ctl.DF.fEditOptions ); - E.SetBoundsRect( Ctl.BoundsRect ); - E.SetAlign( Ctl.Align ); - E.fTabOrder := Ctl.fTabOrder; - E.Text := Ctl.Text; - E.OnChange := Ctl.ChangeGraphEdit; - E.Color := Ctl.Color; - E.fCursor := Ctl.fCursor; - E.CreateWindow; - E.OnLeave := Ctl.LeaveGraphEdit; - E.EV.fLeave := Ctl.LeaveGraphEdit; - E.Focused := TRUE; - E.OnChar := Ctl.OnChar; - E.OnKeyDown := Ctl.OnKeyDown; - E.OnKeyUp := Ctl.OnKeyUp; - E.OnDestroy := Ctl.DestroyGraphEdit; - //E.Font.Assign( Font ); - Result := E; - Ctl.Visible := FALSE; - Ctl.DF.fEditCtl := E; - {$IFDEF NIL_EVENTS} - if Assigned( Ctl.EV.fOnEnter ) then - {$ENDIF} - Ctl.EV.fOnEnter( Ctl ); -end;//////////////////////////////////////////////////////////////////////////// -function NewGraphEditbox( AParent: PControl; Options: TEditOptions ): PControl; -begin {$IFDEF INPACKAGE} - Result := NewEditbox( AParent, Options ); - {$ELSE} - Result := _NewGraphCtl( AParent, TRUE, - {$IFDEF PACK_COMMANDACTIONS} EditActions_Packed - {$ELSE} @EditActions {$ENDIF} ); - Result.aAutoSzY := 1; - Result.EV.fPaintProc := Result.GraphicEditPaint; - Result.DF.fEditOptions := Options; - Result.VerticalAlign := vaCenter; - Result.fColor := clWindow; - Result.EV.fGraphCtlMouseEvent := Result.GraphicEditMouse; - Result.fSetFocus := @EditGraphEdit; - Result.fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ]; - Result.EV.fLeave := Result.LeaveGraphEdit; - {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -{ TGraphicControl } - -function TControl.DoGraphCtlPrepaint: TRect; -begin - Result := ClientRect; - if not Assigned( TMethod( EV.fOnPrepaint ).Data ) and not Transparent then - begin if fBrush <> nil then - Canvas.Brush.Assign( fBrush ) - else Canvas.Brush.Color := Color; - Canvas.FillRect( Result ); - end; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GraphicLabelPaint(DC: HDC); -var R: TRect; -begin R := DoGraphCtlPrepaint; - if Text <> '' then DrawFormattedText( @ Self, DC, R, 0 ); -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GraphicCheckBoxPaint(DC: HDC); -var R, R1: TRect; - Flag: DWORD; - W, H: Integer; - {$IFDEF GRAPHCTL_XPSTYLES} - Theme: THandle; - {$ENDIF} -begin R := DoGraphCtlPrepaint; - {$IFDEF GRAPHCTL_XPSTYLES} - OpenThemeDataProc; - Theme := 0; - if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then - Theme := fOpenThemeDataProc( 0, 'Button' ); - if Theme <> 0 then begin - W := GetSystemMetrics( SM_CXMENUCHECK ); - H := GetSystemMetrics( SM_CYMENUCHECK ); - R1 := R; - R1.Right := R1.Left + W; - if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1 - {$ELSE} fWordWrap {$ENDIF} then - R1.Top := R1.Top + Border - else R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2; - R1.Bottom := R1.Top + H; - Flag := 1; {CBS_UNCHECKEDNORMAL} - if not Enabled then - Flag := 4 {CBS_UNCHECKEDDISABLED} - else if {$IFDEF USE_FLAGS} G4_Hot in fFlagsG4 - {$ELSE} fHot {$ENDIF} then - Flag := 2; {CBS_UNCHECKEDHOT} - if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4 - {$ELSE} fChecked {$ENDIF} then - Inc( Flag, 4 ); - fDrawThemeBackground( Theme, DC, 3 {BP_CHECKBOX}, Flag, @R1, @R ); - R.Left := R1.Left + W + Border; - if fCaption <> '' then begin - DrawFormattedText( @ Self, DC, R, DT_CALCRECT ); - if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1 - {$ELSE} fWordWrap {$ENDIF} then begin - DrawFormattedText( @ Self, DC, R, 0 ); - GraphCtlDrawFocusRect( DC, R ); - end else begin - GraphCtlDrawFocusRect( DC, R ); - DrawFormattedTextXP( Theme, @ Self, DC, R, 3 {BP_CHECKBOX}, Flag, 0, 0 ); - end; - end; - fCloseThemeData( Theme ); - end else - {$ENDIF} - begin W := GetSystemMetrics( SM_CXMENUCHECK ); - H := GetSystemMetrics( SM_CYMENUCHECK ); - R1 := R; - R1.Right := R1.Left + W; - if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1 - {$ELSE} fWordWrap {$ENDIF} then - R1.Top := R1.Top + Border - else R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2; - R1.Bottom := R1.Top + H; - Flag := 0; - if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4 - {$ELSE} fChecked {$ENDIF} then - Flag := DFCS_CHECKED; - DrawFrameControl( DC, R1, DFC_BUTTON, DFCS_BUTTONCHECK or - $800 {DFCS_TRANSPARENT} or Flag ); - R.Left := R1.Left + W + Border; - DrawFormattedText( @ Self, DC, R, 0 ); - GraphCtlDrawFocusRect( DC, R ); - end; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GraphicCheckBoxMouse(var Msg: TMsg); -begin if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_LBUTTONDBLCLK) then - ClickGraphCheck( @ Self ); -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GraphicRadioBoxPaint(DC: HDC); -var R, R1: TRect; - Flag: DWORD; - W, H: Integer; - {$IFDEF GRAPHCTL_XPSTYLES} - Theme: THandle; - {$ENDIF} -begin R := DoGraphCtlPrepaint; - {$IFDEF GRAPHCTL_XPSTYLES} - OpenThemeDataProc; - Theme := 0; - if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then - Theme := fOpenThemeDataProc( 0, 'Button' ); - if Theme <> 0 then begin - W := GetSystemMetrics( SM_CXMENUCHECK ); - H := GetSystemMetrics( SM_CYMENUCHECK ); - R1 := R; - R1.Right := R1.Left + W; - if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1 - {$ELSE} fWordWrap {$ENDIF} then - R1.Top := R1.Top + Border - else R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2; - R1.Bottom := R1.Top + H; - Flag := 1; {CBS_UNCHECKEDNORMAL} - if not Enabled then - Flag := 4 {CBS_UNCHECKEDDISABLED} - else if {$IFDEF USE_FLAGS} G4_Hot in fFlagsG4 - {$ELSE} fHot {$ENDIF} then - Flag := 2; {CBS_UNCHECKEDHOT} - if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4 - {$ELSE} fChecked {$ENDIF} then - Inc( Flag, 4 ); - fDrawThemeBackground( Theme, DC, 2 {BP_RADIOBOX}, Flag, @R1, @R ); - R.Left := R1.Left + W + Border; - if fCaption <> '' then begin - DrawFormattedText( @ Self, DC, R, DT_CALCRECT ); - if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1 - {$ELSE} fWordWrap {$ENDIF} then begin - DrawFormattedText( @ Self, DC, R, 0 ); - GraphCtlDrawFocusRect( DC, R ); - end else begin - GraphCtlDrawFocusRect( DC, R ); - DrawFormattedTextXP( Theme, @ Self, DC, R, 2 {BP_RADIOBOX}, Flag, 0, 0 ); - end; - end; - fCloseThemeData( Theme ); - end else - {$ENDIF} - begin W := GetSystemMetrics( SM_CXMENUCHECK ); - H := GetSystemMetrics( SM_CYMENUCHECK ); - R1 := R; - R1.Right := R1.Left + W; - if {$IFDEF USE_FLAGS} G1_WordWrap in fFlagsG1 - {$ELSE} fWordWrap {$ENDIF} then - R1.Top := R1.Top + Border - else R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2; - R1.Bottom := R1.Top + H; - Flag := 0; - if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4 - {$ELSE} fChecked {$ENDIF} then - Flag := DFCS_CHECKED; - DrawFrameControl( DC, R1, DFC_BUTTON, DFCS_BUTTONRADIO - or $800 {DFCS_TRANSPARENT} {or DFCS_ADJUSTRECT} or Flag ); - R.Left := R1.Right + 2; - DrawFormattedText( @ Self, DC, R, 0 ); - GraphCtlDrawFocusRect( DC, R ); - end; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GraphicButtonPaint(DC: HDC); -var R: TRect; - Flag: DWORD; - {$IFDEF GRAPHCTL_XPSTYLES} - Flag1: DWORD; - Theme: THandle; - {$ENDIF} - II: TIconInfo; - BI: TagBitmap; - Y: Integer; - R1: TRect; -begin R := DoGraphCtlPrepaint; - {$IFDEF GRAPHCTL_XPSTYLES} - OpenThemeDataProc; - Theme := 0; - if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then - Theme := fOpenThemeDataProc( 0, 'Button' ); - if Theme <> 0 then begin - Flag := 1; {PBS_UNCHECKEDNORMAL} - if not Enabled then - Flag := 4 {PBS_UNCHECKEDDISABLED} - else - if {$IFDEF USE_FLAGS} G4_Pushed in fFlagsG4 - {$ELSE} fPushed {$ENDIF} then - Flag := 3 {PBS_UNCHECKEDPRESSED} - else - if {$IFDEF USE_FLAGS} G4_Hot in fFlagsG4 - {$ELSE} fHot {$ENDIF} then - Flag := 2; {PBS_UNCHECKEDHOT} - if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4 - {$ELSE} fChecked {$ENDIF} then - Inc( Flag, 4 ); - fDrawThemeBackground( Theme, DC, 1 {BP_PUSHBUTTON}, Flag, @R, @R ); - fGetThemeBackgroundContentRect( Theme, DC, 1 {BS_PUSHBUTTON}, Flag, @R, @R1 ); - GraphCtlDrawFocusRect( DC, R1 ); - if (DF.fButtonIcon <> 0) and GetIconInfo( DF.fButtonIcon, II ) then begin - if GetObject( II.hbmColor, Sizeof( BI ), @ BI ) <> 0 then begin - CASE fVerticalAlign OF - vaTop: Y := R.Top + Border; - vaBottom: Y := R.Bottom - Border - BI.bmHeight; - else {vaCenter:}Y := R.Top + (R.Bottom - R.Top - BI.bmHeight) div 2; - END; - DrawIcon( DC, R.Left + Border, Y, DF.fButtonIcon ); - Inc( R1.Left, BI.bmWidth + Border * 2 ); - end; - DeleteObject( II.hbmColor ); - if II.hbmMask <> 0 then - DeleteObject( II.hbmMask ); - end; - if fCaption <> '' then begin - Flag1 := DT_SINGLELINE; - if WordWrap then Flag1 := DT_WORDBREAK; - DrawFormattedText( @ Self, DC, R1, DT_CALCRECT ); - DrawFormattedTextXP( Theme, @ Self, DC, R1, 1 {BP_PUSHBUTTON}, Flag, - Flag1, 0 ); - end; - fCloseThemeData( Theme ); - end else - {$ENDIF} - begin - Flag := 0; - if {$IFDEF USE_FLAGS} G4_Checked in fFlagsG4 - {$ELSE} fChecked {$ENDIF} then Flag := DFCS_CHECKED - else if {$IFDEF USE_FLAGS} G4_Pushed in fFlagsG4 - {$ELSE} fPushed {$ENDIF} then - Flag := DFCS_PUSHED; - if {$IFDEF USE_FLAGS} G3_Flat in fFlagsG3 - {$ELSE} fFlat {$ENDIF} then - Flag := Flag or DFCS_FLAT; - DrawFrameControl( DC, R, DFC_BUTTON, DFCS_BUTTONPUSH or - $800 {DFCS_TRANSPARENT} or DFCS_ADJUSTRECT or Flag ); - R1 := R; - if (DF.fButtonIcon <> 0) and GetIconInfo( DF.fButtonIcon, II ) then begin - if GetObject( II.hbmColor, Sizeof( BI ), @ BI ) <> 0 then begin - CASE fVerticalAlign OF - vaTop: Y := R.Top + Border; - vaBottom: Y := R.Bottom - Border - BI.bmHeight; - else {vaCenter:}Y := R.Top + (R.Bottom - R.Top - BI.bmHeight) div 2; - END; - DrawIcon( DC, R.Left + Border, Y, DF.fButtonIcon ); - Inc( R1.Left, BI.bmWidth + Border * 2 ); - end; - DeleteObject( II.hbmColor ); - if II.hbmMask <> 0 then DeleteObject( II.hbmMask ); - end; - DrawFormattedText( @ Self, DC, R1, 0 ); - GraphCtlDrawFocusRect( DC, R ); - end; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GraphicButtonMouse(var Msg: TMsg); -var Pt: TPoint; -begin CASE Msg.message OF - WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: - begin GraphButtonSetFocus(@Self); - RefInc; - SetCapture( Parent.Handle ); - Parent.fPushedBtn := @ Self; - {$IFDEF USE_FLAGS} include( fFlagsG4, G4_Pushed ); - {$ELSE} fPushed := TRUE; {$ENDIF} - Invalidate; - end; - WM_LBUTTONUP: - begin - ReleaseCapture; - Invalidate; - if {$IFDEF USE_FLAGS} G4_Pushed in fFlagsG4 - {$ELSE} fPushed {$ENDIF} then begin - Pt.X := SmallInt( LoWord( Msg.lParam ) ); - Pt.Y := SmallInt( HiWord( Msg.lParam ) ); - if PtInRect( ClientRect, Pt ) then DoClick; - {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_Pushed ); - {$ELSE} fPushed := FALSE; {$ENDIF} - Parent.fPushedBtn := nil; - RefDec; - end; - end; - END; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.LeaveGraphButton( Sender: PObj ); -begin {$IFDEF USE_FLAGS} exclude( fFlagsG6, G6_Focused ); - {$ELSE} fFocused := FALSE; {$ENDIF} - if Parent.DF.fCurrentControl = @ Self then - Parent.DF.fCurrentControl := nil; - if ParentForm.DF.fCurrentControl = @ Self then - ParentForm.DF.fCurrentControl := nil; - Invalidate; - {$IFDEF NIL_EVENTS} - if Assigned( EV.fOnLeave ) then - {$ENDIF} - EV.fOnLeave( @ Self ); -end;//////////////////////////////////////////////////////////////////////////// -function TControl.GraphButtonKeyboardProcess(var Msg: TMsg; - var Rslt: Integer): Boolean; -var SpacePressed: Boolean; -begin Result := FALSE; - SpacePressed := Msg.wParam = Word( ' ' ); - {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER} - SpacePressed := SpacePressed or (Msg.wParam = 13); - {$ENDIF} - if not SpacePressed then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - if (Msg.message = WM_KEYDOWN) or (Msg.message = WM_SYSKEYDOWN) then - begin - Parent.fPushedBtn := @ Self; - {$IFDEF USE_FLAGS} include( fFlagsG4, G4_Pushed ); - {$ELSE} fPushed := TRUE; {$ENDIF} - Invalidate; - Result := TRUE; ///// - end else - if (Msg.message = WM_KEYUP) or (Msg.message = WM_SYSKEYUP) then - begin - {$IFDEF USE_FLAGS} exclude( fFlagsG4, G4_Pushed ); - {$ELSE} fPushed := FALSE; {$ENDIF} - Parent.fPushedBtn := nil; - Invalidate; - Result := TRUE; ///// - end else - if (Msg.message = WM_CHAR) or (Msg.message = WM_SYSCHAR) then - begin - DoClick; - Result := TRUE; - end; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GraphicEditPaint(DC: HDC); -var R: TRect; - {$IFDEF GRAPHCTL_XPSTYLES} - R1: TRect; - Flag, Flag1: DWORD; - Theme: THandle; - {$ENDIF} -begin R := ClientRect; - {$IFDEF GRAPHCTL_XPSTYLES} - OpenThemeDataProc; - Theme := 0; - if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then - Theme := fOpenThemeDataProc( 0, 'Edit' ); - if Theme <> 0 then - begin - Flag := 1; {ETS_NORMAL} - if not Enabled then - Flag := 4 {ETS_DISABLED} - else if eoReadonly in DF.fEditOptions then - Flag := 6 {ETS_READONLY} - else if {$IFDEF USE_FLAGS} G6_Focused in fFlagsG6 - {$ELSE} fFocused {$ENDIF} then - Flag := 5 {ETS_FOCUSED} - else if {$IFDEF USE_FLAGS} G4_Hot in fFlagsG4 - {$ELSE} fHot {$ENDIF} then - Flag := 2; {ETS_HOT} - fDrawThemeBackground( Theme, DC, 1 {EP_EDITTEXT}, Flag, @R, @R ); - Inc( R.Left, 2 ); - Dec( R.Right, 2 ); - fGetThemeBackgroundContentRect( Theme, DC, 1 {EP_EDITTEXT}, Flag, @R, @R1 ); - if fCaption <> '' then - begin - Flag1 := DT_SINGLELINE; - if eoMultiline in DF.fEditOptions then - Flag1 := DT_WORDBREAK; - CASE fTextAlign OF - taCenter: Flag1 := Flag1 or DT_CENTER; - taRight: Flag1 := Flag1 or DT_RIGHT; - END; - CASE fVerticalAlign OF - vaCenter: Flag1 := Flag1 or DT_VCENTER; - vaBottom: Flag1 := Flag1 or DT_BOTTOM; - END; - DrawFormattedTextXP( Theme, @ Self, DC, R1, 1 {EP_EDITTEXT}, Flag, - Flag1, 0 ); - end; - fCloseThemeData( Theme ); - end else - {$ENDIF} - begin - if not Assigned( EV.fOnPrepaint ) and not Transparent then begin - Canvas.Brush.Color := fColor; - Canvas.FillRect( R ); - end; - DrawEdge( DC, R, BDR_SUNKENINNER or BDR_SUNKENOUTER, BF_ADJUST or BF_RECT ); - DrawFormattedText( @ Self, DC, R, DT_EDITCONTROL ); - end; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GraphicEditMouse(var Msg: TMsg); -var E: PControl; - Pt: TPoint; -begin CASE Msg.message OF - WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: - if not ( eoReadOnly in DF.fEditOptions ) then begin - E := EditGraphEdit(@Self); - Pt.X := Smallint( LoWord( Msg.lParam ) ) - Left; - Pt.Y := Smallint( HiWord( Msg.lParam ) ) - Top; - PostMessage( E.Handle, Msg.message, Msg.wParam, - Pt.Y shl 16 or Pt.X and $FFFF ); - end; - END; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.LeaveGraphEdit(Sender: PObj); -begin if {$IFDEF USE_FLAGS} not(G6_GraphicCtl in PControl(Sender).fFlagsG6) - {$ELSE} PControl( Sender ).fWindowed {$ENDIF} - and ( DF.fEditCtl <> nil ) then begin - Text := PControl( Sender ).Text; - DF.fEditCtl := nil; - Visible := TRUE; - ParentForm.DF.fCurrentControl := @ Self; - Parent.DF.fCurrentControl := @ Self; - Parent.Postmsg( CM_QUIT, DWORD( Sender ), 0 ); - end else - if Assigned( DF.fEditCtl ) then - DF.fEditCtl.EV.fLeave( DF.fEditCtl ); -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.ChangeGraphEdit(Sender: PObj); -begin Text := PControl( Sender ).Text; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.DestroyGraphEdit(Sender: PObj); -begin - DF.fEditCtl := nil; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GraphCtlDrawFocusRect(DC: HDC; const R: TRect); -var rgn: HRgn; -begin if {$IFDEF USE_FLAGS} (G6_Focused in fFlagsG6) - {$ELSE} fFocused {$ENDIF} - and (GetActiveWindow = ParentForm.Handle) then begin - BeginPath( DC ); - Canvas.FrameRect( R ); - EndPath( DC ); - Canvas.FrameRect( R ); - DrawFocusRect( DC, R ); - rgn := PathToRegion( DC ); - ExtSelectClipRgn( DC, rgn, RGN_DIFF ); - DeleteObject( rgn ); - end; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.GroupBoxPaint(DC: HDC); -var bk_erased: Boolean; - procedure DoEraseBkgnd; - var R: TRect; - begin - bk_erased := TRUE; - If Assigned( EV.fOnEraseBkgnd ) then - EV.fOnEraseBkgnd( @ Self, DC ) - else begin - R := BoundsRect; - OffsetRect( R, -R.Left, -R.Top ); - SetBkMode( DC, OPAQUE ); - SetBkColor( DC, Color2RGB( fColor ) ); - SetBrushOrgEx( DC, 0, 0, nil ); - Windows.FillRect( DC, R, Global_GetCtlBrushHandle( @ Self ) ); - End; - end; -var R, R1, R0: TRect; - rgn, rgn2, rgntxt, rgnsav, rgnsavall: HRgn; - i: Integer; - C: PControl; - {$IFDEF GRAPHCTL_XPSTYLES} - Theme: THandle; - Flag: DWORD; - {$ENDIF} -begin if not DF.fErasingBkgnd then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - R := ClientRect; - Dec( R.Top, 14 { Self_.fClientTop div 2 } ); - Dec( R.Left, fClientLeft ); - Inc( R.Right, fClientRight ); - Inc( R.Bottom, fClientBottom ); - rgnsavall := CreateRectRgn( 0, 0, 0, 0 ); - GetClipRgn( DC, rgnsavall ); - TRY - For i := 0 to ChildCount-1 do begin - C := Children[ i ]; - If {$IFDEF USE_FLAGS} (G6_GraphicCtl in C.fFlagsG6) - {$ELSE} not C.fWindowed {$ENDIF} - and {$IFDEF USE_FLAGS} (F3_Visible in C.fStyle.f3_Style) - {$ELSE} C.fVisible {$ENDIF} then begin - rgn := CreateRectRgnIndirect( C.BoundsRect ); - ExtSelectClipRgn( DC, rgn, RGN_DIFF ); - DeleteObject( rgn ); - End; - End; - {$IFDEF GRAPHCTL_XPSTYLES} - OpenThemeDataProc; - Theme := 0; - if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then - Theme := fOpenThemeDataProc( 0, 'Button' ); - If Theme <> 0 then begin - DoEraseBkgnd; - Flag := 1; {GBS_NORMAL} - if not Enabled then Flag := 2; {GBS_DISABLED} - R1 := R; - rgnsav := 0; - if fCaption <> '' then - begin - R1.Top := 0; - Inc( R1.Left, 8 ); - Dec( R1.Right, 8 ); - BeginPath( DC ); - DrawFormattedTextXP( Theme, @ Self, DC, R1, 4 {BP_GROUPBOX}, Flag, 0, 0 ); - EndPath( DC ); - rgntxt := PathToRegion( DC ); - if rgntxt = 0 then begin - R1.Right := R1.Left + Canvas.TextWidth( fCaption ); - R1.Bottom := R1.Top + Canvas.TextHeight( fCaption ); - rgntxt := CreateRectRgnIndirect( R1 ); - end; - DrawFormattedTextXP( Theme, @ Self, DC, R1, 4 {BP_GROUPBOX}, Flag, 0, 0 ); - GetRgnBox( rgntxt, R0 ); - Dec( R0.Left, 3 ); - Inc( R0.Right, 3 ); - DeleteObject( rgntxt ); - rgn := CreateRectRgnIndirect( R0 ); - end else rgn := 0; - if rgn <> 0 then - begin - rgnsav := CreateRectRgn( 0, 0, 0, 0 ); - GetClipRgn( DC, rgnsav ); - ExtSelectClipRgn( DC, rgn, RGN_DIFF ); - DeleteObject( rgn ); - end; - fDrawThemeBackground( Theme, DC, 4 {BP_GROUPBOX}, Flag, @R, @R ); - if rgnsav <> 0 then begin - SelectClipRgn( DC, rgnsav ); - DeleteObject( rgnsav ); - end; - fCloseThemeData( Theme ); - end else - {$ENDIF} - begin - bk_erased := FALSE; - R1 := R; - R1.Top := 0; - R1.Bottom := ClientRect.Top; - Inc( R1.Left, 16 ); - Dec( R1.Right, 16 ); - fVerticalAlign := vaCenter; - BeginPath( DC ); - Canvas.TextOut( R1.Left, R1.Top, fCaption ); - EndPath( DC ); - Canvas.TextOut( R1.Left, R1.Top, fCaption ); - rgntxt := PathToRegion( DC ); - if rgntxt = 0 then // такое - в случае шрифта по умолчанию! - begin - R1.Right := R1.Left + Canvas.TextWidth( fCaption ); - R1.Bottom := R1.Top + Canvas.TextHeight( fCaption ); - rgntxt := CreateRectRgnIndirect( R1 ); - end; - - GetRgnBox( rgntxt, R0 ); - rgn2 := CreateRectRgnIndirect( R0 ); - - rgnsav := CreateRectRgn( 0, 0, 0, 0 ); - GetClipRgn( DC, rgnsav ); - ExtSelectClipRgn( DC, rgn2, RGN_DIFF ); - DeleteObject( rgn2 ); - - BeginPath( DC ); - DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT ); - EndPath( DC ); - rgn := PathToRegion( DC ); - if rgn = 0 then DoEraseBkgnd; - DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT ); - - SelectClipRgn( DC, rgnsav ); - DeleteObject( rgnsav ); - - if rgn <> 0 then - begin - ExtSelectClipRgn( DC, rgn, RGN_DIFF ); - DeleteObject( rgn ); - end; - ExtSelectClipRgn( DC, rgntxt, RGN_DIFF ); - DeleteObject( rgntxt ); - - if not bk_erased then DoEraseBkgnd; - End; - FINALLY - SelectClipRgn( DC, rgnsavall ); - DeleteObject( rgnsavall ); - END; -end; -{$ENDIF USE_GRAPHCTLS}//-------------------------------------------------------- - -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -function TControl.MakeWordWrap: PControl; -begin {$IFDEF USE_FLAGS} include( fFlagsG1, G1_WordWrap ); - {$ELSE} fWordWrap := TRUE; {$ENDIF} - if IsButton then - Style := fStyle.Value or BS_MULTILINE - else - Style := fStyle.Value and not SS_LEFTNOWORDWRAP; - Result := @ Self; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -function ParentAnchorChildren( Sender: PControl; var Msg: TMsg; - var Rslt: Integer ): Boolean; -var NewW, NewH: Integer; - dW, dH: Integer; - i: Integer; - C: PControl; - {$IFNDEF ANCHORS_WM_SIZE} - CR: TRect; - {$ENDIF} -begin Result := FALSE; - If (Msg.message = {$IFDEF ANCHORS_WM_SIZE} WM_SIZE {$ELSE} WM_WINDOWPOSCHANGED {$ENDIF} ) - and not IsIconic(Sender.Handle) then begin - {$IFDEF ANCHORS_WM_SIZE} - NewW := LoWord( Msg.lParam ); - NewH := HiWord( Msg.lParam ); - {$ELSE} - CR := Sender.ClientRect; - NewW := CR.Right; - NewH := CR.Bottom; - {$ENDIF} - dW := NewW - Sender.fOldWidth; - dH := NewH - Sender.fOldHeight; - For i := 0 to Sender.ChildCount - 1 do begin - C := Sender.Children[ i ]; - If dW <> 0 then begin - if C.AnchorRight and C.AnchorLeft then - C.Width := C.Width + dW - else if C.AnchorRight then - C.Left := C.Left + dW; - End; - If dH <> 0 then begin - if C.AnchorBottom and C.AnchorTop then - C.Height := C.Height + dH - else if C.AnchorBottom then - C.Top := C.Top + dH; - End; - End; - Sender.fOldWidth := NewW; - Sender.fOldHeight := NewH; - End; -end;//////////////////////////////////////////////////////////////////////////// -function TControl.Anchor(aLeft, aTop, aRight, aBottom: Boolean): PControl; -begin if (not aLeft) and aRight then - AnchorLeft := FALSE - else AnchorLeft := aLeft; - if (not aTop) and aBottom then - AnchorTop := FALSE - else AnchorTop := aTop; - AnchorRight := aRight; - AnchorBottom := aBottom; - Result := @ Self; -end; -function TControl.GetLBTopIndex: Integer; -begin Result := Perform(LB_GETTOPINDEX,0,0); -end;//////////////////////////////////////////////////////////////////////////// -function TControl.LBItemAtPos(X, Y: Integer): Integer; -var R: TRect; - P: TPoint; - i: Integer; -begin P := MakePoint(X,Y); - For i := LBTopIndex to Count -1 do begin - Perform(LB_GETITEMRECT, i , Integer(@R)); - if PointInRect(P,R) then begin - Result := i; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - end; - End; - Result := -1; -end;//////////////////////////////////////////////////////////////////////////// -procedure TControl.SetLBTopIndex(const Value: Integer); -begin Perform(LB_SETTOPINDEX,Value,0); end;///////////////////////////////////// -{$ENDIF WIN_GDI}//-------------------------------------------------------------- -{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} -function TControl.FormGetIntParam: Integer; -var C: Byte; - Sign, Cont: Boolean; -begin Result := 0; - While TRUE do begin - C := Byte( DF.FormParams^ ); - inc( DF.FormParams ); - Cont := C and 1 <> 0; - C := C shr 1; - If Cont then - Result := (Result shl 7) or C - else begin - Sign := C and 1 <> 0; - C := C shr 1; - Result := (Result shl 6) or C; - if Sign then - Result := -Result; - break; - End; - End; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function TControl.FormGetColorParam: Integer; -begin Result := FormGetIntParam; - Result := (Result shr 1) or (Result shl 31); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure TControl.FormGetStrParam; -var i: Integer; -begin i := FormGetIntParam; - SetString( FormString, DF.FormParams, i ); - inc( DF.FormParams, i ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure TControl.FormCreateParameters( - alphabet: PFormInitFuncArray; - params: PAnsiChar ); -begin DF.FormCurrentParent := @Self; - DF.FormLastCreatedChild := @Self; - DF.FormParams := params; - DF.FormAlphabet := alphabet; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure TControl.FormExecuteCommands(AForm: PControl; ControlPtrOffsets: PSmallIntArray); -var N: Integer; - Ctrl: PPcontrol; -begin while {FormParams <> ''} TRUE do begin - N := FormGetIntParam; - if N = 0 then - break; - if N < 0 then - begin - N := -N; - Ctrl := PPControl( Pointer( Integer(AForm) - + (ControlPtrOffsets[0] shl 2) ) ); - ControlPtrOffsets := Pointer( Integer( ControlPtrOffsets ) + 2 ); - Ctrl^ := DF.FormAlphabet[N-1]( @Self ); - DF.FormLastCreatedChild := Ctrl^; - end else begin - Ctrl := @ DF.FormLastCreatedChild; - PFormInitFuncArray1( DF.FormAlphabet )[N-1]( Ctrl^, 1 ); - end; - end; - FormString := ''; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION} -procedure FormPrepareStrParamCreateCtrl; -asm PUSH EAX - CALL TControl.FormGetStrParam - POP ECX - MOV EAX, [ECX].TControl.DF.FormCurrentParent - MOV EDX, [ECX].TControl.FormString -end;//////////////////////////////////////////////////////////////////////////// -procedure FormPrepareIntParamCreateCtrl; -asm PUSH EAX - CALL TControl.FormGetIntParam - XCHG EDX, EAX - POP ECX - MOV EAX, [ECX].TControl.DF.FormCurrentParent -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewLabel( Form: PControl ): PControl; -begin Form.FormGetStrParam; - Result := NewLabel( Form.DF.FormCurrentParent, Form.FormString ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewWordWrapLabel( Form: PControl ): PControl; -begin Form.FormGetStrParam; - Result := NewWordWrapLabel( Form.DF.FormCurrentParent, Form.FormString ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewLabelEffect( Form: PControl ): PControl; -var Shd: Integer; -begin Form.FormGetStrParam; - Shd := Form.FormGetIntParam; - Result := NewLabelEffect( Form.DF.FormCurrentParent, Form.FormString, Shd ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewButton( Form: PControl ): PControl; -begin Form.FormGetStrParam; - Result := NewButton( Form.DF.FormCurrentParent, Form.FormString ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -function FormNewBitBtn( Form: PControl ): PControl; -type PBitBtnOptions = ^TBitBtnOptions; -var Cap: KOLString; - i, j, k, bmp: Integer; -begin Form.FormGetStrParam; - Cap := Form.FormString; - i := Form.FormGetIntParam; - j := Form.FormGetIntParam; - Form.FormGetStrParam; - k := Form.FormGetIntParam; - bmp := 0; - if Form.FormString <> '' then - bmp := LoadBmp( hInstance, PKOLChar( KOLString( Form.FormString ) ), Form ); - Result := NewBitBtn( Form.DF.FormCurrentParent, Cap, - PBitBtnOptions( @i )^, - TGlyphLayout( j ), - bmp, k ); -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewPanel( Form: PControl ): PControl; -begin Result := NewPanel( Form.DF.FormCurrentParent, - TEdgeStyle( Form.FormGetIntParam ) ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -function FormNewGradientPanel( Form: PControl ): PControl; -var C1, C2: TColor; -begin C1 := Form.FormGetColorParam; - C2 := Form.FormGetColorParam; - Result := NewGradientPanel( Form.DF.FormCurrentParent, C1, C2 ); -end;//////////////////////////////////////////////////////////////////////////// -function FormNewGradientPanelEx( Form: PControl ): PControl; -var C1, C2: TColor; - Style, Layout: Integer; -begin C1 := Form.FormGetColorParam; - C2 := Form.FormGetColorParam; - Style := Form.FormGetIntParam; - Layout := Form.FormGetIntParam; - Result := NewGradientPanelEx( Form.DF.FormCurrentParent, C1, C2, - TGradientStyle( Style ), TGradientLayout( Layout ) ); -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -function FormNewGroupbox( Form: PControl ): PControl; -begin Form.FormGetStrParam; - Result := NewGroupbox( Form.DF.FormCurrentParent, - Form.FormString ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -function FormNewPaintbox( Form: PControl ): PControl; -begin Result := NewPaintbox( Form.DF.FormCurrentParent ); end;////////////////// -function FormNewImageShow( Form: PControl ): PControl; -begin Result := NewImageShow( Form.DF.FormCurrentParent, nil, 0 ); end;///////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewEditBox( Form: PControl ): PControl; -type PEditOptions = ^TEditOptions; -var i: Integer; -begin i := Form.FormGetIntParam; - Result := NewEditbox( Form.DF.FormCurrentParent, PEditOptions( @ i )^ ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF USE_RICHEDIT}/////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewRichEdit( Form: PControl ): PControl; -type PEditOptions = ^TEditOptions; -var i: Integer; -begin i := Form.FormGetIntParam; - Result := NewRichEdit( Form.DF.FormCurrentParent, - PEditOptions( @ i )^ ); -end; -{$ENDIF PAS_VERSION} -{$ENDIF USE_RICHEDIT}/////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewComboBox( Form: PControl ): PControl; -type PComboOptions = ^TComboOptions; -var i: Integer; -begin i := Form.FormGetIntParam; - Result := NewCombobox( Form.DF.FormCurrentParent, PComboOptions( @ i )^ ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewCheckbox( Form: PControl ): PControl; -begin Form.FormGetStrParam; - Result := NewCheckbox( Form.DF.FormCurrentParent, Form.FormString ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewRadiobox( Form: PControl ): PControl; -begin Form.FormGetStrParam; - Result := NewRadiobox( Form.DF.FormCurrentParent, Form.FormString ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -function FormNewSplitter( Form: PControl ): PControl; -var p, n: Integer; -begin p := Form.FormGetIntParam; - n := Form.FormGetIntParam; - Result := NewSplitter( Form.DF.FormCurrentParent, p, n ); -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE} -function FormNewListbox( Form: PControl ): PControl; -type PListOptions = ^TListOptions; -var i: Integer; -begin i := Form.FormGetIntParam; - Result := NewListbox( Form.DF.FormCurrentParent, PListOptions( @ i )^ ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -function FormNewListView( Form: PControl ): PControl; -type PListViewOptions = ^TListViewOptions; -var lvs: TListViewStyle; - i: Integer; -begin lvs := TListViewStyle( Form.FormGetIntParam ); - i := Form.FormGetIntParam; - Result := NewListView( Form.DF.FormCurrentParent, - lvs, PListViewOptions( @i )^, - nil, nil, nil ); -end;//////////////////////////////////////////////////////////////////////////// -function FormNewTreeView( Form: PControl ): PControl; -type PTreeViewOptions = ^TTreeViewOptions; -var i: Integer; -begin i := Form.FormGetIntParam; - Result := NewTreeView( Form.DF.FormCurrentParent, - PTreeViewOptions( @i )^, - nil, nil ); -end;//////////////////////////////////////////////////////////////////////////// -function FormNewScrollbox( Form: PControl ): PControl; -type PScrollerBars = ^TScrollerBars; -var es: TEdgeStyle; - b: Integer; -begin es := TEdgeStyle( Form.FormGetIntParam ); - b := Form.FormGetIntParam; - Result := NewScrollbox( Form.DF.FormCurrentParent, es, PScrollerBars( @ b )^ ); -end;//////////////////////////////////////////////////////////////////////////// -function FormNewScrollboxEx( Form: PControl ): PControl; -begin Result := NewScrollboxEx( Form.DF.FormCurrentParent, - TEdgeStyle( Form.FormGetIntParam ) ); -end;//////////////////////////////////////////////////////////////////////////// -function FormNewScrollBar( Form: PControl ): PControl; -begin Result := NewScrollbar( Form.DF.FormCurrentParent, - TScrollerBar( Form.FormGetIntParam ) ); -end;//////////////////////////////////////////////////////////////////////////// -function FormNewProgressBar( Form: PControl ): PControl; -begin Result := NewProgressBar( Form.DF.FormCurrentParent ); end;/////////////// -function FormNewProgressBarEx( Form: PControl ): PControl; -type PProgressbarOptions = ^TProgressbarOptions; -begin Result := NewProgressBarEx( Form.DF.FormCurrentParent, - PProgressbarOptions(Form.FormGetIntParam)^ ); -end;//////////////////////////////////////////////////////////////////////////// -function FormNewDateTimePicker( Form: PControl ): PControl; -type PDateTimePickerOptions = ^TDateTimePickerOptions; -var o: Integer; -begin o := Form.FormGetIntParam; - Result := NewDateTimePicker( Form.DF.FormCurrentParent, - PDateTimePickerOptions( @ o )^ ); -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF _D4orHigher} -function FormNewTabControl( Form: PControl ): PControl; -type PTabControlOptions = ^TTabControlOptions; -var N, i, o: Integer; - Tabs1: array of KOLString; - Tabs2: array of PKOLChar; -begin N := Form.FormGetIntParam; - SetLength( Tabs1, N ); - SetLength( Tabs2, N ); - for i := 0 to N-1 do - begin - Form.FormGetStrParam; - Tabs1[i] := Form.FormString; - Tabs2[i] := PKOLChar( Tabs1[i] ); - end; - o := Form.FormGetIntParam; - i := Form.FormGetIntParam; - Result := NewTabControl( Form.DF.FormCurrentParent, - Tabs2, - PTabControlOptions(@ o)^, - nil, i ); - SetLength( Tabs1, 0 ); - SetLength( Tabs2, 0 ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ENDIF PAS_VERSION}//////////////////////////////////////// -function ParentForm_PCharParam(Control: PControl): PKOLChar; -var Form: PControl; -begin Form := Control.FormParentForm; - Form.FormGetStrParam; - Result := PKOLChar( KOLString( Form.FormString ) ); -end;//////////////////////////////////////////////////////////////////////////// -function ParentForm_IntParamPas(Form: PControl): Integer; -begin Result := Form.FormParentForm.FormGetIntParam; end;/////////////////////////// -function ParentForm_ColorParamPas(Form: PControl): Integer; -begin Result := Form.FormParentForm.FormGetColorParam; end;///////////////////////// -{$IFDEF ASM_VERSION} // only to call from asm -- returns EAX=Parent Form, EDX=ECX=PChar param -{$ENDIF ASM_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetSize( Form: PControl ); -var W, H: Integer; -begin W := ParentForm_IntParamPas( Form ); - H := ParentForm_IntParamPas( Form ); - Form.SetSize( W, H ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -procedure FormSetHeight( Form: PControl ); -begin Form.Height := ParentForm_IntParamPas(Form); end;///////////////////////// -procedure FormSetWidth( Form: PControl ); -begin Form.Width := ParentForm_IntParamPas(Form); end;////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetPosition( Form: PControl ); -var X, Y: Integer; -begin X := ParentForm_IntParamPas(Form); - Y := ParentForm_IntParamPas(Form); - Form.SetPosition( X, Y ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetClientSize( Form: PControl ); -var W, H: Integer; -begin W := ParentForm_IntParamPas(Form); - H := ParentForm_IntParamPas(Form); - Form.SetClientSize( W, H ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetAlign( Form: PControl ); -begin Form.SetAlign( TControlAlign( ParentForm_IntParamPas(Form) ) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF USE_NAMES} -procedure FormSetName( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - Form.FormGetStrParam; - C.SetName( Form, Form.FormString ); -end; -{$ENDIF USE_NAMES}////////////////////////////////////////////////////////////// -procedure FormSetTag( Form: PControl ); -var tag: DWORD; -begin - tag := ParentForm_IntParamPas(Form); - Form.Tag := tag; -end; -{$IFDEF UNICODE_CTRLS} -procedure FormSetUnicode( Form: PControl ); -begin Form.SetUnicode( TRUE ); end; -{$ENDIF UNICODE_CTRLS}////////////////////////////////////////////////////////// -procedure FormAssignHelpContext( Form: PControl ); -begin Form.AssignHelpContext( ParentForm_IntParamPas( Form ) ); end;//////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetCanResizeFalse( Form: PControl ); -begin Form.CanResize := FALSE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormInitMenu( Form: PControl ); -begin Form.Perform( WM_INITMENU, 0, 0 ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSizeGripFalse( Form: PControl ); -begin Form.SizeGrip := FALSE; end; ///////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetExStyle( Form: PControl ); -begin Form.ExStyle := Form.ExStyle or DWORD( ParentForm_IntParamPas(Form) ); end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetVisibleFalse( Form: PControl ); -begin Form.Visible := FALSE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetEnabledFalse( Form: PControl ); -begin Form.Enabled := FALSE; end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormResetStyles( Form: PControl ); -begin Form.Style := Form.Style and not ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetStyle( Form: PControl ); -begin Form.Style := Form.Style or DWORD( ParentForm_IntParamPas(Form)); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetAlphaBlend( Form: PControl ); -begin Form.AlphaBlend := ParentForm_IntParamPas( Form ); end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetHasBorderFalse( Form: PControl ); -begin Form.HasBorder := FALSE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetHasCaptionFalse( Form: PControl ); -begin Form.HasCaption := FALSE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormResetCtl3D( Form: PControl ); -begin Form.Ctl3D := FALSE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormIconLoad_hInstance( Form: PControl ); -begin Form.IconLoad( hInstance, - MAKEINTRESOURCE( ParentForm_IntParamPas(Form) ) ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormIconLoadCursor_0( Form: PControl ); -begin Form.IconLoadCursor( 0, MakeIntResource( ParentForm_IntParamPas(Form) ) ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetIconNeg1( Form: PControl ); -begin Form.Icon := THandle( -1 ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormIconLoad_hInstance_str( Form: PControl ); -begin Form.FormGetStrParam; - Form.IconLoad( hInstance, PKOLChar( KOLString( Form.FormString ) ) ); -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetWindowState( Form: PControl ); -begin Form.WindowState := TWindowState( ParentForm_IntParamPas(Form) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormCursorLoad_0( Form: PControl ); -begin Form.CursorLoad( 0, MAKEINTRESOURCE( ParentForm_IntParamPas(Form) ) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormCursorLoad_hInstance( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - Form.FormGetStrParam; - C.CursorLoad( 0, PKOLChar( KOLString( Form.FormString ) ) ); -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetColor( Form: PControl ); -begin Form.Color := ParentForm_ColorParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetBrushStyle( Form: PControl ); -begin Form.Brush.BrushStyle := TBrushStyle( ParentForm_IntParamPas(Form) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetBrushBitmap( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - {$IFDEF UNICODE_CTRLS} - Form.FormGetStrParam; - {$ENDIF} - C.Brush.BrushBitmap := - LoadBmp( hInstance, - {$IFDEF UNICODE_CTRLS} PKOLChar( KOLString( Form.FormString ) ) - {$ELSE} ParentForm_PCharParam(Form) - {$ENDIF} , Form ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetFontColor( Form: PControl ); -begin Form.Font.Color := ParentForm_ColorParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetFontStyles( Form: PControl ); -type PFontStyle = ^TFontStyle; -var fs: Byte; -begin fs := ParentForm_IntParamPas(Form); - Form.Font.FontStyle := PFontStyle( @ fs )^; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetFontHeight( Form: PControl ); -begin Form.Font.FontHeight := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetFontWidth( Form: PControl ); -begin Form.Font.FontWidth := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure ParentForm_StrParam( Form: PControl ); -begin Form := Form.FormParentForm; - Form.FormGetStrParam; -end;//////////////////////////////////////////////////////////////////////////// -procedure FormSetFontName( Form: PControl ); -begin ParentForm_StrParam(Form); - Form.Font.FontName := Form.FormParentForm.FormString; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetFontOrientation( Form: PControl ); -begin Form.Font.FontOrientation := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetFontCharset( Form: PControl ); -begin Form.Font.FontCharset := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetFontPitch( Form: PControl ); -begin Form.Font.FontPitch := TFontPitch( ParentForm_IntParamPas(Form) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetBorder( Form: PControl ); -begin Form.Border := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMarginTop( Form: PControl ); -begin Form.MarginTop := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMarginBottom( Form: PControl ); -begin Form.MarginBottom := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMarginLeft( Form: PControl ); -begin Form.MarginLeft := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMarginRight( Form: PControl ); -begin Form.MarginRight := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetSimpleStatusText( Form: PControl ); -begin Form.SimpleStatusText := ParentForm_PCharParam(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetStatusText( Form: PControl ); -var I: Integer; -begin I := ParentForm_IntParamPas(Form); - Form.StatusText[I] := ParentForm_PCharParam(Form); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormRemoveCloseIcon( Form: PControl ); -begin DeleteMenu( GetSystemMenu( Form.GetWindowHandle, False ), - SC_CLOSE, MF_BYCOMMAND ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetEraseBkgndTrue( Form: PControl ); -begin Form.EraseBackground := TRUE; end; -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMinWidth( Form: PControl ); -begin Form.MinWidth := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMaxWidth( Form: PControl ); -begin Form.MaxWidth := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMinHeight( Form: PControl ); -begin Form.MinHeight := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMaxHeight( Form: PControl ); -begin Form.MaxHeight := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF noASM_VERSION} -procedure FormSetRepeatInterval( Form: PControl ); -asm CALL ParentForm_IntParamAsm - MOV [EAX].TControl.fRepeatInterval, EDX -end; -{$ELSE PAS_VERSION} -procedure FormSetRepeatInterval( Form: PControl ); -begin Form.RepeatInterval := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetKeyPreviewTrue( Form: PControl ); -begin {$IFDEF KEY_PREVIEW} - Form.KeyPreview := TRUE; - {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetTextShiftX( Form: PControl ); -begin Form.TextShiftX := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetTextShiftY( Form: PControl ); -begin Form.TextShiftY := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetColor2( Form: PControl ); -begin Form.Color2 := ParentForm_ColorParamPas( Form ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetTextAlign( Form: PControl ); -begin Form.TextAlign := TTextAlign( ParentForm_IntParamPas(Form) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetTextVAlign( Form: PControl ); -begin Form.VerticalAlign := TVerticalAlign( ParentForm_IntParamPas(Form) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetTabStopFalse( Form: PControl ); -begin Form.TabStop := FALSE; end; -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetIgnoreDefault( Form: PControl ); -begin Form.IgnoreDefault := Boolean( ParentForm_IntParamPas(Form) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetHintText( Form: PControl ); -begin {$IFDEF USE_MHTOOLTIP} - ParentForm_StrParam(Form); - Form.Hint.Text := Form.FormParentForm.FormString; - {$ENDIF USE_MHTOOLTIP} -end;//////////////////////////////////////////////////////////////////////////// -procedure FormSetAnchor( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - Form.AnchorLeft := I and 1 <> 0; - Form.AnchorTop := I and 2 <> 0; - Form.AnchorRight := I and 4 <> 0; - Form.AnchorBottom := I and 8 <> 0; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetCaption( Form: PControl ); -var Ctl: PControl; -begin Ctl := Form; - Form := Form.FormParentForm; - Form.FormGetStrParam; - Ctl.Caption := Form.FormString; -end; -{$ENDIF PAS_VERSION} -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetGradienStyle( Form: PControl ); -begin Form.GradientStyle := TGradientStyle( ParentForm_IntParamPas(Form) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormOverrideScrollbars( Form: PControl ); -begin OverrideScrollbars( Form ); end; -{$IFDEF USE_RICHEDIT} -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetRE_AutoFontFalse( Form: PControl ); -begin Form.RE_AutoFont := FALSE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetRE_AutoFontSizeAdjustFalse( Form: PControl ); -begin Form.RE_AutoFontSizeAdjust := FALSE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetRE_DualFontTrue( Form: PControl ); -begin Form.RE_DualFont := TRUE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetRE_UIFontsTrue( Form: PControl ); -begin Form.RE_UIFonts := TRUE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetRE_IMECancelCompleteTrue( Form: PControl ); -begin Form.RE_IMECancelComplete := TRUE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetRE_IMEAlwaysSendNotifyTrue( Form: PControl ); -begin Form.RE_IMEAlwaysSendNotify := TRUE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMaxTextSize( Form: PControl ); -begin Form.MaxTextSize := DWORD( ParentForm_IntParamPas(Form) ); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetRE_AutoKeyboardTrue( Form: PControl ); -begin Form.RE_AutoKeyboard := TRUE; end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetRE_DisableOverwriteChangeTrue( Form: PControl ); -begin Form.RE_DisableOverwriteChange := TRUE; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetRE_Zoom( Form: PControl ); -var zoom: TSmallPoint; -begin zoom.X := ParentForm_IntParamPas(Form); - zoom.Y := ParentForm_IntParamPas(Form); - Form.RE_Zoom := zoom; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$ENDIF USE_RICHEDIT} -procedure FormSetListItems( Form: PControl ); -var N, i: Integer; -begin N := ParentForm_IntParamPas(Form); - for i := 0 to N-1 do BEGIN - ParentForm_StrParam(Form); - Form.Items[i] := Form.FormParentForm.FormString; - END; -end; -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetCount( Form: PControl ); -begin Form.Count := ParentForm_IntParamPas(Form); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetDroppedWidth( Form: PControl ); -begin Form.DroppedWidth := ParentForm_IntParamPas(Form); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetButtonIcon( Form: PControl ); -begin - Form.SetButtonIcon( LoadImage( hInstance, - ParentForm_PCharParam(Form), - IMAGE_ICON, 0, 0, $8000 {LR_SHARED} ) ); -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetButtonImage( Form: PControl ); -var w, h: Integer; -begin w := ParentForm_IntParamPas(Form); - h := ParentForm_IntParamPas(Form); - Form.SetButtonIcon( LoadImage( hInstance, - ParentForm_PCharParam(Form), - IMAGE_ICON, w, h, $8000 {LR_SHARED} ) ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetButtonBitmap( Form: PControl ); -begin Form.SetButtonBitmap( LoadBitmap( hInstance, - ParentForm_PCharParam(Form) ) ); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetDefaultBtn( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - Form.SetDefaultBtn( i, TRUE ); -end; -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetMaxProgress( Form: PControl ); -begin Form.MaxProgress := ParentForm_IntParamPas(Form); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetProgress( Form: PControl ); -begin Form.Progress := ParentForm_IntParamPas(Form); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormLVColumsAdd( Form: PControl ); -var N, i, w: Integer; -begin N := ParentForm_IntParamPas(Form); - for i := 0 to N-1 do BEGIN - w := ParentForm_IntParamPas(Form); - ParentForm_StrParam(Form); - Form.LVColAdd( Form.FormParentForm.FormString, taLeft, w ); - END; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetLVColOrder( Form: PControl ); -var N, i: Integer; -begin N := ParentForm_IntParamPas(Form); - i := ParentForm_IntParamPas(Form); - Form.LVColOrder[N] := i; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetLVColImage( Form: PControl ); -var N, i: Integer; -begin N := ParentForm_IntParamPas(Form); - i := ParentForm_IntParamPas(Form); - Form.LVColImage[N] := i; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetTVIndent( Form: PControl ); -begin Form.TVIndent := ParentForm_IntParamPas(Form); -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetTBBtnImgWidth( Form: PControl ); -begin Form.TBBtnImgWidth := ParentForm_IntParamPas( Form ); -end;//////////////////////////////////////////////////////////////////////////// -procedure FormTBAddBitmap( Form: PControl ); -var map: array[ 0..1 ] of TColor; - b: Integer; - C: PControl; -begin C := Form; - Form := Form.FormParentForm; - b := Form.FormGetIntParam; - if b >= 0 then - begin - Form.FormGetStrParam; - if b <> 0 then - begin - map[0] := Form.FormGetColorParam; - map[1] := Color2RGB( clBtnFace ); - b := LoadMappedBitmapEx( Form, hInstance, PKOLChar( KOLString( Form.FormString )), map ); - end else - b := LoadBmp( hInstance, PKOLChar(KOLString(Form.FormString)), Form ); - end; - C.TBAddBitmap( b ); -end;//////////////////////////////////////////////////////////////////////////// -procedure FormSetTBButtonSize( Form: PControl ); -begin Form.Perform( TB_SETBUTTONSIZE, 0, - ParentForm_IntParamPas(Form) or $10000 {or (HiWord(HW) shl 16)} ); -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF _D4orHigher} -procedure FormTBSetTooltips( Form: PControl ); -var A1: array of KOLString; - A2: array of PKOLChar; - N, i: Integer; - C: PControl; -begin C := Form; - Form := Form.FormParentForm; - N := Form.FormGetIntParam; - SetLength( A1, N ); - SetLength( A2, N ); - for i := 0 to N-1 do - begin - Form.FormGetStrParam; - A1[i] := Form.FormString; - A2[i] := PKOLChar( A1[i] ); - end; - C.TBSetTooltips( 0, A2 ); - SetLength( A1, 0 ); - SetLength( A2, 0 ); -end; -{$ENDIF _D4orHigher}//////////////////////////////////////////////////////////// -procedure FormSetTBButtonsMinWidth( Form: PControl ); -begin Form.TBButtonsMinWidth := ParentForm_IntParamPas(Form); -end;//////////////////////////////////////////////////////////////////////////// -procedure FormSetTBButtonsMaxWidth( Form: PControl ); -begin Form.TBButtonsMaxWidth := ParentForm_IntParamPas(Form); -end;//////////////////////////////////////////////////////////////////////////// -procedure FormHideToolbarButton( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - {$IFDEF USE_GRUSH} - ShowHideToolbarButton( Form, i, FALSE ); - {$ELSE} Form.TBButtonVisible[ i ] := FALSE; {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -procedure FormDisableToolbarButton( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - {$IFDEF USE_GRUSH} - EnableToolbarButton( Form, i, FALSE ); - {$ELSE} Form.TBButtonEnabled[ i ] := FALSE; {$ENDIF} -end;//////////////////////////////////////////////////////////////////////////// -procedure FormFixFlatXPToolbar( Form: PControl ); -begin Form.OnTBCustomDraw := nil; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetDateTimeFormat( Form: PControl ); -begin ParentForm_StrParam(Form); - Form.DateTimeFormat := Form.FormParentForm.FormString; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetDateTimeColor( Form: PControl ); -var i: Integer; - C: TColor; -begin C := ParentForm_ColorParamPas( Form ); - i := ParentForm_IntParamPas( Form ); - Form.DateTimePickerColors[TDateTimePickerColor(i)] := C; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetCurrentTab( Form: PControl ); -var i: Integer; -begin i := ParentForm_IntParamPas(Form); - Form.CurIndex := i; - Form.Pages[i].BringToFront; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetCurIdx( Form: PControl ); -begin Form.CurIndex := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetSBMin( Form: PControl ); -begin Form.SBMin := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetSBMax( Form: PControl ); -begin Form.SBMax := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetSBPosition( Form: PControl ); -begin Form.SBPosition := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetSBPageSize( Form: PControl ); -begin Form.SBPageSize := ParentForm_IntParamPas(Form); end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormLastCreatedChildAsNewCurrentParent( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - Form.DF.FormCurrentParent := C; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetUpperParent( Form: PControl ); -begin Form := Form.FormParentForm; - Form.DF.FormCurrentParent := Form.DF.FormCurrentParent.Parent; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL} -procedure FormSetTabpageAsParent( Form: PControl ); -var i: Integer; - C: PControl; -begin C := Form; - Form := Form.FormParentForm; - i := Form.FormGetIntParam; - Form.DF.FormCurrentParent := C.Pages[i]; - Form.DF.FormLastCreatedChild := Form.DF.FormCurrentParent; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE PASCAL}////////////////////////////////////////////// -procedure FormSetCurCtl( Form: PControl ); -var i: Integer; - C: PControl; -begin Form := Form.FormParentForm; - i := Form.FormGetIntParam; - C := PPControl(Integer( Form.DF.FormAddress ) + i * 4)^; - if C = nil then C := Form; - Form.DF.FormLastCreatedChild := C; -end; -{$ENDIF PAS_VERSION}//////////////////////////////////////////////////////////// -procedure FormSetParent( Form: PControl ); -var C: PControl; -begin C := Form; - Form := Form.FormParentForm; - Form.DF.FormCurrentParent := C; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE}///////////////////////////////////////////////////// -procedure FormSetEvent( Form: PControl ); -type TSetEventProc = procedure( TargetCtl: PControl; const event: TOnEvent ); -var C: PControl; - idx_handler, idx_setter: Integer; - handler, setter: Pointer; - event: TOnEvent; - set_proc: TSetEventProc; -begin C := Form; - Form := Form.FormParentForm; - idx_handler := Form.FormGetIntParam; - idx_setter := Form.FormGetIntParam; - handler := @Form.DF.FormAlphabet[idx_handler]; - setter := @Form.DF.FormAlphabet[idx_setter]; - set_proc := TSetEventProc( setter ); - Pointer( TMethod( event ).Code ) := handler; - TMethod( event ).Data := Form.DF.FormObj; - set_proc( PControl( C ), event ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -{$IFDEF ASM_VERSION}{$ELSE}///////////////////////////////////////////////////// -procedure FormSetIndexedEvent( Form: PControl ); -type TSetIndexedEventProc = procedure( TargetCtl: PControl; Index: Integer; - const event: TOnEvent ); -var C: PControl; - idx_handler, idx_setter, idx: Integer; - handler, setter: Pointer; - event: TOnEvent; - set_proc: TSetIndexedEventProc; -begin C := Form; - Form := Form.FormParentForm; - idx_handler := Form.FormGetIntParam; - idx := Form.FormGetIntParam; - idx_setter := Form.FormGetIntParam; - handler := @Form.DF.FormAlphabet[idx_handler]; - setter := @Form.DF.FormAlphabet[idx_setter]; - set_proc := TSetIndexedEventProc( setter ); - Pointer( TMethod( event ).Code ) := handler; - TMethod( event ).Data := Form.DF.FormObj; - set_proc( PControl( C ), idx, event ); -end; -{$ENDIF}//////////////////////////////////////////////////////////////////////// -procedure DummyOverrideScrollbars(Sender: PControl); -begin -end; - -{$IFnDEF PAS_VERSION} - {$I KOL_ASM.inc} //<<<<<<<<<<<<<<<<<<<<<<< KOL_ASM.inc - {$IFnDEF UNICODE_CTRLS} - {$I KOL_ASM_NOUNICODE.inc} //<<<<<<<<< KOL_ASM_NOUNICODE.inc - {$ENDIF noUNICODE} -{$ENDIF PAS_VERSION} -{$IFDEF LIN} - {$DEFINE implementation} {$I KOL_Linux.inc} {$UNDEF implementation} -{$ENDIF LIN} - -{$IFDEF USE_CUSTOMEXTENSIONS} - {$I CUSTOM_CODE_EXTENSION.inc} // See comments in TControl -{$ENDIF USE_CUSTOMEXTENSIONS} - -{$IFDEF EVENTS_DYNAMIC}//------------------------------------------------------- -{$IFDEF ASM_VERSION} -function TControl.ProvideUniqueEvents: PEvents; -const Size_TEvents = Sizeof(TEvents); -asm PUSH ESI - XCHG ESI, EAX - MOV EAX, [ESI].TControl.EV - CMP EAX, offset[EmptyEvents] - JNZ @@ready - - MOV EAX, Size_TEvents - CALL System.@GetMem - MOV [ESI].TControl.EV, EAX - PUSH EAX - XCHG EDX, EAX - MOV EAX, offset[EmptyEvents] - MOV ECX, Size_TEvents - CALL Move - PUSH ESI - PUSH offset[FreeEV] - XCHG EAX, ESI - CALL TControl.Add2AutoFreeEx - POP EAX -@@ready: - POP ESI -end; -{$ELSE} -function TControl.ProvideUniqueEvents: PEvents; -begin if EV = @EmptyEvents then - begin - GetMem( EV, Sizeof(TEvents) ); - Move( EmptyEvents, EV^, Sizeof(TEvents) ); - Add2AutoFreeEx( FreeEV ); - end; - Result := EV; -end; {$ENDIF PAS_VERSION}/////////////////////////////////////////////////////// - -procedure TControl.FreeEV; -begin FreeMem( EV ); - EV := @EmptyEvents; -end;//////////////////////////////////////////////////////////////////////////// -function TControl.Get_OnHelp: TOnHelp; -begin Result := EV.fOnHelp; end; -procedure TControl.Set_OnHelp(const Value: TOnHelp); -begin ProvideUniqueEvents.fOnHelp := Value; end; -function TControl.Get_OnBitBtnDraw: TOnBitBtnDraw; -begin Result := EV.FOnBitBtnDraw; end; -procedure TControl.Set_OnBitBtnDraw(const Value: TOnBitBtnDraw); -begin ProvideUniqueEvents.FOnBitBtnDraw := Value; end; -function TControl.Get_OnMeasureItem: TOnMeasureItem; -begin Result := EV.fOnMeasureItem; end; -function TControl.Get_OnShow: TOnEvent; -begin Result := EV.fOnShow; end; -function TControl.Get_OnHide: TOnEvent; -begin Result := EV.fOnHide; end; -function TControl.Get_OnClose: TOnEventAccept; -begin Result := EV.fOnClose; end; -function TControl.Get_OnQueryEndSession: TOnEventAccept; -begin Result := EV.fOnQueryEndSession; end; -function TControl.Get_OnPaint: TOnPaint; -begin Result := EV.fOnPaint; end; -function TControl.Get_OnPrePaint: TOnPaint; -begin Result := EV.fOnPrepaint; end; -procedure TControl.Set_OnPrePaint(const Value: TOnPaint); -begin ProvideUniqueEvents.fOnPrepaint := Value; end; -function TControl.Get_OnPostPaint: TOnPaint; -begin Result := EV.fOnPostPaint; end; -procedure TControl.Set_OnPostPaint(const Value: TOnPaint); -begin ProvideUniqueEvents.fOnPostPaint := Value; end; -function TControl.Get_OnEraseBkgnd: TOnPaint; -begin Result := EV.fOnEraseBkgnd; end; -procedure TControl.Set_OnEraseBkgnd(const Value: TOnPaint); -begin ProvideUniqueEvents.fOnEraseBkgnd := Value; - AttachProc( WndProcEraseBkgnd ); -end;//////////////////////////////////////////////////////////////////////////// -function TControl.Get_OnClick: TOnEvent; -begin Result := EV.fOnClick; end; -function TControl.Get_OnResize: TOnEvent; -begin Result := EV.fOnResize; end; -function TControl.Get_OnMove: TOnEvent; -begin Result := EV.fOnMove; end; -function TControl.Get_OnMoving: TOnEventMoving; -begin Result := EV.fOnMoving; end; -function TControl.Get_OnSplit: TOnSplit; -begin Result := EV.FOnSplit; end; -procedure TControl.Set_OnSplit(const Value: TOnSplit); -begin ProvideUniqueEvents.FOnSplit := Value; end; -function TControl.Get_OnKeyDown: TOnKey; -begin Result := EV.fOnKeyDown; end; -function TControl.Get_OnKeyUp: TOnKey; -begin Result := EV.fOnKeyUp; end; -function TControl.Get_OnChar: TOnChar; -begin Result := EV.fOnChar; end; -function TControl.Get_OnDeadChar: TOnChar; -begin Result := EV.fOnDeadChar; end; -function TControl.Get_OnMouseUp: TOnMouse; -begin Result := EV.fOnMouseUp; end; -function TControl.Get_OnMouseDown: TOnMouse; -begin Result := EV.fOnMouseDown; end; -function TControl.Get_OnMouseMove: TOnMouse; -begin Result := EV.fOnMouseMove; end; -function TControl.Get_OnMouseDblClk: TOnMouse; -begin Result := EV.fOnMouseDblClk; end; -function TControl.Get_OnMouseWheel: TOnMouse; -begin Result := EV.fOnMouseWheel; end; -function TControl.Get_OnMouseEnter: TOnEvent; -begin Result := EV.fOnMouseEnter; end; -function TControl.Get_OnMouseLeave: TOnEvent; -begin Result := EV.fOnMouseLeave; end; -function TControl.Get_OnTestMouseOver: TOnTestMouseOver; -begin Result := EV.fOnTestMouseOver; end; -function TControl.Get_OnEndEditLVItem: TOnEditLVItem; -begin Result := EV.fOnEndEditLVItem; end; -function TControl.Get_OnDeleteLVItem: TOnDeleteLVItem; -begin Result := EV.fOnDeleteLVItem; end; -function TControl.Get_OnLVData: TOnLVData; -begin Result := EV.fOnLVData; end; -function TControl.Get_OnCompareLVItems: TOnCompareLVItems; -begin Result := EV.fOnCompareLVItems; end; -procedure TControl.Set_OnCompareLVItems(const Value: TOnCompareLVItems); -begin ProvideUniqueEvents.fOnCompareLVItems := Value; end; -function TControl.Get_OnColumnClick: TOnLVColumnClick; -begin Result := EV.fOnColumnClick; end; -function TControl.Get_OnLVStateChange: TOnLVStateChange; -begin Result := EV.FOnLVStateChange; end; -function TControl.Get_OnDrawItem: TOnDrawItem; -begin Result := EV.fOnDrawItem; end; -function TControl.Get_OnLVCustomDraw: TOnLVCustomDraw; -begin Result := EV.fOnLVCustomDraw; end; -function TControl.Get_OnTVBeginDrag: TOnTVBeginDrag; -begin Result := EV.FOnTVBeginDrag; end; -procedure TControl.Set_OnTVBeginDrag(const Value: TOnTVBeginDrag); -begin ProvideUniqueEvents.FOnTVBeginDrag := Value; end; -function TControl.Get_OnTVBeginEdit: TOnTVBeginEdit; -begin Result := EV.FOnTVBeginEdit; end; -procedure TControl.Set_OnTVBeginEdit(const Value: TOnTVBeginEdit); -begin ProvideUniqueEvents.FOnTVBeginEdit := Value; end; -function TControl.Get_OnTVEndEdit: TOnTVEndEdit; -begin Result := EV.FOnTVEndEdit; end; -procedure TControl.Set_OnTVEndEdit(const Value: TOnTVEndEdit); -begin ProvideUniqueEvents.fOnTVEndEdit := Value; end; -function TControl.Get_OnTVExpanding: TOnTVExpanding; -begin Result := EV.FOnTVExpanding; end; -procedure TControl.Set_OnTVExpanding(const Value: TOnTVExpanding); -begin ProvideUniqueEvents.FOnTVExpanding := Value; end; -function TControl.Get_OnTVExpanded: TOnTVExpanded; -begin Result := EV.FOnTVExpanded; end; -procedure TControl.Set_OnTVExpanded(const Value: TOnTVExpanded); -begin ProvideUniqueEvents.FOnTVExpanded := Value; end; -function TControl.Get_OnTVDelete: TOnTVDelete; -begin Result := EV.FOnTVDelete; end; -function TControl.Get_OnTVSelChanging: TOnTVSelChanging; -begin Result := EV.fOnTVSelChanging; end; -procedure TControl.Set_OnTVSelChanging(const Value: TOnTVSelChanging); -begin ProvideUniqueEvents.FOnTVSelChanging := Value; end; -function TControl.Get_OnDTPUserString: TDTParseInputEvent; -begin Result := EV.FOnDTPUserString; end; -procedure TControl.Set_OnDTPUserString(const Value: TDTParseInputEvent); -begin ProvideUniqueEvents.FOnDTPUserString := Value; end; -function TControl.Get_OnSBBeforeScroll: TOnSBBeforeScroll; -begin Result := EV.FOnSBBeforeScroll; end; -procedure TControl.Set_OnSBBeforeScroll(const Value: TOnSBBeforeScroll); -begin ProvideUniqueEvents.fOnSBBeforeScroll := Value; end; -function TControl.Get_OnSBScroll: TOnSBScroll; -begin Result := EV.FOnSBScroll; end; -procedure TControl.Set_OnSBScroll(const Value: TOnSBScroll); -begin ProvideUniqueEvents.FOnSBScroll := Value; end; -function TControl.Get_OnScroll: TOnScroll; -begin Result := EV.fOnScroll; end; -function TControl.Get_OnMessage: TOnMessage; -begin Result := EV.fOnMessage; end; -procedure TControl.Set_OnMessage(const Value: TOnMessage); -begin ProvideUniqueEvents.fOnMessage := Value; end; -function TControl.Get_TOnEvent(const Index: Integer): TOnEvent; -begin Result := TOnEvent( EV.MethodEvents[Index] ); end; -procedure TControl.Set_TOnEvent(const Index: Integer; const Value: TOnEvent); -begin ProvideUniqueEvents.MethodEvents[Index] := TMethod( Value ); end; -function TControl.Get_OnDropFiles: TOnDropFiles; -begin Result := EV.fOnDropFiles; end; -{$ENDIF EVENTS_DYNAMIC}//------------------------------------------------------- -{$IFnDEF NOT_USE_RICHEDIT} -procedure TControl.FreeCharFormatRec; -begin {$IFnDEF STATIC_RICHEDIT_DATA} FreeMem( DF.fRECharFormatRec ); {$ENDIF} end; -{$ENDIF} -function TControl.GetAnchor(const Index: Integer): Boolean; -begin Result := fAnchors and Index <> 0; end; -procedure TControl.SetAnchor(const Index: Integer; const Value: Boolean); -begin if Value then - fAnchors := fAnchors or Index - else fAnchors := fAnchors and not Index; - if Parent <> nil then - begin - fParent.AttachProc( ParentAnchorChildren ); - Parent.fOldWidth := Parent.ClientWidth; - Parent.fOldHeight := Parent.ClientHeight; - end; -end;//////////////////////////////////////////////////////////////////////////// -function TControl.Get_StatusWnd: HWND; -begin Result := 0; - if fStatusCtl <> nil then - Result := fStatusCtl.GetWindowHandle; -end;//////////////////////////////////////////////////////////////////////////// -function TControl.Get_Prop_Int(PropName: PKOLChar): Integer; -begin Result := GetProp( GetWindowHandle, PropName ); end; -procedure TControl.Set_Prop_Int(PropName: PKOLChar; const Value: Integer); -begin SetProp( GetWindowHandle, PropName, Value ); end; -function TControl.GetHelpContext: Integer; -begin Result := 0; - if fHandle <> 0 then - Result := GetWindowContextHelpId( fHandle ); -end;//////////////////////////////////////////////////////////////////////////// -function TControl.Get_Ctl3D: Boolean; -begin Result := fCtl3D_child and 2 <> 0; end; -procedure TControl.ResetEvent(idx: Integer); -begin TMethod( EV.MethodEvents[idx] ).Code := DummyProcTable[ InitEventsTable[ idx ] and $F ]; - TMethod( EV.MethodEvents[idx] ).Data := nil; -end;//////////////////////////////////////////////////////////////////////////// -{$IFDEF COMMANDACTIONS_OBJ} -{ TCommandActionsObj } -{$IFDEF ASM_VERSION}//////////////////////////////////////////////////////////// -destructor TCommandActionsObj.Destroy; -asm MOV EDX, [EAX].fIndexInActions - MOV dword ptr [EDX*4+AllActions_Objs], 0 - CALL TObj.Destroy -end; {$ELSE}//////////////////////////////////////////////////////////////////// -destructor TCommandActionsObj.Destroy; -begin AllActions_Objs[fIndexInActions] := nil; - inherited; -end; {$ENDIF}/////////////////////////////////////////////////////////////////// -{$ENDIF} -{$IFDEF GRAPHCTL_XPSTYLES}{$DEFINE INIT_FINIT}{$ENDIF} -{$IFDEF USE_NAMES}{$DEFINE INIT_FINIT}{$ENDIF} -{$IFNDEF NOT_UNLOAD_RICHEDITLIB}{$IFDEF UNLOAD_RICHEDITLIB} - {$DEFINE INIT_FINIT} -{$ENDIF}{$ENDIF} -{$IFDEF INIT_FINIT}//----------------------------------------------------------- -//****************************************************************************** -initialization //............................................................... -{$IFDEF GRAPHCTL_XPSTYLES} - CheckThemes; - if AppTheming then - InitThemes; -{$ENDIF} -finalization //................................................................. -{$IFDEF GRAPHCTL_XPSTYLES} - if AppTheming then - DeinitThemes; -{$ENDIF} -{$IFNDEF NOT_UNLOAD_RICHEDITLIB} -{$IFDEF UNLOAD_RICHEDITLIB} - if FRichEditModule <> 0 then - FreeLibrary( FRichEditModule ); -{$ENDIF UNLOAD_RICHEDITLIB} -{$ENDIF} -{$ENDIF INIT_FINIT}//----------------------------------------------------------- - -end. - - - - - - - - diff --git a/plugins/ImportTXT/kol/kolmath.pas b/plugins/ImportTXT/kol/kolmath.pas deleted file mode 100644 index 9e06418343..0000000000 --- a/plugins/ImportTXT/kol/kolmath.pas +++ /dev/null @@ -1,1845 +0,0 @@ -{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - - KKKKK KKKKK OOOOOOOOO LLLLL - KKKKK KKKKK OOOOOOOOOOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKKKKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOO OOOOO LLLLL - KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL - KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL - - Key Objects Library (C) 2000 by Kladov Vladimir. - - mailto: vk@kolmck.net - Home: http://kolmck.net - - =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-} -{ - This code is grabbed from standard math.pas unit, - provided by Borland Delphi. This unit is for working with - engineering (mathematical) functions. The main difference - is that err unit specially designed to handle exceptions - for KOL is used instead of SysUtils. This allows to make - size of the executable smaller for about 5K. though this - value is insignificant for project made with VCL, it can - be more than 15% of executable file size made with KOL. -} - -{*******************************************************} -{ } -{ Borland Delphi Runtime Library } -{ Math Unit } -{ } -{ Copyright (C) 1996,99 Inprise Corporation } -{ } -{*******************************************************} - -unit kolmath; - -{ This unit contains high-performance arithmetic, trigonometric, logorithmic, - statistical and financial calculation routines which supplement the math - routines that are part of the Delphi language or System unit. } - -{$N+,S-} - -{$I KOLDEF.INC} - -interface - -uses {$IFNDEF MATH_NOERR} err, {$ENDIF} kol; - -const { Ranges of the IEEE floating point types, including denormals } - MinSingle = 1.5e-45; - MaxSingle = 3.4e+38; - MinDouble = 5.0e-324; - MaxDouble = 1.7e+308; - MinExtended = 3.4e-4932; - MaxExtended = 1.1e+4932; - MinComp = -9.223372036854775807e+18; - MaxComp = 9.223372036854775807e+18; - -{----------------------------------------------------------------------- -References: - -1) P.J. Plauger, "The Standard C Library", Prentice-Hall, 1992, Ch. 7. -2) W.J. Cody, Jr., and W. Waite, "Software Manual For the Elementary - Functions", Prentice-Hall, 1980. -3) Namir Shammas, "C/C++ Mathematical Algorithms for Scientists and Engineers", - McGraw-Hill, 1995, Ch 8. -4) H.T. Lau, "A Numerical Library in C for Scientists and Engineers", - CRC Press, 1994, Ch. 6. -5) "Pentium(tm) Processor User's Manual, Volume 3: Architecture - and Programming Manual", Intel, 1994 -+6)Уоррен Младший, "Арифметические трюки для программистов", исправленное изд., - 2004 - -All angle parameters and results of trig functions are in radians. - -Most of the following trig and log routines map directly to Intel 80387 FPU -floating point machine instructions. Input domains, output ranges, and -error handling are determined largely by the FPU hardware. -Routines coded in assembler favor the Pentium FPU pipeline architecture. ------------------------------------------------------------------------} - -function EAbs( D: Double ): Double; -function EMax( const Values: array of Double ): Double; -function EMin( const Values: array of Double ): Double; -function ESign( X: Extended ): Integer; -function iMax( const Values: array of Integer ): Integer; -function iMin( const Values: array of Integer ): Integer; -function iSign( i: Integer ): Integer; - -{ Trigonometric functions } -function ArcCos(X: Extended): Extended; { IN: |X| <= 1 OUT: [0..PI] radians } -function ArcSin(X: Extended): Extended; { IN: |X| <= 1 OUT: [-PI/2..PI/2] radians } - -{ ArcTan2 calculates ArcTan(Y/X), and returns an angle in the correct quadrant. - IN: |Y| < 2^64, |X| < 2^64, X <> 0 OUT: [-PI..PI] radians } -function ArcTan2(Y, X: Extended): Extended; - -{ SinCos is 2x faster than calling Sin and Cos separately for the same angle } -procedure SinCos(Theta: Extended; var Sin, Cos: Extended) register; -function Tan(X: Extended): Extended; -function Cotan(X: Extended): Extended; { 1 / tan(X), X <> 0 } -function Hypot(X, Y: Extended): Extended; { Sqrt(X**2 + Y**2) } - -{ Angle unit conversion routines } -function DegToRad(Degrees: Extended): Extended; { Radians := Degrees * PI / 180} -function RadToDeg(Radians: Extended): Extended; { Degrees := Radians * 180 / PI } -function GradToRad(Grads: Extended): Extended; { Radians := Grads * PI / 200 } -function RadToGrad(Radians: Extended): Extended; { Grads := Radians * 200 / PI } -function CycleToRad(Cycles: Extended): Extended; { Radians := Cycles * 2PI } -function RadToCycle(Radians: Extended): Extended;{ Cycles := Radians / 2PI } - -{ Hyperbolic functions and inverses } -function Cosh(X: Extended): Extended; -function Sinh(X: Extended): Extended; -function Tanh(X: Extended): Extended; -function ArcCosh(X: Extended): Extended; { IN: X >= 1 } -function ArcSinh(X: Extended): Extended; -function ArcTanh(X: Extended): Extended; { IN: |X| <= 1 } - -{ Logorithmic functions } -function LnXP1(X: Extended): Extended; { Ln(X + 1), accurate for X near zero } -function Log10(X: Extended): Extended; { Log base 10 of X} -function Log2(X: Extended): Extended; { Log base 2 of X } -function LogN(Base, X: Extended): Extended; { Log base N of X } - -{ Exponential functions } - -{ IntPower: Raise base to an integral power. Fast. } -//function IntPower(Base: Extended; Exponent: Integer): Extended register; -// -- already defined in kol.pas - -{ Power: Raise base to any power. - For fractional exponents, or |exponents| > MaxInt, base must be > 0. } -function Power(Base, Exponent: Extended): Extended; -{$IFNDEF _D6orHigher} -function Trunc( X: Extended ): Int64; -{$ENDIF} - -{ Miscellaneous Routines } - -{ Frexp: Separates the mantissa and exponent of X. } -procedure Frexp(X: Extended; var Mantissa: Extended; var Exponent: Integer) register; - -{ Ldexp: returns X*2**P } -function Ldexp(X: Extended; P: Integer): Extended register; - -{ Ceil: Smallest integer >= X, |X| < MaxInt } -function Ceil(X: Extended):Integer; - -{ Floor: Largest integer <= X, |X| < MaxInt } -function Floor(X: Extended): Integer; - -{ Poly: Evaluates a uniform polynomial of one variable at value X. - The coefficients are ordered in increasing powers of X: - Coefficients[0] + Coefficients[1]*X + ... + Coefficients[N]*(X**N) } -function Poly(X: Extended; const Coefficients: array of Double): Extended; - -{----------------------------------------------------------------------- -Statistical functions. - -Common commercial spreadsheet macro names for these statistical and -financial functions are given in the comments preceding each function. ------------------------------------------------------------------------} - -{ Mean: Arithmetic average of values. (AVG): SUM / N } -function Mean(const Data: array of Double): Extended; - -{ Sum: Sum of values. (SUM) } -function Sum(const Data: array of Double): Extended register; -function SumInt(const Data: array of Integer): Integer register; -function SumOfSquares(const Data: array of Double): Extended; -procedure SumsAndSquares(const Data: array of Double; - var Sum, SumOfSquares: Extended) register; - -{ MinValue: Returns the smallest signed value in the data array (MIN) } -function MinValue(const Data: array of Double): Double; -function MinIntValue(const Data: array of Integer): Integer; - -function Min(A,B: Integer): Integer; -{$IFDEF _D4orHigher} -overload; -function Min(A,B: I64): I64; overload; -function Min(A,B: Int64): Int64; overload; -function Min(A,B: Single): Single; overload; -function Min(A,B: Double): Double; overload; -function Min(A,B: Extended): Extended; overload; -{$ENDIF} - -{ MaxValue: Returns the largest signed value in the data array (MAX) } -function MaxValue(const Data: array of Double): Double; -function MaxIntValue(const Data: array of Integer): Integer; - -function Max(A,B: Integer): Integer; -{$IFDEF _D4orHigher} -overload; -function Max(A,B: I64): I64; overload; -function Max(A,B: Single): Single; overload; -function Max(A,B: Double): Double; overload; -function Max(A,B: Extended): Extended; overload; -{$ENDIF} - -{ Standard Deviation (STD): Sqrt(Variance). aka Sample Standard Deviation } -function StdDev(const Data: array of Double): Extended; - -{ MeanAndStdDev calculates Mean and StdDev in one call. } -procedure MeanAndStdDev(const Data: array of Double; var Mean, StdDev: Extended); - -{ Population Standard Deviation (STDP): Sqrt(PopnVariance). - Used in some business and financial calculations. } -function PopnStdDev(const Data: array of Double): Extended; - -{ Variance (VARS): TotalVariance / (N-1). aka Sample Variance } -function Variance(const Data: array of Double): Extended; - -{ Population Variance (VAR or VARP): TotalVariance/ N } -function PopnVariance(const Data: array of Double): Extended; - -{ Total Variance: SUM(i=1,N)[(X(i) - Mean)**2] } -function TotalVariance(const Data: array of Double): Extended; - -{ Norm: The Euclidean L2-norm. Sqrt(SumOfSquares) } -function Norm(const Data: array of Double): Extended; - -{ MomentSkewKurtosis: Calculates the core factors of statistical analysis: - the first four moments plus the coefficients of skewness and kurtosis. - M1 is the Mean. M2 is the Variance. - Skew reflects symmetry of distribution: M3 / (M2**(3/2)) - Kurtosis reflects flatness of distribution: M4 / Sqr(M2) } -procedure MomentSkewKurtosis(const Data: array of Double; - var M1, M2, M3, M4, Skew, Kurtosis: Extended); - -{ RandG produces random numbers with Gaussian distribution about the mean. - Useful for simulating data with sampling errors. } -function RandG(Mean, StdDev: Extended): Extended; - -{----------------------------------------------------------------------- -Financial functions. Standard set from Quattro Pro. - -Parameter conventions: - -From the point of view of A, amounts received by A are positive and -amounts disbursed by A are negative (e.g. a borrower's loan repayments -are regarded by the borrower as negative). - -Interest rates are per payment period. 11% annual percentage rate on a -loan with 12 payments per year would be (11 / 100) / 12 = 0.00916667 - ------------------------------------------------------------------------} - -type - TPaymentTime = (ptEndOfPeriod, ptStartOfPeriod); - -{ Double Declining Balance (DDB) } -function DoubleDecliningBalance(Cost, Salvage: Extended; - Life, Period: Integer): Extended; - -{ Future Value (FVAL) } -function FutureValue(Rate: Extended; NPeriods: Integer; Payment, PresentValue: - Extended; PaymentTime: TPaymentTime): Extended; - -{ Interest Payment (IPAYMT) } -function InterestPayment(Rate: Extended; Period, NPeriods: Integer; PresentValue, - FutureValue: Extended; PaymentTime: TPaymentTime): Extended; - -{ Interest Rate (IRATE) } -function InterestRate(NPeriods: Integer; - Payment, PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; - -{ Internal Rate of Return. (IRR) Needs array of cash flows. } -function InternalRateOfReturn(Guess: Extended; - const CashFlows: array of Double): Extended; - -{ Number of Periods (NPER) } -function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended; - PaymentTime: TPaymentTime): Extended; - -{ Net Present Value. (NPV) Needs array of cash flows. } -function NetPresentValue(Rate: Extended; const CashFlows: array of Double; - PaymentTime: TPaymentTime): Extended; - -{ Payment (PAYMT) } -function Payment(Rate: Extended; NPeriods: Integer; - PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; - -{ Period Payment (PPAYMT) } -function PeriodPayment(Rate: Extended; Period, NPeriods: Integer; - PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; - -{ Present Value (PVAL) } -function PresentValue(Rate: Extended; NPeriods: Integer; - Payment, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; - -{ Straight Line depreciation (SLN) } -function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended; - -{ Sum-of-Years-Digits depreciation (SYD) } -function SYDDepreciation(Cost, Salvage: Extended; Life, Period: Integer): Extended; - -{type - EInvalidArgument = class(EMathError) end;} - -{------------------------------------------------------------------------------} -{ Integer and logical functions } -function IsPowerOf2( i: Integer ): Boolean; -{* TRUE, если число является степенью числа 2 } - -function Low1( i: Integer ): Integer; -{* Выделяет младший бит 1 из числа i. } - -function Low0( i: Integer ): Integer; -{* Выделяет младший справа бит 0 из числа i, например, 1100011 -> 100 } - -function count_1_bits_in_byte( x: Byte ): Byte; -{* Подсчитывает число единичных битов в байте } - -function count_1_bits_in_dword( x: Integer ): Integer; -{* Подсчитывает число единичных битов в 32-битном } - - -implementation - -{$IFNDEF _D2orD3} -uses SysConst; -{$ENDIF} - -function EAbs( D: Double ): Double; -begin - Result := D; - if Result < 0.0 then - Result := -Result; -end; - -function EMax( const Values: array of Double ): Double; -var I: Integer; -begin - Result := Values[ 0 ]; - for I := 1 to High( Values ) do - if Result < Values[ I ] then Result := Values[ I ]; -end; - -function EMin( const Values: array of Double ): Double; -var I: Integer; -begin - Result := Values[ 0 ]; - for I := 1 to High( Values ) do - if Result > Values[ I ] then Result := Values[ I ]; -end; - -function ESign( X: Extended ): Integer; -begin - if X < 0 then Result := -1 - else if X > 0 then Result := 1 - else Result := 1; -end; - -function iMax( const Values: array of Integer ): Integer; -var I: Integer; -begin - Result := Values[ 0 ]; - for I := 1 to High( Values ) do - if Result < Values[ I ] then Result := Values[ I ]; -end; - -function iMin( const Values: array of Integer ): Integer; -var I: Integer; -begin - Result := Values[ 0 ]; - for I := 1 to High( Values ) do - if Result > Values[ I ] then Result := Values[ I ]; -end; - -{$IFDEF PAS_VERSION} -function iSign( i: Integer ): Integer; -begin - if i < 0 then Result := -1 - else if i > 0 then Result := 1 - else Result := 0; -end; -{$ELSE} -function iSign( i: Integer ): Integer; -asm - XOR EDX, EDX - TEST EAX, EAX - JZ @@exit - MOV DL, 1 - JG @@exit - OR EDX, -1 -@@exit: - XCHG EAX, EDX -end; -{$ENDIF} - -function Annuity2(R: Extended; N: Integer; PaymentTime: TPaymentTime; - var CompoundRN: Extended): Extended; Forward; -function Compound(R: Extended; N: Integer): Extended; Forward; -function RelSmall(X, Y: Extended): Boolean; Forward; - -type - TPoly = record - Neg, Pos, DNeg, DPos: Extended - end; - -const - MaxIterations = 15; - -{$IFNDEF MATH_NOERR} -procedure ArgError(const Msg: string); -begin - raise Exception.Create(e_Math_InvalidArgument, Msg); -end; -{$ENDIF} - -function DegToRad(Degrees: Extended): Extended; { Radians := Degrees * PI / 180 } -begin - Result := Degrees * (PI / 180); -end; - -function RadToDeg(Radians: Extended): Extended; { Degrees := Radians * 180 / PI } -begin - Result := Radians * (180 / PI); -end; - -function GradToRad(Grads: Extended): Extended; { Radians := Grads * PI / 200 } -begin - Result := Grads * (PI / 200); -end; - -function RadToGrad(Radians: Extended): Extended; { Grads := Radians * 200 / PI} -begin - Result := Radians * (200 / PI); -end; - -function CycleToRad(Cycles: Extended): Extended; { Radians := Cycles * 2PI } -begin - Result := Cycles * (2 * PI); -end; - -function RadToCycle(Radians: Extended): Extended;{ Cycles := Radians / 2PI } -begin - Result := Radians / (2 * PI); -end; - -function LnXP1(X: Extended): Extended; -{ Return ln(1 + X). Accurate for X near 0. } -asm - FLDLN2 - MOV AX,WORD PTR X+8 { exponent } - FLD X - CMP AX,$3FFD { .4225 } - JB @@1 - FLD1 - FADD - FYL2X - JMP @@2 -@@1: - FYL2XP1 -@@2: - FWAIT -end; - -{ Invariant: Y >= 0 & Result*X**Y = X**I. Init Y = I and Result = 1. } -{function IntPower(X: Extended; I: Integer): Extended; -var - Y: Integer; -begin - Y := Abs(I); - Result := 1.0; - while Y > 0 do begin - while not Odd(Y) do - begin - Y := Y shr 1; - X := X * X - end; - Dec(Y); - Result := Result * X - end; - if I < 0 then Result := 1.0 / Result -end; -} -(* -- already defined in kol.pas -function IntPower(Base: Extended; Exponent: Integer): Extended; -asm - mov ecx, eax - cdq - fld1 { Result := 1 } - xor eax, edx - sub eax, edx { eax := Abs(Exponent) } - jz @@3 - fld Base - jmp @@2 -@@1: fmul ST, ST { X := Base * Base } -@@2: shr eax,1 - jnc @@1 - fmul ST(1),ST { Result := Result * X } - jnz @@1 - fstp st { pop X from FPU stack } - cmp ecx, 0 - jge @@3 - fld1 - fdivrp { Result := 1 / Result } -@@3: - fwait -end; -*) - -function Compound(R: Extended; N: Integer): Extended; -{ Return (1 + R)**N. } -begin - Result := IntPower(1.0 + R, N) -end; - -function Annuity2(R: Extended; N: Integer; PaymentTime: TPaymentTime; - var CompoundRN: Extended): Extended; -{ Set CompoundRN to Compound(R, N), - return (1+Rate*PaymentTime)*(Compound(R,N)-1)/R; -} -begin - if R = 0.0 then - begin - CompoundRN := 1.0; - Result := N; - end - else - begin - { 6.1E-5 approx= 2**-14 } - if EAbs(R) < 6.1E-5 then - begin - CompoundRN := Exp(N * LnXP1(R)); - Result := N*(1+(N-1)*R/2); - end - else - begin - CompoundRN := Compound(R, N); - Result := (CompoundRN-1) / R - end; - if PaymentTime = ptStartOfPeriod then - Result := Result * (1 + R); - end; -end; {Annuity2} - - -procedure PolyX(const A: array of Double; X: Extended; var Poly: TPoly); -{ Compute A[0] + A[1]*X + ... + A[N]*X**N and X * its derivative. - Accumulate positive and negative terms separately. } -var - I: Integer; - Neg, Pos, DNeg, DPos: Extended; -begin - Neg := 0.0; - Pos := 0.0; - DNeg := 0.0; - DPos := 0.0; - for I := High(A) downto Low(A) do - begin - DNeg := X * DNeg + Neg; - Neg := Neg * X; - DPos := X * DPos + Pos; - Pos := Pos * X; - if A[I] >= 0.0 then - Pos := Pos + A[I] - else - Neg := Neg + A[I] - end; - Poly.Neg := Neg; - Poly.Pos := Pos; - Poly.DNeg := DNeg * X; - Poly.DPos := DPos * X; -end; {PolyX} - - -function RelSmall(X, Y: Extended): Boolean; -{ Returns True if X is small relative to Y } -const - C1: Double = 1E-15; - C2: Double = 1E-12; -begin - Result := EAbs(X) < (C1 + C2 * EAbs(Y)) -end; - -{ Math functions. } - -function ArcCos(X: Extended): Extended; -begin - if X > 0.999999999999999 then - Result := 0 {иначе -NAN !} - else - if X < -0.999999999999999 then - Result := PI - else - Result := ArcTan2(Sqrt(1 - X*X), X); -end; - -function ArcSin(X: Extended): Extended; -begin - Result := ArcTan2(X, Sqrt(1 - X*X)) -end; - -function ArcTan2(Y, X: Extended): Extended; -asm - FLD Y - FLD X - FPATAN - FWAIT -end; - -function Tan(X: Extended): Extended; -{ Tan := Sin(X) / Cos(X) } -asm - FLD X - FPTAN - FSTP ST(0) { FPTAN pushes 1.0 after result } - FWAIT -end; - -function CoTan(X: Extended): Extended; -{ CoTan := Cos(X) / Sin(X) = 1 / Tan(X) } -asm - FLD X - FPTAN - FDIVRP - FWAIT -end; - -function Hypot(X, Y: Extended): Extended; -{ formula: Sqrt(X*X + Y*Y) - implemented as: |Y|*Sqrt(1+Sqr(X/Y)), |X| < |Y| for greater precision -var - Temp: Extended; -begin - X := Abs(X); - Y := Abs(Y); - if X > Y then - begin - Temp := X; - X := Y; - Y := Temp; - end; - if X = 0 then - Result := Y - else // Y > X, X <> 0, so Y > 0 - Result := Y * Sqrt(1 + Sqr(X/Y)); -end; -} -asm - FLD Y - FABS - FLD X - FABS - FCOM - FNSTSW AX - TEST AH,$45 - JNZ @@1 // if ST > ST(1) then swap - FXCH ST(1) // put larger number in ST(1) -@@1: FLDZ - FCOMP - FNSTSW AX - TEST AH,$40 // if ST = 0, return ST(1) - JZ @@2 - FSTP ST // eat ST(0) - JMP @@3 -@@2: FDIV ST,ST(1) // ST := ST / ST(1) - FMUL ST,ST // ST := ST * ST - FLD1 - FADD // ST := ST + 1 - FSQRT // ST := Sqrt(ST) - FMUL // ST(1) := ST * ST(1); Pop ST -@@3: FWAIT -end; - - -procedure SinCos(Theta: Extended; var Sin, Cos: Extended); -asm - FLD Theta - FSINCOS - FSTP tbyte ptr [edx] // Cos - FSTP tbyte ptr [eax] // Sin - FWAIT -end; - -{ Extract exponent and mantissa from X } -procedure Frexp(X: Extended; var Mantissa: Extended; var Exponent: Integer); -{ Mantissa ptr in EAX, Exponent ptr in EDX } -asm - FLD X - PUSH EAX - MOV dword ptr [edx], 0 { if X = 0, return 0 } - - FTST - FSTSW AX - FWAIT - SAHF - JZ @@Done - - FXTRACT // ST(1) = exponent, (pushed) ST = fraction - FXCH - -// The FXTRACT instruction normalizes the fraction 1 bit higher than -// wanted for the definition of frexp() so we need to tweak the result -// by scaling the fraction down and incrementing the exponent. - - FISTP dword ptr [edx] - FLD1 - FCHS - FXCH - FSCALE // scale fraction - INC dword ptr [edx] // exponent biased to match - FSTP ST(1) // discard -1, leave fraction as TOS - -@@Done: - POP EAX - FSTP tbyte ptr [eax] - FWAIT -end; - -function Ldexp(X: Extended; P: Integer): Extended; - { Result := X * (2^P) } -asm - PUSH EAX - FILD dword ptr [ESP] - FLD X - FSCALE - POP EAX - FSTP ST(1) - FWAIT -end; - -function Ceil(X: Extended): Integer; -begin - Result := Integer(Trunc(X)); - if Frac(X) > 0 then - Inc(Result); -end; - -function Floor(X: Extended): Integer; -begin - Result := Integer(Trunc(X)); - if Frac(X) < 0 then - Dec(Result); -end; - -{ Conversion of bases: Log.b(X) = Log.a(X) / Log.a(b) } - -function Log10(X: Extended): Extended; - { Log.10(X) := Log.2(X) * Log.10(2) } -asm - FLDLG2 { Log base ten of 2 } - FLD X - FYL2X - FWAIT -end; - -function Log2(X: Extended): Extended; -asm - FLD1 - FLD X - FYL2X - FWAIT -end; - -function LogN(Base, X: Extended): Extended; -{ Log.N(X) := Log.2(X) / Log.2(N) } -asm - FLD1 - FLD X - FYL2X - FLD1 - FLD Base - FYL2X - FDIV - FWAIT -end; - -function Poly(X: Extended; const Coefficients: array of Double): Extended; -{ Horner's method } -var - I: Integer; -begin - Result := Coefficients[High(Coefficients)]; - for I := High(Coefficients)-1 downto Low(Coefficients) do - Result := Result * X + Coefficients[I]; -end; - -function Power(Base, Exponent: Extended): Extended; -begin - if Exponent = 0.0 then - Result := 1.0 { n**0 = 1 } - else if (Base = 0.0) and (Exponent > 0.0) then - Result := 0.0 { 0**n = 0, n > 0 } - else if (Frac(Exponent) = 0.0) and (EAbs(Exponent) <= MaxInt) then - Result := IntPower(Base, Integer(Trunc(Exponent))) - else - Result := Exp(Exponent * Ln(Base)) -end; - -{$IFNDEF _D6orHigher} -(*function Trunc1( X: Extended ): Int64; -begin - Result := System.Trunc( X ); -end; -asm - FLD qword ptr [ESP+4] - { -> FST(0) Extended argument } - { <- EDX:EAX Result } - - - SUB ESP,12 - FNSTCW [ESP].Word // save - FNSTCW [ESP+2].Word // scratch - FWAIT - OR [ESP+2].Word, $0F00 // trunc toward zero, full precision - FLDCW [ESP+2].Word - FISTP qword ptr [ESP+4] - FWAIT - FLDCW [ESP].Word - POP ECX - POP EAX - POP EDX -end;*) - -function Trunc( X: Extended ): Int64; -begin - if Abs( X ) < 1 then Result := 0 else - if X < 0 then Result := -System.Trunc( -X ) - else Result := System.Trunc( X ); -end; -{$ENDIF} - - -{ Hyperbolic functions } - -function CoshSinh(X: Extended; Factor: Double): Extended; -begin - Result := Exp(X) / 2; - Result := Result + Factor / Result; -end; - -function Cosh(X: Extended): Extended; -begin - Result := CoshSinh(X, 0.25) -end; - -function Sinh(X: Extended): Extended; -begin - Result := CoshSinh(X, -0.25) -end; - -const - MaxTanhDomain = 5678.22249441322; // Ln(MaxExtended)/2 - -function Tanh(X: Extended): Extended; -begin - if X > MaxTanhDomain then - Result := 1.0 - else if X < -MaxTanhDomain then - Result := -1.0 - else - begin - Result := Exp(X); - Result := Result * Result; - Result := (Result - 1.0) / (Result + 1.0) - end; -end; - -function ArcCosh(X: Extended): Extended; -begin - if X <= 1.0 then - Result := 0.0 - else if X > 1.0e10 then - Result := Ln(2) + Ln(X) - else - Result := Ln(X + Sqrt((X - 1.0) * (X + 1.0))); -end; - -function ArcSinh(X: Extended): Extended; -var - Neg: Boolean; -begin - if X = 0 then - Result := 0 - else - begin - Neg := (X < 0); - X := EAbs(X); - if X > 1.0e10 then - Result := Ln(2) + Ln(X) - else - begin - Result := X*X; - Result := LnXP1(X + Result / (1 + Sqrt(1 + Result))); - end; - if Neg then Result := -Result; - end; -end; - -function ArcTanh(X: Extended): Extended; -var - Neg: Boolean; -begin - if X = 0 then - Result := 0 - else - begin - Neg := (X < 0); - X := EAbs(X); - if X >= 1 then - Result := MaxExtended - else - Result := 0.5 * LnXP1((2.0 * X) / (1.0 - X)); - if Neg then Result := -Result; - end; -end; - -{ Statistical functions } - -function Mean(const Data: array of Double): Extended; -begin - Result := SUM(Data) / (High(Data) - Low(Data) + 1) -end; - -function MinValue(const Data: array of Double): Double; -var - I: Integer; -begin - Result := Data[Low(Data)]; - for I := Low(Data) + 1 to High(Data) do - if Result > Data[I] then - Result := Data[I]; -end; - -function MinIntValue(const Data: array of Integer): Integer; -var - I: Integer; -begin - Result := Data[Low(Data)]; - for I := Low(Data) + 1 to High(Data) do - if Result > Data[I] then - Result := Data[I]; -end; - -{$IFDEF ASM_VERSION} -function Min(A,B: Integer): Integer; -asm - CMP EAX, EDX - JL @@1 - XCHG EAX, EDX -@@1: -end; -{$ELSE} -function Min(A,B: Integer): Integer; -begin - if A < B then - Result := A - else - Result := B; -end; -{$ENDIF} - -{$IFDEF _D4orHigher} -function Min(A,B: I64): I64; -begin - if Cmp64( A, B ) < 0 then - Result := A - else - Result := B; -end; - -function Min(A,B: Int64): Int64; -begin - if A < B then - Result := A - else - Result := B; -end; - -function Min(A,B: Single): Single; -begin - if A < B then - Result := A - else - Result := B; -end; - -function Min(A,B: Double): Double; -begin - if A < B then - Result := A - else - Result := B; -end; - -function Min(A,B: Extended): Extended; -begin - if A < B then - Result := A - else - Result := B; -end; -{$ENDIF} - -function MaxValue(const Data: array of Double): Double; -var - I: Integer; -begin - Result := Data[Low(Data)]; - for I := Low(Data) + 1 to High(Data) do - if Result < Data[I] then - Result := Data[I]; -end; - -function MaxIntValue(const Data: array of Integer): Integer; -var - I: Integer; -begin - Result := Data[Low(Data)]; - for I := Low(Data) + 1 to High(Data) do - if Result < Data[I] then - Result := Data[I]; -end; - -{$IFDEF ASM_VERSION} -function Max(A,B: Integer): Integer; -asm - CMP EAX, EDX - JG @@1 - XCHG EAX, EDX -@@1: -end; -{$ELSE} -function Max(A,B: Integer): Integer; -begin - if A > B then - Result := A - else - Result := B; -end; -{$ENDIF} - -{$IFDEF _D4orHigher} -function Max(A,B: I64): I64; -begin - if Cmp64( A, B ) > 0 then - Result := A - else - Result := B; -end; - -function Max(A,B: Single): Single; -begin - if A > B then - Result := A - else - Result := B; -end; - -function Max(A,B: Double): Double; -begin - if A > B then - Result := A - else - Result := B; -end; - -function Max(A,B: Extended): Extended; -begin - if A > B then - Result := A - else - Result := B; -end; -{$ENDIF} - -procedure MeanAndStdDev(const Data: array of Double; var Mean, StdDev: Extended); -var - S: Extended; - N,I: Integer; -begin - N := High(Data)- Low(Data) + 1; - if N = 1 then - begin - Mean := Data[0]; - StdDev := Data[0]; - Exit; - end; - Mean := Sum(Data) / N; - S := 0; // sum differences from the mean, for greater accuracy - for I := Low(Data) to High(Data) do - S := S + Sqr(Mean - Data[I]); - StdDev := Sqrt(S / (N - 1)); -end; - -procedure MomentSkewKurtosis(const Data: array of Double; - var M1, M2, M3, M4, Skew, Kurtosis: Extended); -var - Sum, SumSquares, SumCubes, SumQuads, OverN, Accum, M1Sqr, S2N, S3N: Extended; - I: Integer; -begin - OverN := 1 / (High(Data) - Low(Data) + 1); - Sum := 0; - SumSquares := 0; - SumCubes := 0; - SumQuads := 0; - for I := Low(Data) to High(Data) do - begin - Sum := Sum + Data[I]; - Accum := Sqr(Data[I]); - SumSquares := SumSquares + Accum; - Accum := Accum*Data[I]; - SumCubes := SumCubes + Accum; - SumQuads := SumQuads + Accum*Data[I]; - end; - M1 := Sum * OverN; - M1Sqr := Sqr(M1); - S2N := SumSquares * OverN; - S3N := SumCubes * OverN; - M2 := S2N - M1Sqr; - M3 := S3N - (M1 * 3 * S2N) + 2*M1Sqr*M1; - M4 := (SumQuads * OverN) - (M1 * 4 * S3N) + (M1Sqr*6*S2N - 3*Sqr(M1Sqr)); - Skew := M3 * Power(M2, -3/2); // = M3 / Power(M2, 3/2) - Kurtosis := M4 / Sqr(M2); -end; - -function Norm(const Data: array of Double): Extended; -begin - Result := Sqrt(SumOfSquares(Data)); -end; - -function PopnStdDev(const Data: array of Double): Extended; -begin - Result := Sqrt(PopnVariance(Data)) -end; - -function PopnVariance(const Data: array of Double): Extended; -begin - Result := TotalVariance(Data) / (High(Data) - Low(Data) + 1) -end; - -function RandG(Mean, StdDev: Extended): Extended; -{ Marsaglia-Bray algorithm } -var - U1, S2: Extended; -begin - repeat - U1 := 2*Random - 1; - S2 := Sqr(U1) + Sqr(2*Random-1); - until S2 < 1; - Result := Sqrt(-2*Ln(S2)/S2) * U1 * StdDev + Mean; -end; - -function StdDev(const Data: array of Double): Extended; -begin - Result := Sqrt(Variance(Data)) -end; - -procedure RaiseOverflowError; forward; - -function SumInt(const Data: array of Integer): Integer; -{var - I: Integer; -begin - Result := 0; - for I := Low(Data) to High(Data) do - Result := Result + Data[I] -end; } -asm // IN: EAX = ptr to Data, EDX = High(Data) = Count - 1 - // loop unrolled 4 times, 5 clocks per loop, 1.2 clocks per datum - PUSH EBX - MOV ECX, EAX // ecx = ptr to data - MOV EBX, EDX - XOR EAX, EAX - AND EDX, not 3 - AND EBX, 3 - SHL EDX, 2 - JMP @Vector.Pointer[EBX*4] -@Vector: - DD @@1 - DD @@2 - DD @@3 - DD @@4 -@@4: - ADD EAX, [ECX+12+EDX] - JO @@RaiseOverflowError -@@3: - ADD EAX, [ECX+8+EDX] - JO @@RaiseOverflowError -@@2: - ADD EAX, [ECX+4+EDX] - JO @@RaiseOverflowError -@@1: - ADD EAX, [ECX+EDX] - JO @@RaiseOverflowError - SUB EDX,16 - JNS @@4 - POP EBX - RET -@@RaiseOverflowError: - POP EBX - POP ECX - JMP RaiseOverflowError -end; - -procedure RaiseOverflowError; -begin - {$IFNDEF MATH_NOERR} - raise Exception.Create(e_IntOverflow, SIntOverflow); - {$ENDIF} -end; - -function SUM(const Data: array of Double): Extended; -{var - I: Integer; -begin - Result := 0.0; - for I := Low(Data) to High(Data) do - Result := Result + Data[I] -end; } -asm // IN: EAX = ptr to Data, EDX = High(Data) = Count - 1 - // Uses 4 accumulators to minimize read-after-write delays and loop overhead - // 5 clocks per loop, 4 items per loop = 1.2 clocks per item - FLDZ - MOV ECX, EDX - FLD ST(0) - AND EDX, not 3 - FLD ST(0) - AND ECX, 3 - FLD ST(0) - SHL EDX, 3 // count * sizeof(Double) = count * 8 - JMP @Vector.Pointer[ECX*4] -@Vector: - DD @@1 - DD @@2 - DD @@3 - DD @@4 -@@4: FADD qword ptr [EAX+EDX+24] // 1 - FXCH ST(3) // 0 -@@3: FADD qword ptr [EAX+EDX+16] // 1 - FXCH ST(2) // 0 -@@2: FADD qword ptr [EAX+EDX+8] // 1 - FXCH ST(1) // 0 -@@1: FADD qword ptr [EAX+EDX] // 1 - FXCH ST(2) // 0 - SUB EDX, 32 - JNS @@4 - FADDP ST(3),ST // ST(3) := ST + ST(3); Pop ST - FADD // ST(1) := ST + ST(1); Pop ST - FADD // ST(1) := ST + ST(1); Pop ST - FWAIT -end; - -function SumOfSquares(const Data: array of Double): Extended; -var - I: Integer; -begin - Result := 0.0; - for I := Low(Data) to High(Data) do - Result := Result + Sqr(Data[I]); -end; - -procedure SumsAndSquares(const Data: array of Double; var Sum, SumOfSquares: Extended); -{var - I: Integer; -begin - Sum := 0; - SumOfSquares := 0; - for I := Low(Data) to High(Data) do - begin - Sum := Sum + Data[I]; - SumOfSquares := SumOfSquares + Data[I]*Data[I]; - end; -end; } -asm // IN: EAX = ptr to Data - // EDX = High(Data) = Count - 1 - // ECX = ptr to Sum - // Est. 17 clocks per loop, 4 items per loop = 4.5 clocks per data item - FLDZ // init Sum accumulator - PUSH ECX - MOV ECX, EDX - FLD ST(0) // init Sqr1 accum. - AND EDX, not 3 - FLD ST(0) // init Sqr2 accum. - AND ECX, 3 - FLD ST(0) // init/simulate last data item left in ST - SHL EDX, 3 // count * sizeof(Double) = count * 8 - JMP @Vector.Pointer[ECX*4] -@Vector: - DD @@1 - DD @@2 - DD @@3 - DD @@4 -@@4: FADD // Sqr2 := Sqr2 + Sqr(Data4); Pop Data4 - FLD qword ptr [EAX+EDX+24] // Load Data1 - FADD ST(3),ST // Sum := Sum + Data1 - FMUL ST,ST // Data1 := Sqr(Data1) -@@3: FLD qword ptr [EAX+EDX+16] // Load Data2 - FADD ST(4),ST // Sum := Sum + Data2 - FMUL ST,ST // Data2 := Sqr(Data2) - FXCH // Move Sqr(Data1) into ST(0) - FADDP ST(3),ST // Sqr1 := Sqr1 + Sqr(Data1); Pop Data1 -@@2: FLD qword ptr [EAX+EDX+8] // Load Data3 - FADD ST(4),ST // Sum := Sum + Data3 - FMUL ST,ST // Data3 := Sqr(Data3) - FXCH // Move Sqr(Data2) into ST(0) - FADDP ST(3),ST // Sqr1 := Sqr1 + Sqr(Data2); Pop Data2 -@@1: FLD qword ptr [EAX+EDX] // Load Data4 - FADD ST(4),ST // Sum := Sum + Data4 - FMUL ST,ST // Sqr(Data4) - FXCH // Move Sqr(Data3) into ST(0) - FADDP ST(3),ST // Sqr1 := Sqr1 + Sqr(Data3); Pop Data3 - SUB EDX,32 - JNS @@4 - FADD // Sqr2 := Sqr2 + Sqr(Data4); Pop Data4 - POP ECX - FADD // Sqr1 := Sqr2 + Sqr1; Pop Sqr2 - FXCH // Move Sum1 into ST(0) - MOV EAX, SumOfSquares - FSTP tbyte ptr [ECX] // Sum := Sum1; Pop Sum1 - FSTP tbyte ptr [EAX] // SumOfSquares := Sum1; Pop Sum1 - FWAIT -end; - -function TotalVariance(const Data: array of Double): Extended; -var - Sum, SumSquares: Extended; -begin - SumsAndSquares(Data, Sum, SumSquares); - Result := SumSquares - Sqr(Sum)/(High(Data) - Low(Data) + 1); -end; - -function Variance(const Data: array of Double): Extended; -begin - Result := TotalVariance(Data) / (High(Data) - Low(Data)) -end; - - -{ Depreciation functions. } - -function DoubleDecliningBalance(Cost, Salvage: Extended; Life, Period: Integer): Extended; -{ dv := cost * (1 - 2/life)**(period - 1) - DDB = (2/life) * dv - if DDB > dv - salvage then DDB := dv - salvage - if DDB < 0 then DDB := 0 -} -var - DepreciatedVal, Factor: Extended; -begin - Result := 0; - if (Period < 1) or (Life < Period) or (Life < 1) or (Cost <= Salvage) then - Exit; - - {depreciate everything in period 1 if life is only one or two periods} - if ( Life <= 2 ) then - begin - if ( Period = 1 ) then - DoubleDecliningBalance:=Cost-Salvage - else - DoubleDecliningBalance:=0; {all depreciation occurred in first period} - exit; - end; - Factor := 2.0 / Life; - - DepreciatedVal := Cost * IntPower((1.0 - Factor), Period - 1); - {DepreciatedVal is Cost-(sum of previous depreciation results)} - - Result := Factor * DepreciatedVal; - {Nominal computed depreciation for this period. The rest of the - function applies limits to this nominal value. } - - {Only depreciate until total depreciation equals cost-salvage.} - if Result > DepreciatedVal - Salvage then - Result := DepreciatedVal - Salvage; - - {No more depreciation after salvage value is reached. This is mostly a nit. - If Result is negative at this point, it's very close to zero.} - if Result < 0.0 then - Result := 0.0; -end; - -function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended; -{ Spreads depreciation linearly over life. } -begin - {$IFNDEF MATH_NOERR} - if Life < 1 then ArgError('SLNDepreciation'); - {$ENDIF} - Result := (Cost - Salvage) / Life -end; - -function SYDDepreciation(Cost, Salvage: Extended; Life, Period: Integer): Extended; -{ SYD = (cost - salvage) * (life - period + 1) / (life*(life + 1)/2) } -{ Note: life*(life+1)/2 = 1+2+3+...+life "sum of years" - The depreciation factor varies from life/sum_of_years in first period = 1 - downto 1/sum_of_years in last period = life. - Total depreciation over life is cost-salvage.} -var - X1, X2: Extended; -begin - Result := 0; - if (Period < 1) or (Life < Period) or (Cost <= Salvage) then Exit; - X1 := 2 * (Life - Period + 1); - X2 := Life * (Life + 1); - Result := (Cost - Salvage) * X1 / X2 -end; - -{ Discounted cash flow functions. } - -function InternalRateOfReturn(Guess: Extended; const CashFlows: array of Double): Extended; -{ -Use Newton's method to solve NPV = 0, where NPV is a polynomial in -x = 1/(1+rate). Split the coefficients into negative and postive sets: - neg + pos = 0, so pos = -neg, so -neg/pos = 1 -Then solve: - log(-neg/pos) = 0 - - Let t = log(1/(1+r) = -LnXP1(r) - then r = exp(-t) - 1 -Iterate on t, then use the last equation to compute r. -} -var - T, Y: Extended; - Poly: TPoly; - K, Count: Integer; - - function ConditionP(const CashFlows: array of Double): Integer; - { Guarantees existence and uniqueness of root. The sign of payments - must change exactly once, the net payout must be always > 0 for - first portion, then each payment must be >= 0. - Returns: 0 if condition not satisfied, > 0 if condition satisfied - and this is the index of the first value considered a payback. } - var - X: Double; - I, K: Integer; - begin - K := High(CashFlows); - while (K >= 0) and (CashFlows[K] >= 0.0) do Dec(K); - Inc(K); - if K > 0 then - begin - X := 0.0; - I := 0; - while I < K do begin - X := X + CashFlows[I]; - if X >= 0.0 then - begin - K := 0; - Break - end; - Inc(I) - end - end; - ConditionP := K - end; - -begin - InternalRateOfReturn := 0; - K := ConditionP(CashFlows); - {$IFNDEF MATH_NOERR} - if K < 0 then ArgError('InternalRateOfReturn'); - {$ENDIF} - if K = 0 then - begin - {$IFNDEF MATH_NOERR} - if Guess <= -1.0 then ArgError('InternalRateOfReturn'); - {$ENDIF} - T := -LnXP1(Guess) - end else - T := 0.0; - for Count := 1 to MaxIterations do - begin - PolyX(CashFlows, Exp(T), Poly); - {$IFNDEF MATH_NOERR} - if Poly.Pos <= Poly.Neg then ArgError('InternalRateOfReturn'); - {$ENDIF} - if (Poly.Neg >= 0.0) or (Poly.Pos <= 0.0) then - begin - InternalRateOfReturn := -1.0; - Exit; - end; - with Poly do - Y := Ln(-Neg / Pos) / (DNeg / Neg - DPos / Pos); - T := T - Y; - if RelSmall(Y, T) then - begin - InternalRateOfReturn := Exp(-T) - 1.0; - Exit; - end - end; - {$IFNDEF MATH_NOERR} - ArgError('InternalRateOfReturn'); - {$ENDIF} -end; - -function NetPresentValue(Rate: Extended; const CashFlows: array of Double; - PaymentTime: TPaymentTime): Extended; -{ Caution: The sign of NPV is reversed from what would be expected for standard - cash flows!} -var - rr: Extended; - I: Integer; -begin - {$IFNDEF MATH_NOERR} - if Rate <= -1.0 then ArgError('NetPresentValue'); - {$ENDIF} - rr := 1/(1+Rate); - result := 0; - for I := High(CashFlows) downto Low(CashFlows) do - result := rr * result + CashFlows[I]; - if PaymentTime = ptEndOfPeriod then result := rr * result; -end; - -{ Annuity functions. } - -{--------------- -From the point of view of A, amounts received by A are positive and -amounts disbursed by A are negative (e.g. a borrower's loan repayments -are regarded by the borrower as negative). - -Given interest rate r, number of periods n: - compound(r, n) = (1 + r)**n "Compounding growth factor" - annuity(r, n) = (compound(r, n)-1) / r "Annuity growth factor" - -Given future value fv, periodic payment pmt, present value pv and type -of payment (start, 1 , or end of period, 0) pmtTime, financial variables satisfy: - - fv = -pmt*(1 + r*pmtTime)*annuity(r, n) - pv*compound(r, n) - -For fv, pv, pmt: - - C := compound(r, n) - A := (1 + r*pmtTime)*annuity(r, n) - Compute both at once in Annuity2. - - if C > 1E16 then A = C/r, so: - fv := meaningless - pv := -pmt*(pmtTime+1/r) - pmt := -pv*r/(1 + r*pmtTime) - else - fv := -pmt(1+r*pmtTime)*A - pv*C - pv := (-pmt(1+r*pmtTime)*A - fv)/C - pmt := (-pv*C-fv)/((1+r*pmtTime)*A) ----------------} - -function PaymentParts(Period, NPeriods: Integer; Rate, PresentValue, - FutureValue: Extended; PaymentTime: TPaymentTime; var IntPmt: Extended): - Extended; -var - Crn:extended; { =Compound(Rate,NPeriods) } - Crp:extended; { =Compound(Rate,Period-1) } - Arn:extended; { =AnnuityF(Rate,NPeriods) } - -begin - {$IFNDEF MATH_NOERR} - if Rate <= -1.0 then ArgError('PaymentParts'); - {$ENDIF} - Crp:=Compound(Rate,Period-1); - Arn:=Annuity2(Rate,NPeriods,PaymentTime,Crn); - IntPmt:=(FutureValue*(Crp-1)-PresentValue*(Crn-Crp))/Arn; - PaymentParts:=(-FutureValue-PresentValue)*Crp/Arn; -end; - -function FutureValue(Rate: Extended; NPeriods: Integer; Payment, PresentValue: - Extended; PaymentTime: TPaymentTime): Extended; -var - Annuity, CompoundRN: Extended; -begin - {$IFNDEF MATH_NOERR} - if Rate <= -1.0 then ArgError('FutureValue'); - {$ENDIF} - Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN); - {$IFNDEF MATH_NOERR} - if CompoundRN > 1.0E16 then ArgError('FutureValue'); - {$ENDIF} - FutureValue := -Payment * Annuity - PresentValue * CompoundRN -end; - -function InterestPayment(Rate: Extended; Period, NPeriods: Integer; PresentValue, - FutureValue: Extended; PaymentTime: TPaymentTime): Extended; -var - Crp:extended; { compound(rate,period-1)} - Crn:extended; { compound(rate,nperiods)} - Arn:extended; { annuityf(rate,nperiods)} -begin - {$IFNDEF MATH_NOERR} - if (Rate <= -1.0) - or (Period < 1) or (Period > NPeriods) then ArgError('InterestPayment'); - {$ENDIF} - Crp:=Compound(Rate,Period-1); - Arn:=Annuity2(Rate,Nperiods,PaymentTime,Crn); - InterestPayment:=(FutureValue*(Crp-1)-PresentValue*(Crn-Crp))/Arn; -end; - -function InterestRate(NPeriods: Integer; - Payment, PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; -{ -Given: - First and last payments are non-zero and of opposite signs. - Number of periods N >= 2. -Convert data into cash flow of first, N-1 payments, last with -first < 0, payment > 0, last > 0. -Compute the IRR of this cash flow: - 0 = first + pmt*x + pmt*x**2 + ... + pmt*x**(N-1) + last*x**N -where x = 1/(1 + rate). -Substitute x = exp(t) and apply Newton's method to - f(t) = log(pmt*x + ... + last*x**N) / -first -which has a unique root given the above hypotheses. -} -var - X, Y, Z, First, Pmt, Last, T, ET, EnT, ET1: Extended; - Count: Integer; - Reverse: Boolean; - - function LostPrecision(X: Extended): Boolean; - asm - XOR EAX, EAX - MOV BX,WORD PTR X+8 - INC EAX - AND EBX, $7FF0 - JZ @@1 - CMP EBX, $7FF0 - JE @@1 - XOR EAX,EAX - @@1: - end; - -begin - Result := 0; - {$IFNDEF MATH_NOERR} - if NPeriods <= 0 then ArgError('InterestRate'); - {$ENDIF} - Pmt := Payment; - if PaymentTime = ptEndOfPeriod then - begin - X := PresentValue; - Y := FutureValue + Payment - end - else - begin - X := PresentValue + Payment; - Y := FutureValue - end; - First := X; - Last := Y; - Reverse := False; - if First * Payment > 0.0 then - begin - Reverse := True; - T := First; - First := Last; - Last := T - end; - if first > 0.0 then - begin - First := -First; - Pmt := -Pmt; - Last := -Last - end; - {$IFNDEF MATH_NOERR} - if (First = 0.0) or (Last < 0.0) then ArgError('InterestRate'); - {$ENDIF} - T := 0.0; { Guess at solution } - for Count := 1 to MaxIterations do - begin - EnT := Exp(NPeriods * T); - if {LostPrecision(EnT)} ent=(ent+1) then - begin - Result := -Pmt / First; - if Reverse then - Result := Exp(-LnXP1(Result)) - 1.0; - Exit; - end; - ET := Exp(T); - ET1 := ET - 1.0; - if ET1 = 0.0 then - begin - X := NPeriods; - Y := X * (X - 1.0) / 2.0 - end - else - begin - X := ET * (Exp((NPeriods - 1) * T)-1.0) / ET1; - Y := (NPeriods * EnT - ET - X * ET) / ET1 - end; - Z := Pmt * X + Last * EnT; - Y := Ln(Z / -First) / ((Pmt * Y + Last * NPeriods *EnT) / Z); - T := T - Y; - if RelSmall(Y, T) then - begin - if not Reverse then T := -T; - InterestRate := Exp(T)-1.0; - Exit; - end - end; - {$IFNDEF MATH_NOERR} - ArgError('InterestRate'); - {$ENDIF} -end; - -function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended; - PaymentTime: TPaymentTime): Extended; - -{ If Rate = 0 then nper := -(pv + fv) / pmt - else cf := pv + pmt * (1 + rate*pmtTime) / rate - nper := LnXP1(-(pv + fv) / cf) / LnXP1(rate) } - -var - PVRPP: Extended; { =PV*Rate+Payment } {"initial cash flow"} - T: Extended; - -begin - {$IFNDEF MATH_NOERR} - if Rate <= -1.0 then ArgError('NumberOfPeriods'); - {$ENDIF} - -{whenever both Payment and PaymentTime are given together, the PaymentTime has the effect - of modifying the effective Payment by the interest accrued on the Payment} - - if ( PaymentTime=ptStartOfPeriod ) then - Payment:=Payment*(1+Rate); - -{if the payment exactly matches the interest accrued periodically on the - presentvalue, then an infinite number of payments are going to be - required to effect a change from presentvalue to futurevalue. The - following catches that specific error where payment is exactly equal, - but opposite in sign to the interest on the present value. If PVRPP - ("initial cash flow") is simply close to zero, the computation will - be numerically unstable, but not as likely to cause an error.} - - PVRPP:=PresentValue*Rate+Payment; - {$IFNDEF MATH_NOERR} - if PVRPP=0 then ArgError('NumberOfPeriods'); - {$ENDIF} - - { 6.1E-5 approx= 2**-14 } - if ( EAbs(Rate)<6.1E-5 ) then - Result:=-(PresentValue+FutureValue)/PVRPP - else - begin - -{starting with the initial cash flow, each compounding period cash flow - should result in the current value approaching the final value. The - following test combines a number of simultaneous conditions to ensure - reasonableness of the cashflow before computing the NPER.} - - T:= -(PresentValue+FutureValue)*Rate/PVRPP; - {$IFNDEF MATH_NOERR} - if T<=-1.0 then ArgError('NumberOfPeriods'); - {$ENDIF} - Result := LnXP1(T) / LnXP1(Rate) - end; - NumberOfPeriods:=Result; -end; - -function Payment(Rate: Extended; NPeriods: Integer; PresentValue, FutureValue: - Extended; PaymentTime: TPaymentTime): Extended; -var - Annuity, CompoundRN: Extended; -begin - {$IFNDEF MATH_NOERR} - if Rate <= -1.0 then ArgError('Payment'); - {$ENDIF} - Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN); - if CompoundRN > 1.0E16 then - Payment := -PresentValue * Rate / (1 + Integer(PaymentTime) * Rate) - else - Payment := (-PresentValue * CompoundRN - FutureValue) / Annuity -end; - -function PeriodPayment(Rate: Extended; Period, NPeriods: Integer; - PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended; -var - Junk: Extended; -begin - {$IFNDEF MATH_NOERR} - if (Rate <= -1.0) or (Period < 1) or (Period > NPeriods) then ArgError('PeriodPayment'); - {$ENDIF} - PeriodPayment := PaymentParts(Period, NPeriods, Rate, PresentValue, - FutureValue, PaymentTime, Junk); -end; - -function PresentValue(Rate: Extended; NPeriods: Integer; Payment, FutureValue: - Extended; PaymentTime: TPaymentTime): Extended; -var - Annuity, CompoundRN: Extended; -begin - {$IFNDEF MATH_NOERR} - if Rate <= -1.0 then ArgError('PresentValue'); - {$ENDIF} - Annuity := Annuity2(Rate, NPeriods, PaymentTime, CompoundRN); - if CompoundRN > 1.0E16 then - PresentValue := -(Payment / Rate * Integer(PaymentTime) * Payment) - else - PresentValue := (-Payment * Annuity - FutureValue) / CompoundRN -end; - -{------------------------------------------------------------------------------} - -function IsPowerOf2( i: Integer ): Boolean; { Result = (i <> 0) and (i and (i-1) = 0); } -asm - OR EAX,EAX - JZ @@exit // 0 не является степенью числа 2 - LEA EDX, [EAX-1] - OR EAX,EDX - SETZ AL // число является степенью 2, если (i & (i-1)) = 0, т.е. если после - // обнуления младшей 1 в числе больше не осталось битов 1. -@@exit: -end; - -function Low1( i: Integer ): Integer; { Result := i and (-i); } -asm - MOV EDX, EAX - NEG EAX - AND EAX, EDX -end; - -function Low0( i: Integer ): Integer; { Result := -i and (i+1); } -asm - LEA EDX, [EAX+1] - NEG EAX - AND EAX, EDX -end; - -function count_1_bits_in_byte( x: Byte ): Byte; - asm - MOV CL, AL -@@loop: - SHR CL, 1 - JZ @@exit - SUB AL, CL - JMP @@loop -@@exit: - end; - -function count_1_bits_in_dword( x: Integer ): Integer; - asm - MOV ECX, EAX - JMP @@go -@@loop: - SUB EAX, ECX -@@go: - SHR ECX, 1 - JNZ @@loop - end; - -end. diff --git a/plugins/ImportTXT/kol/read1st.txt b/plugins/ImportTXT/kol/read1st.txt deleted file mode 100644 index 3657c8d07d..0000000000 --- a/plugins/ImportTXT/kol/read1st.txt +++ /dev/null @@ -1,63 +0,0 @@ -KEY OBJECTS LIBRARY for Delphi (and Free Pascal Compiler) - to make applications small and power. This library is freeware and open source. Delphi 2, 3, 4, 5, 6, 7, 8, BDS 2005, 2006, 2010, TurboDelphi, Delphi XE, Delphi XE2 and Free Pascal Compiler 1.0.5, 1.0.6, and higher (2.0.4) are supported. Partially compatible with Kylix (Linux/Qt platform, use special converting tool and provided files in Tools section on the site http://bonanzas.rinet.ru) - -Copyright (C) by Vladimir Kladov, 1999-2010. -Some parts of code are Copyright (C) intellectual property by other people, see comments in code and on KOL site. Thanks to all for help with KOL and MCK! - -v. 3.18 (23-Apr-2012) - -To get newer version, go to Web-page http://www.kolmck.net and get there updates. - -__________________ -BRIEF DESCRIPTION: -    KOL - Key Objects Library is a set of objects to develop applications using Delphi. It is distributed free of charge, with source code. -   KOL allows to create very compact GUI applications (starting from ~14,0K without compression - if suggested system units replacement used). The majority of the code is converted to assembly. -   A Help generating tool, xHelpGen is provided for KOL, which creates detailed documentation in html format. Documentation is generated on from the source code comments, so developers instantly  have access to the most fresh and complete documentation. -   With advent of the MCK (Mirror Classes Kit) package, all advantages of visual programming are available for developers who use KOL. Additionally with MCK it is possible to make large enough projects smaller converting part of machine code to a byte code of Forth-like virtual (emulated at run time) machint (see more detailed: Collapse). - A lot of additions are available for KOL, which allow to work with data bases, Active-X components, print reports, different image and compression formats, etc. --------------------------------------------- - -This archive contains Key Objects Library main part: KOL.PAS and several test samples. At the KOL Web page (http://bonanzas.rinet.ru), you can download also additional components: - -MCK - Mirror Classes Kit - visual programming environment for KOL -xHelpGen - utility to generate html-documentation from comments within the source code; -KolErr (~25K) - "light" (for 6K), but functional exception handling unit -KOLEdb, KOLODBC, StrDb (by Mike Talcott), TdkDbKol (by Thaddy de Koning) - DB-extensions for KOL -KolGif (~20K) - GIF (animated, transparent) support for KOL -KolJpegObj (~127K + 340K) - JPEG support for KOL -KolOGL12 (~59K) - OpenGL support for KOL -KOLword (~12K) - MS Word automation -Service (~20K) - writing NT services with KOL -KOLSocket (~30K) - sockets for KOL (by Alexander Shakhaylo) -TestKOLRas (~20K) - RAS dial-up for KOL (by Alexander Shakhaylo) -sysdcu (~200K) - system.dcu, sysinit.dcu replacement for Delphi5 (it provides a savings of 9KBytes from the .exe's file size) -sysdcuD6 (~200K) - system.dcu, ... replacement for Delphi6 -HeapMM (~1K) - alteranative memory manager -MapMem -Widgets -ZLib -... and many others, this list is constantly extended with new items. - - -_____________ -INSTALLATION: - -1. When You install KOL the first time, create a new directory for KOL (e.g., E:\KOL). - -2. Unpack all files from KOL.ZIP there. (If upgrading, confirm overwriting of old files with new ones). - -3. If You downloaded xhelpgen.zip package, also unpack it into the same directory. Read also docs for xHelpGen from the package. - -4. If You downloaded SYSDCU.ZIP, create subdirectory for it (e.g. E:\KOL\SYS) and unpack it there. Read also docs for system units replacement in the package. - -5. To learn how to install the MCK (Mirror Classes Kit) see instructions in the MCK archive. - -6. To learn how to install KOLEdb, see instructions in KOLEDB.ZIP archive. - -7. For more information on the use and or installation of any of the packages packages and programs found on KOL site: look for help within it's package. - -Note: KOL itself does not require creating a package since it has no design-time components to install it onto Component Palette. See MCK, which has such components and allows visual programming using KOL. --------------------------------------------------- - -Web address: http://kolmck.net -vk@kolmck.net -Vladimir Kladov \ No newline at end of file diff --git a/plugins/ImportTXT/kol/read1st_rus.txt b/plugins/ImportTXT/kol/read1st_rus.txt deleted file mode 100644 index 60219b29fc..0000000000 --- a/plugins/ImportTXT/kol/read1st_rus.txt +++ /dev/null @@ -1,61 +0,0 @@ -KEY OBJECTS LIBRARY для Delphi (и Free Pascal Compiler) - предназначен для того, чтобы сделать программы, изготовленные с использованием языка Паскаль, маленькими и очень маленькими. -Copyright (C) by Vladimir Kladov, 1999-2007. Бесплатно, с исходными текстами. - -версия 3.18 (23 апреля 2012 г.) - -_________________ -КРАТКОЕ ОПИСАНИЕ: -   KOL - Key Objects Library - это библиотека объектов для программирования в среде Delphi. -   Поддерживаются версии Delphi2, Delph3, Delphi4, Delphi5, Delphi6, Delphi7, Delphi8, BDS2005, BDS2006, BDS2010, Turbo-Delphi, Delphi XE, Delphi XE2, а так же Free Pascal v1.0.5, v2.0.4 и выше. Имеется так же частичная совместимость с Kylix (требуется конвертер и набор файлов, см. в разделе "Инструменты разработчика" на сайте http://bonanzas.rinet.ru). Ведется работа над портированием на другие платформы (Linux, Win CE). - Библиотека KOL позволяет разрабатывать чрезвычайно компактные GUI-приложения (от 11К без сжатия - при условии использования предлагаемой замены системных модулей system, sysinit, см. на сайте раздел "Архивы"). Большая часть кода переведана на ассемблер. -   К библиотеке прилагается программа - генератор справки (xHelpGen), формирующая подробную документацию по библиотеке в html-формате. Справка формируется на основе комментариев в исходных текстах, так что разработчики всегда имеют доступ к самой свежей и полной документации. -   С использованием MCK (Mirror Classes Kit - набор зеркальных классов) все прелести визуальной разработки программ в полной мере доступны и для разработчиков, использующих KOL. Дополнительно с MCK имеется возможность еще более уменьшать приложения, автоматически генерируя П-код виртуальной машины вместо Паскаль-кода для инициализации форм (см. подроблее: Collapse). ----------------------------------- - -Данный архив содержит самодостаточную часть библиотеки Key Objects Library: файл KOL.PAS. На странице (http://www.kolmck.net) возможно также загрузить дополнительные расширения, в том числе: - -MCK - Mirror Classes Kit - полноценная визуальная среда для KOL -xHelpGen (~50K) - генератор html-справки на основе комментариев в исходном коде -KolErr (~20K) - "облегченная" (на 6К), но вполне фунциональная обработка исключений -KOLEdb, KOLODBC, StrDb, TdkDbKol - расширения для работы с БД -KOLWord (~12K) - MS Word automation -KolGif (~20K) - поддержка анимированных gif-файлов -KolJpegObj (~127K) - поддержка JPEG -KolOgl12 (~59K) - поддержка OpenGL -Service (~30K) - написание NT сервисов в KOL -KOLSocket (~30K) - сокеты -sysdcu (~200K) - замена system.dcu, sysinit.dcu для Delphi5 (экономия еще 9К в .exe) -HeapMM (~1K) - альтернативный менеджер памяти - -... -И так далее, список пополняется постоянно. - -__________________________________________________ -УСТАНОВКА И ПЕРЕУСТАНОВКА (УСТАНОВКА НОВОЙ ВЕРСИИ): - -1. При первой установке создать новую директорию (например, E:\KOL). - -2. Распаковать файлы из KOL.ZIP туда же. (При переустановке подтвердить замещение старых файлов новыми). - -4. Если Вы загрузили архив xhelpgen.zip, так же распаковывайте его в ту же директорию. Не забудьте прочитать прилагаемую к нему инструкцию. - -5. Если Вы загрузили архив SYSDCU.ZIP, создайте поддиректорию для него (например, E:\KOL\SYS) и распакуйте туда его содержимое. К нему так же прилагается своя инструкция. - -6. Инструкции по установке MCK (Mirror Classes Kit) см. в архиве MCK.ZIP. - -7. Аналогично для koledb, kolword и других дополнений. - -Примечание: для самого KOL не требуется создавать Package, т.к. KOL не имеет компонент времени разработки, требующих установки на палтру компонентов. См. пакет MCK, которое имеет такие компоненты, и позволяет разрабатывать приложения с использованием KOL, визуально. -------------------------------------------------------------- - -ЛИЦЕНЗИРОВАНИЕ. - -Данный параграф введен здесь, чтобы не переводить на русский язык лицензию, см. файл LICENSE.txt. - -На использование библиотеки в качестве инструмента для разработки исполнимых модулей (exe, dll и т.д.) не накладывается никаких ограничений. Нельзя продавать библиотеку полностью или частично. Нельзя распространять ее бесплатно, полностью или частично, без согласия автора и без ссылок на автора. В случае, если распространяется модифицированная библиотека, пользователи обязаны быть информированы о первоисточнике и о том, кто является автором оригинальной библиотеки, и как с ним связаться. - -------------------------------------------------------------- - -http://kolmck.net -vk@kolmck.net -Владимир Кладов \ No newline at end of file diff --git a/plugins/ImportTXT/kol/visual_xp_styles.inc b/plugins/ImportTXT/kol/visual_xp_styles.inc deleted file mode 100644 index 5db52144c1..0000000000 --- a/plugins/ImportTXT/kol/visual_xp_styles.inc +++ /dev/null @@ -1,1448 +0,0 @@ -// Name: KOL Addon - Visual XP Styles -// Rev.: 1.99 + KOL 3.00.A -// Date: 02 oct 2010 -// Author: MTsv DN -// Thanks: mdw, Vladimir Kladov - -{$IFDEF _FPC} -const - clGrey = TColor($808080); - clLtGrey = TColor($C0C0C0); - clDkGrey = TColor($808080); -{$ENDIF} - -procedure ConvertBitmap2Grayscale(var Bmp: PBitmap); -type - TRGBArray = array[0..32767] of TRGBTriple; - PRGBArray = ^TRGBArray; -var - x, y, Gray: Integer; - Row: PRGBArray; - R, G, B : Byte; - TrColor : Integer; -begin - Bmp.PixelFormat := pf24bit; - TrColor := Bmp.Pixels[Bmp.Width - 1, 0]; - for y := 0 to Bmp.Height - 1 do - begin - Row := Bmp.ScanLine[y]; - for x := 0 to Bmp.Width - 1 do - begin - R := LoByte(LoWord(TrColor)); - G := HiByte(LoWord(TrColor)); - B := LoByte(HiWord(TrColor)); - if (Row[x].rgbtRed = R) and - (Row[x].rgbtGreen = G) and - (Row[x].rgbtBlue = B) then continue; - Gray := (Row[x].rgbtRed + Row[x].rgbtGreen + Row[x].rgbtBlue) div 3; - Row[x].rgbtRed := Gray; - Row[x].rgbtGreen := Gray; - Row[x].rgbtBlue := Gray; - end; - end; -end; -//********************* Creating font on Sender font base ********************// -function CreateNewFont(Sender : PControl): HFont; -const - CLEARTYPE_QUALITY = 5; -var - fnWeight : Integer; - fnItalic, fnUnderline, fnStrikeOut, - fnQuality, fnPitch : DWORD; -begin - // Font style - if Sender.Font.FontStyle = [fsBold] then fnWeight := 700 else fnWeight := 0; - if Sender.Font.FontStyle = [fsItalic] then fnItalic := DWORD(TRUE) else fnItalic := DWORD(FALSE); - if Sender.Font.FontStyle = [fsUnderline] then fnUnderline := DWORD(TRUE) else fnUnderline := DWORD(FALSE); - if Sender.Font.FontStyle = [fsStrikeOut] then fnStrikeOut := DWORD(TRUE) else fnStrikeOut := DWORD(FALSE); - - // Font quality - case Sender.Font.FontQuality of - fqAntialiased: fnQuality := DWORD(ANTIALIASED_QUALITY); - {$IFDEF AUTO_REPLACE_CLEARTYPE} - fqClearType: fnQuality := DWORD(CLEARTYPE_QUALITY); - {$ELSE} - fqClearType: fnQuality := DWORD(ANTIALIASED_QUALITY); - {$ENDIF} - fqDraft: fnQuality := DWORD(DRAFT_QUALITY); - fqNonAntialiased: fnQuality := DWORD(NONANTIALIASED_QUALITY); - fqProof: fnQuality := DWORD(PROOF_QUALITY); - {fqDefault:} else fnQuality := DWORD(DEFAULT_QUALITY); - end; - - // Font pitch - case Sender.Font.FontPitch of - fpFixed: fnPitch := DWORD(FIXED_PITCH); - fpVariable: fnPitch := DWORD(VARIABLE_PITCH); - {fpDefault:} else fnPitch := DWORD(DEFAULT_PITCH); - end; - - Result := CreateFont(Sender.Font.FontHeight, - Sender.Font.FontWidth, - 0, - Sender.Font.FontOrientation, - fnWeight, - fnItalic, - fnUnderline, - fnStrikeOut, - Sender.Font.FontCharset, - OUT_DEFAULT_PRECIS, - CLIP_DEFAULT_PRECIS, - fnQuality, - fnPitch, - PKOLChar(Sender.Font.FontName)); -end; -//***************************** Initializing themes **************************// -function InitThemes : boolean; -begin - Result := false; - ThemeLibrary := LoadLibrary(themelib); - if ThemeLibrary > 0 then - begin - OpenThemeData := GetProcAddress(ThemeLibrary, 'OpenThemeData'); - DrawThemeBackground := GetProcAddress(ThemeLibrary, 'DrawThemeBackground'); - IsThemeBackgroundPartiallyTransparent := GetProcAddress(ThemeLibrary, 'IsThemeBackgroundPartiallyTransparent'); - DrawThemeParentBackground := GetProcAddress(ThemeLibrary, 'DrawThemeParentBackground'); - DrawThemeText := GetProcAddress(ThemeLibrary, 'DrawThemeText'); - CloseThemeData := GetProcAddress(ThemeLibrary, 'CloseThemeData'); - IsThemeActive := GetProcAddress(ThemeLibrary, 'IsThemeActive'); - IsAppThemed := GetProcAddress(ThemeLibrary, 'IsAppThemed'); - GetThemeColor := GetProcAddress(ThemeLibrary, 'GetThemeColor'); - Result := true; - end; -end; -//***************************** Deinitializing themes ************************// -procedure DeinitThemes; -begin - if ThemeLibrary > 0 then - begin - FreeLibrary(ThemeLibrary); - ThemeLibrary := 0; - OpenThemeData := nil; - DrawThemeBackground := nil; - IsThemeBackgroundPartiallyTransparent := nil; - DrawThemeParentBackground := nil; - CloseThemeData := nil; - IsAppThemed := nil; - IsThemeActive := nil; - GetThemeColor := nil; - end; -end; -//****************************** Checking themes *****************************// -procedure CheckThemes; -// Check Manifest file or resource - function IsManifestFilePresent : boolean; - begin - Result := false; - if FileExists(ParamStr(0) + '.manifest') then //dufa. в случае с DLL ExePath вернет путь до нее, а не до EXE - begin - Result := true; - exit; - end; - if FindResource(hInstance, MAKEINTRESOURCE(1), MakeIntResource(24)) <> 0 then - Result := true; - end; -// Check activity themes - function UseThemes: Boolean; - begin - if (ThemeLibrary > 0) then Result := IsThemeActive - else Result := False; - end; -begin - AppTheming := false; - if IsManifestFilePresent then - if InitThemes then - begin - if UseThemes then - AppTheming := true; - DeinitThemes; - end; -end; -//****************************** Drawing Splitter ****************************// -procedure WndSplitterXPDraw( Dummy : Pointer; Sender: PControl; DC: HDC ); -const - Bit : Word = $FF; -var - B, Brush : HBRUSH; - fDC : HDC; - Bmp : HBITMAP; -begin - // Checking user owner-draw - if Assigned(Sender.EV.fOnPaint) and (@Sender.EV.fOnPaint <> @WndSplitterXPDraw) then - begin - Sender.EV.fOnPaint(Sender, DC); - exit; - end; - - // Draw back layer - Brush := CreateSolidBrush(Color2RGB(Sender.fParent.Color)); - fDC := SelectObject(DC, Brush); - FillRect(DC, Sender.ClientRect, Brush); - SelectObject(DC, fDC); - DeleteObject(Brush); - - // Creating brush and pen - if {$IFDEF USE_FLAGS} G4_Pressed in Sender.fFlagsG4 - {$ELSE} Sender.fPressed {$ENDIF} then - begin - Bmp := CreateBitmap(2, 2, 1, 1, @Bit); - B := CreatePatternBrush(Bmp); - fDC := SelectObject(DC, B); - // Drawing splitter - PatBlt (DC, 0, 0, Sender.Width, Sender.Height, PATINVERT); - // Destroying brush and pen - SelectObject(DC, fDC); - DeleteObject(B); - DeleteObject(Bmp); - end; -end; -//*************************** Drawing TabControl Page ************************// -procedure WndTabXPDraw( Dummy : Pointer; Sender: PControl; DC: HDC ); -var - hThemes : THandle; - Color : COLORREF; - Brush : HBRUSH; - fDC : HDC; -begin - // Checking user owner-draw - if Assigned(Sender.EV.fOnPaint) and (@Sender.EV.fOnPaint <> @WndTabXPDraw) then - begin - Sender.EV.fOnPaint(Sender, DC); - exit; - end; - hThemes := OpenThemeData(Sender.fHandle, 'TAB'); - if hThemes <> 0 then - begin - GetThemeColor(hThemes, 10, 0, 3805, Color); - Sender.Color := Color2RGB(Color); - Brush := CreateSolidBrush(Color2RGB(Color)); - fDC := SelectObject(DC, Brush); - FillRect(DC, Sender.ClientRect, Brush); - SelectObject(DC, fDC); - DeleteObject(Brush); - CloseThemeData(hThemes); - end; -end; -//*************************** Drawing Panel control **************************// -procedure WndPanelXPResize( Dummy : Pointer; Sender: PObj ); -var - R : TRect; -begin - R := PControl(Sender).ClientRect; - InvalidateRect(PControl(Sender).fHandle, @R, False); -end; - -procedure WndPanelXPDraw( Dummy : Pointer; Sender: PControl; DC: HDC ); -var - RClient, RText : TRect; - LPos : DWORD; - S : KOLString; - F : HFONT; - fDC1, fDC2 : HDC; - hThemes : THandle; - TxtColor, Color : COLORREF; - Brush : HBRUSH; - Pen : HPEN; -begin - // Checking user owner-draw - if Assigned(Sender.EV.fOnPaint) and (@Sender.EV.fOnPaint <> @WndPanelXPDraw) then - begin - Sender.EV.fOnPaint(Sender, DC); - exit; - end; - - // Getting rects - RClient := Sender.ClientRect; - // Getting text and text flags - S := Sender.fCaption; - LPos := 0; - if S <> '' then - begin - case Sender.fVerticalAlign of - vaTop: LPos := DT_TOP; - vaCenter: LPos := DT_VCENTER; - vaBottom: LPos := DT_BOTTOM; - end; - case Sender.fTextAlign of - taLeft: LPos := LPos or DT_LEFT; - taCenter: LPos := LPos or DT_CENTER; - taRight: LPos := LPos or DT_RIGHT; - end; - end; - - // Draw back layer - if (Sender.EdgeStyle = esTransparent) or - ({$IFDEF USE_FLAGS} (G2_Transparent in Sender.fFlagsG2) - {$ELSE} Sender.fTransparent {$ENDIF}) then else - begin - Brush := CreateSolidBrush(Color2RGB(Sender.fParent.Color)); - fDC1 := SelectObject(DC, Brush); - FillRect(DC, RClient, Brush); - - case Sender.EdgeStyle of - esRaised, esLowered: - begin - Sender.fStyle.Value := Sender.fStyle.Value and (not SS_SUNKEN) and (not WS_DLGFRAME); - Sender.fExStyle := Sender.fExStyle and (not WS_EX_STATICEDGE) or WS_EX_WINDOWEDGE; - - Pen := CreatePen(PS_SOLID, 1, Color2RGB(clLtGrey)); - fDC2 := SelectObject(DC, Pen); - RoundRect(DC, RClient.Left, RClient.Top, - RClient.Right, RClient.Bottom, 5, 5); - SelectObject(DC, fDC2); - DeleteObject(Pen); - end; - end; - - SelectObject(DC, fDC1); - DeleteObject(Brush); - end; - - if S <> '' then - begin - hThemes := OpenThemeData(Sender.fHandle, 'button'); - Color := Sender.Font.Color; - if hThemes <> 0 then - begin - {$IFDEF USE_FLAGS} - if (F3_Disabled in Sender.fStyle.f3_Style) then - {$ELSE} - if not Sender.fEnabled then - {$ENDIF} - GetThemeColor(hThemes, 1, 4, 3803, Color); - CloseThemeData(hThemes); - end; - RText := MakeRect(2, 2, Sender.Width-2, Sender.Height-2); - - // Create font - F := CreateNewFont(Sender); - fDC1 := SelectObject(DC, F); - // Draw text - SetBkMode(DC, TRANSPARENT); - TxtColor := SetTextColor(DC, Color2RGB(Color)); - DrawText(DC, PKOLChar(S), Length(S), RText, LPos or DT_SINGLELINE); - // Backup color - SetTextColor(DC, Color2RGB(TxtColor)); - SetBkMode(DC, OPAQUE); - // Destroying font - SelectObject(DC, fDC1); - DeleteObject(F); - end; -end; -//************************** Drawing GroupBox control ************************// -procedure WndGroupBoxXPDraw( Dummy : Pointer; Sender: PControl; DC: HDC ); -var - hThemes : THandle; - RClient, RText, RClipMain, RClipLeft, RClipRight : TRect; - LPos, fState : DWORD; - S : KOLWideString; - F : HFONT; - fDC : HDC; - TxtColor, Color : COLORREF; - TextWidth, TextHeight : Integer; -begin - // Checking user owner-draw - if Assigned(Sender.EV.fOnPaint) and (@Sender.EV.fOnPaint <> @WndGroupBoxXPDraw) then - begin - Sender.EV.fOnPaint(Sender, DC); - exit; - end; - - // Getting text and text flags - LPos := 0; - case Sender.fVerticalAlign of - vaTop: LPos := DT_TOP; - vaCenter: LPos := DT_VCENTER; - vaBottom: LPos := DT_BOTTOM; - end; - case Sender.fTextAlign of - taLeft: LPos := LPos or DT_LEFT; - taCenter: LPos := LPos or DT_CENTER; - taRight: LPos := LPos or DT_RIGHT; - end; - S := KOLWideString( Sender.fCaption ); - - // Getting rects - TextWidth := Sender.Canvas.WTextWidth(S); - TextHeight := Sender.Canvas.WTextHeight(S); - - RClient := Sender.ClientRect; - RClient.Left := RClient.Left - Sender.MarginLeft; - RClient.Top := RClient.Top - Sender.MarginTop + (TextHeight div 2); - RClient.Right := RClient.Right + Sender.MarginRight; - RClient.Bottom := RClient.Bottom + Sender.MarginBottom; - - case Sender.fTextAlign of - taCenter: - begin - RText := MakeRect(((RClient.Right div 2) - (TextWidth div 2)) - 2, - RClient.Top-6, - ((RClient.Right div 2) + (TextWidth div 2)) + 2, - TextHeight + (RClient.Top-6)); - RClipLeft := MakeRect(RClient.Left, - RClient.Top, - ((RClient.Right div 2) - (TextWidth div 2)) - 2, - TextHeight + (RClient.Top-6)); - RClipRight := MakeRect(((RClient.Right div 2) + (TextWidth div 2)) + 2, - RClient.Top-6, - RClient.Right, - TextHeight + (RClient.Top-6)); - end; - taRight: - begin - RText := MakeRect((RClient.Right-4) - TextWidth, - RClient.Top-6, - RClient.Right-4, - TextHeight + (RClient.Top-6)); - RClipLeft := MakeRect(RClient.Left, - RClient.Top, - (RClient.Right-4) - TextWidth, - TextHeight + (RClient.Top-6)); - RClipRight := MakeRect(RClient.Right-4, - RClient.Top-6, - RClient.Right, - TextHeight + (RClient.Top-6)); - end; - else - RText := MakeRect(RClient.Left+4, - RClient.Top-6, - TextWidth + RClient.Left+4, - TextHeight + RClient.Top-6); - RClipLeft := MakeRect(RClient.Left, - RClient.Top, - RClient.Left+4, - TextHeight + RClient.Top-6); - RClipRight := MakeRect(TextWidth + RClient.Left+4, - RClient.Top-6, - RClient.Right, - TextHeight + RClient.Top-6); - end; - RClipMain := MakeRect(RClient.Left, - TextHeight + RClient.Top-6, - RClient.Right, - RClient.Bottom); - // Open themes - hThemes := OpenThemeData(Sender.fHandle, 'button'); - if hThemes <> 0 then - begin - Sender.Color := Sender.fParent.fColor; - {$IFDEF USE_FLAGS} - if not (F3_Disabled in Sender.fStyle.f3_Style) then - {$ELSE} - if Sender.fEnabled then - {$ENDIF} - fState := 1 else fState := 2; - // Drawing GroupBox rect "step by step" - DrawThemeBackground(hThemes, DC, 4{BP_GROUPBOX}, fState{GBS_XXXXXX}, RClient, @RClipMain); - DrawThemeBackground(hThemes, DC, 4{BP_GROUPBOX}, fState{GBS_XXXXXX}, RClient, @RClipLeft); - DrawThemeBackground(hThemes, DC, 4{BP_GROUPBOX}, fState{GBS_XXXXXX}, RClient, @RClipRight); - // Drawing GroupBox text - {$IFDEF USE_FLAGS} - if F3_Disabled in Sender.fStyle.f3_Style then - {$ELSE} - if not Sender.fEnabled then - {$ENDIF} - GetThemeColor(hThemes, {WP_CAPTION} 1, {CS_DISABLED} 3, 3803, Color) - else GetThemeColor(hThemes, {WP_CAPTION} 1, {CS_ACTIVE} 1, 3803, Color); - // Close themes - CloseThemeData(hThemes); - - // Create font - F := CreateNewFont(Sender); - fDC := SelectObject(DC, F); - // Draw text - SetBkMode(DC, TRANSPARENT); - TxtColor := SetTextColor(DC, Color2RGB(Color)); - DrawTextW(DC, PWideChar(S), Length(S), RText, LPos or DT_SINGLELINE); - // Backup color - SetTextColor(DC, Color2RGB(TxtColor)); - SetBkMode(DC, OPAQUE); - // Destroying font - SelectObject(DC, fDC); - DeleteObject(F); - end; -end; -//************************* Drawing CheckBox control *************************// -procedure WndCheckBoxXPDraw( Dummy : Pointer; Sender: PControl; DC: HDC ); -var - hThemes : THandle; - RClient, RCheck, RText : TRect; - fState : DWORD; - W, H : Integer; - S : KOLString; - F : HFONT; - fDC : HDC; - Color : COLORREF; - TxtColor : COLORREF; - Brush : HBRUSH; -begin - // Checking user owner-draw - if Assigned(Sender.EV.fOnPaint) and (@Sender.EV.fOnPaint <> @WndCheckBoxXPDraw) then - begin - Sender.EV.fOnPaint(Sender, DC); - exit; - end; - - // Getting metrics - W := GetSystemMetrics( SM_CXMENUCHECK ); - H := GetSystemMetrics( SM_CYMENUCHECK ); - // Getting caption - S := Sender.fCaption; - // Getting rects - RClient := Sender.ClientRect; - RCheck := RClient; - RCheck.Right := RCheck.Left + W; - if {$IFDEF USE_FLAGS} G1_WordWrap in Sender.fFlagsG1 - {$ELSE} Sender.fWordWrap {$ENDIF} then - RCheck.Top := RCheck.Top + Sender.Border - else - RCheck.Top := RCheck.Top + (RCheck.Bottom - RCheck.Top - H) div 2; - RCheck.Bottom := RCheck.Top + H; - RText := MakeRect(RCheck.Right + Sender.fMargin, RCheck.Top, - RClient.Right, RCheck.Bottom); - // Getting state - fState := 1; {CBS_UNCHECKEDNORMAL} - {$IFDEF USE_FLAGS} - if F3_Disabled in Sender.fStyle.f3_Style then - {$ELSE} - if not Sender.fEnabled then - {$ENDIF} - fState := 4 {CBS_UNCHECKEDDISABLED} - else - if {$IFDEF USE_FLAGS} G4_Hot in Sender.fFlagsG4 - {$ELSE} Sender.fHot {$ENDIF} then - fState := 2; {CBS_UNCHECKEDHOT} - if {$IFDEF USE_FLAGS} G4_Pressed in Sender.fFlagsG4 - {$ELSE} Sender.fPressed {$ENDIF} then - fState := 3{CBS_UNCHECKEDPRESSED}; - case Sender.Check3 of - tsChecked : Inc( fState, 4 ); - tsIndeterminate : Inc( fState, 8 ); - end; - - // Draw back layer - if {$IFDEF USE_FLAGS} not( G2_Transparent in Sender.fFlagsG2 ) - {$ELSE} not Sender.fTransparent {$ENDIF} then - begin - Brush := CreateSolidBrush(Color2RGB(Sender.fParent.Color)); - fDC := SelectObject(DC, Brush); - FillRect(DC, RClient, Brush); - SelectObject(DC, fDC); - DeleteObject(Brush); - end; - - // Draw theme - Color := Sender.Font.Color; - hThemes := OpenThemeData(Sender.fHandle, 'button'); - if hThemes <> 0 then - begin - {$IFDEF USE_FLAGS} - if F3_Disabled in Sender.fStyle.f3_Style then - {$ELSE} - if not Sender.fEnabled then - {$ENDIF} - GetThemeColor(hThemes, 1, 4, 3803, Color); - DrawThemeBackground(hThemes, DC, 3 {BP_CHECKBOX}, fState, RCheck, @RCheck); - CloseThemeData(hThemes); - end; - - // Create font - F := CreateNewFont(Sender); - fDC := SelectObject(DC, F); - // Draw text - SetBkMode(DC, TRANSPARENT); - TxtColor := SetTextColor(DC, Color2RGB(Color)); - DrawText(DC, PKOLChar(S), Length(S), RText, DT_LEFT or DT_VCENTER or DT_SINGLELINE); - // Destroying font - SetTextColor(DC, Color2RGB(TxtColor)); - SetBkMode(DC, OPAQUE); - // Destroying object - SelectObject(DC, fDC); - DeleteObject(F); - - // Draw focusrect - if GetFocus = Sender.fHandle then - begin - dec( RText.Left ); - DrawFocusRect(DC, RText); - end; -end; -//************************* Drawing RadioBox control *************************// -procedure WndRadioBoxXPDraw( Dummy : Pointer; Sender: PControl; DC: HDC ); -var - hThemes : THandle; - RClient, RDot, RText : TRect; - fState : DWORD; - W, H : Integer; - S : KOLString; - F : HFONT; - fDC : HDC; - Color, TxtColor : COLORREF; - Brush : HBRUSH; -begin - // Checking user owner-draw - if Assigned(Sender.EV.fOnPaint) and (@Sender.EV.fOnPaint <> @WndRadioBoxXPDraw) then - begin - Sender.EV.fOnPaint(Sender, DC); - exit; - end; - - // Getting metrics - W := GetSystemMetrics( SM_CXMENUCHECK ); - H := GetSystemMetrics( SM_CYMENUCHECK ); - // Getting caption - S := Sender.fCaption; - // Getting rects - RClient := Sender.ClientRect; - RDot := RClient; - RDot.Right := RDot.Left + W; - if {$IFDEF USE_FLAGS} G1_WordWrap in Sender.fFlagsG1 - {$ELSE} Sender.fWordWrap {$ENDIF} then - RDot.Top := RDot.Top + Sender.Border - else - RDot.Top := RDot.Top + (RDot.Bottom - RDot.Top - H) div 2; - RDot.Bottom := RDot.Top + H; - RText := MakeRect(RDot.Right + Sender.Border, RDot.Top, - RClient.Right, RDot.Bottom); - // Getting state - fState := 1; {CBS_UNCHECKEDNORMAL} - {$IFDEF USE_FLAGS} - if F3_Disabled in Sender.fStyle.f3_Style then - {$ELSE} - if not Sender.fEnabled then - {$ENDIF} - fState := 4 {CBS_UNCHECKEDDISABLED} - else - if {$IFDEF USE_FLAGS} G4_Hot in Sender.fFlagsG4 - {$ELSE} Sender.fHot {$ENDIF} then - fState := 2; {CBS_UNCHECKEDHOT} - if {$IFDEF USE_FLAGS} G4_Pressed in Sender.fFlagsG4 - {$ELSE} Sender.fPressed {$ENDIF} then - fState := 3{CBS_UNCHECKEDPRESSED}; - if Sender.Checked then - Inc( fState, 4 ); - - // Draw back layer - if {$IFDEF USE_FLAGS} not( G2_Transparent in Sender.fFlagsG2 ) - {$ELSE} not Sender.fTransparent {$ENDIF} then - begin - Brush := CreateSolidBrush(Color2RGB(Sender.fParent.Color)); - fDC := SelectObject(DC, Brush); - FillRect(DC, RClient, Brush); - SelectObject(DC, fDC); - DeleteObject(Brush); - end; - - // Draw theme - Color := Sender.Font.Color; - hThemes := OpenThemeData(Sender.fHandle, 'button'); - if hThemes <> 0 then - begin - {$IFDEF USE_FLAGS} - if F3_Disabled in Sender.fStyle.f3_Style then - {$ELSE} - if not Sender.fEnabled then - {$ENDIF} - GetThemeColor(hThemes, 1, 4, 3803, Color); - DrawThemeBackground(hThemes, DC, 2 {BP_RADIOBOX}, fState, RDot, @RDot); - CloseThemeData(hThemes); - end; - - // Create font - F := CreateNewFont(Sender); - fDC := SelectObject(DC, F); - // Draw text - SetBkMode(DC, TRANSPARENT); - TxtColor := SetTextColor(DC, Color2RGB(Color)); - DrawText(DC, PKOLChar(S), Length(S), RText, DT_LEFT or DT_VCENTER or DT_SINGLELINE); - // Destroying font - SetTextColor(DC, Color2RGB(TxtColor)); - SetBkMode(DC, OPAQUE); - // Destroying object - SelectObject(DC, fDC); - DeleteObject(F); - - // Draw focusrect - if GetFocus = Sender.fHandle then - begin - dec( RText.Left ); - DrawFocusRect(DC, RText); - end; -end; - -//******************** Drawing Button and BitButton control ******************// -procedure WndButtonXPDraw( Dummy : Pointer; Sender: PControl; DC: HDC ); -var - hThemes : THandle; - F : HFONT; - fDC1, fDC2 : HDC; - RClient : TRect; - RText, R1 : TRect; - RIcon : TRect; - S : WideString; - fState, bStyle : DWORD; - Bmp : HBITMAP; - W, H : Integer; - HPos, VPos : DWORD; - Brush : HBRUSH; - Pen : HPEN; - SenderWidth, SenderHeight : integer; - Flags: DWORD; - _DC : HDC; - OldBmp: HBitmap; - ic : PIcon; - b : PBitmap; - i : integer; - il : PImageList; -begin - // Checking user owner-draw - if Assigned(Sender.EV.fOnPaint) - and (TMethod(Sender.EV.fOnPaint).Code <> @WndButtonXPDraw) then - begin - Sender.EV.fOnPaint(Sender, DC); - exit; - end; - if Assigned(Sender.EV.fOnBitBtnDraw) - and (TMethod(Sender.EV.fOnBitBtnDraw).Code <> @DummyProc123_0) then - begin - fState := 0{PBS_NORMAL}; - {$IFDEF USE_FLAGS} - if F3_Disabled in Sender.fStyle.f3_Style then - {$ELSE} - if not Sender.fEnabled then - {$ENDIF} - fState := 2{PBS_DISABLED} - else - if GetFocus = Sender.fHandle then - fState := 3{PBS_PRESSED} - else - if {$IFDEF USE_FLAGS} G4_Hot in Sender.fFlagsG4 - {$ELSE} Sender.fHot {$ENDIF} then - fState := 4{PBS_HOT}; - if {$IFDEF USE_FLAGS} G4_Pressed in Sender.fFlagsG4 - {$ELSE} Sender.fPressed {$ENDIF} then - fState := 1{PBS_PRESSED}; - Sender.EV.fOnBitBtnDraw(Sender, fState); - exit; - end; - - // Getting rects - RClient := Sender.ClientRect; - RText := RClient; - // Calc bitmap rect - Bmp := Sender.DF.fGlyphBitmap; - HPos := 0; VPos := 0; - if Bmp <> 0 then - begin - SenderWidth := Sender.Width; - SenderHeight := Sender.Height; - W := Sender.DF.fGlyphWidth; - H := Sender.DF.fGlyphHeight; - if Sender.DF.fGlyphLayout in [ glyphLeft ] then - begin - RIcon := MakeRect((SenderWidth div 2) - (W + (W div 4)), - (SenderHeight div 2) - (H div 2), - W, SenderHeight); - RText.Left := (SenderWidth div 2) + (W div 4); - HPos := DT_LEFT; - VPos := DT_VCENTER; - end; - if Sender.DF.fGlyphLayout in [ glyphRight ] then - begin - RIcon := MakeRect((SenderWidth div 2) + (W div 4), - (SenderHeight div 2) - (H div 2), - W, SenderHeight); - RText.Right := (SenderWidth div 2) - (W div 4); - HPos := DT_RIGHT; - VPos := DT_VCENTER; - end; - if Sender.DF.fGlyphLayout in [ glyphOver ] then - begin - RIcon := MakeRect((SenderWidth div 2) - (W div 2), - (SenderHeight div 2) - (H div 2), - W, SenderHeight); - HPos := DT_CENTER; - VPos := DT_VCENTER; - end; - if Sender.DF.fGlyphLayout in [ glyphTop ] then - begin - RIcon := MakeRect((SenderWidth div 2) - (W div 2), - (SenderHeight div 2) - (H + (H div 4)), - W, SenderHeight); - RText.Top := (SenderHeight div 2) + (H div 4); - HPos := DT_CENTER; - VPos := DT_TOP; - end; - if Sender.DF.fGlyphLayout in [ glyphBottom ] then - begin - RIcon := MakeRect((SenderWidth div 2) - (W div 2), - (SenderHeight div 2) + (H div 4), - W, SenderHeight); - RText.Bottom := (SenderHeight div 2) - (H div 4); - HPos := DT_CENTER; - VPos := DT_BOTTOM; - end; - end else - begin - HPos := DT_CENTER; - VPos := DT_VCENTER; - RIcon := MakeRect(0, 0, 0, 0); - end; - - // Getting caption - S := KOLWideString( Sender.fCaption ); - // Getting state - fState := 1{PBS_NORMAL}; - {$IFDEF USE_FLAGS} - if F3_Disabled in Sender.fStyle.f3_Style then - {$ELSE} - if not Sender.fEnabled then - {$ENDIF} - fState := 4{PBS_DISABLED} - else - if {$IFDEF USE_FLAGS} G4_Hot in Sender.fFlagsG4 - {$ELSE} Sender.fHot {$ENDIF} then - fState := 2{PBS_HOT}; - if {$IFDEF USE_FLAGS} G4_Pressed in Sender.fFlagsG4 - {$ELSE} Sender.fPressed {$ENDIF} then - fState := 3{PBS_PRESSED}; - // Opening themes - hThemes := OpenThemeData(Sender.fHandle, 'button'); - if hThemes <> 0 then - begin - Brush := CreateSolidBrush(Color2RGB(Sender.fParent.Color)); - fDC1 := SelectObject(DC, Brush); - FillRect(DC, RClient, Brush); - if (Sender.Flat) and (fState = 1{PBS_NORMAL}) then - begin - Pen := CreatePen(PS_SOLID, 1, clLtGrey); - fDC2 := SelectObject(DC, Pen); - RoundRect(DC, RClient.Left+2, RClient.Top+2, RClient.Right-2, RClient.Bottom-2, 3, 3); - SelectObject(DC, fDC2); - DeleteObject(Pen); - end - else - DrawThemeBackground(hThemes, DC, 1{BP_PUSHBUTTON}, fState, RClient, @RClient); - SelectObject(DC, fDC1); - DeleteObject(Brush); - - if Bmp <> 0 then - begin - if bboImageList in Sender.DF.fBitBtnOptions then - begin - bStyle := ILD_TRANSPARENT; - {$IFDEF USE_FLAGS} - if not (F3_Disabled in Sender.fStyle.f3_Style) then - {$ELSE} - if Sender.fEnabled then - {$ENDIF} - i := Sender.BitBtnImgIdx - else - begin - ic := NewIcon; - ic.fSize := Sender.DF.fGlyphWidth; - ic.fHandle := ImageList_GetIcon(Bmp, Sender.BitBtnImgIdx, bStyle); - b := NewBitmap(ic.fSize, ic.fSize); - b.fHandle := ic.Convert2Bitmap(clBtnFace); - ConvertBitmap2Grayscale(b); - i := ImageList_Add(Bmp, b.fHandle, 0); - Free_And_Nil(b); - Free_And_Nil(ic); - end; - ImageList_Draw(Bmp, i, DC, RIcon.Left, RIcon.Top, bStyle); - end - else - begin - _DC := CreateCompatibleDC( 0 ); - {$IFDEF USE_FLAGS} - if not (F3_Disabled in Sender.fStyle.f3_Style) then - {$ELSE} - if Sender.fEnabled then - {$ENDIF} - OldBmp := SelectObject( _DC, Bmp) - else - begin - bStyle := ILD_TRANSPARENT; - il := NewImageList(Sender.fParent); - il.HandleNeeded; - i := ImageList_Add(il.fHandle, Bmp, 0); - ic := NewIcon; - ic.fSize := Sender.DF.fGlyphWidth; - ic.fHandle := ImageList_GetIcon(il.fHandle, i, bStyle); - b := NewBitmap(ic.fSize, ic.fSize); - b.fHandle := ic.Convert2Bitmap(clBtnFace); - ConvertBitmap2Grayscale(b); - OldBmp := SelectObject( _DC, b.fHandle); - Free_And_Nil(b); - Free_And_Nil(ic); - Free_And_Nil(il); - end; - StretchBlt( DC, RIcon.Left, RIcon.Top, Sender.DF.fGlyphWidth, Sender.DF.fGlyphHeight, - _DC, 0, 0, Sender.DF.fGlyphWidth, Sender.DF.fGlyphHeight, - SRCCOPY); - SelectObject( _DC, OldBmp ); - DeleteDC( _DC ); - end; - end; - // Create font - F := CreateNewFont(Sender); - fDC1 := SelectObject(DC, F); - // Draw text - Flags := HPos or VPos; - R1 := RText; - if Sender.Style and BS_MULTILINE = 0 then - Flags := Flags or DT_SINGLELINE - else - begin - Flags := Flags and not DT_VCENTER or DT_WORDBREAK; - if VPos and DT_VCENTER <> 0 then - begin - DrawTextW(DC, PWideChar( S ), Length(S), R1, Flags or DT_CALCRECT); - OffsetRect( R1, 0, - ( (RText.Bottom - RText.Top) - (R1.Bottom - R1.Top) ) div 2 ); - if HPos and DT_CENTER <> 0 then - OffsetRect( R1, - ( (RText.Right - RText.Left) - (R1.Right - R1.Left) ) div 2, 0 ); - end; - end; - DrawThemeText(hThemes, DC, 1{BP_PUSHBUTTON}, fState, PWideChar(S), Length(S), - Flags, 0, R1); - // Destroying font - SelectObject(DC, fDC1); - DeleteObject(F); - - CloseThemeData(hThemes); - end; - - if (GetFocus = Sender.fHandle) and (bboFocusRect in Sender.DF.fBitBtnOptions) then - DrawFocusRect(DC, MakeRect(RClient.Left+4, RClient.Top+4, RClient.Right-4, RClient.Bottom-4)); -end; -//************************* Control MouseEnter event *************************// -{$IFDEF ASM_VERSION} -procedure WndXPMouseEnter( Dummy : Pointer; Sender: PObj ); -asm - {$IFDEF USE_FLAGS} - OR [EDX].TControl.fFlagsG4, 1 shl G4_Hot - {$ELSE} - MOV [EDX].TControl.fHot, 1 - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EDX].TControl.EV - MOV ECX, [EAX].TEvents.fOnMouseEnter.TMethod.Code - {$ELSE} - MOV ECX, [EDX].TControl.EV.fOnMouseEnter.TMethod.Code - {$ENDIF} - JECXZ @@fin - CMP ECX, offset[WndXPMouseEnter] - JZ @@fin - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnMouseEnter.TMethod.Data - {$ELSE} - MOV EAX, [EDX].TControl.EV.fOnMouseEnter.TMethod.Data - {$ENDIF} - CALL ECX -@@fin: -end; -{$ELSE} -procedure WndXPMouseEnter( Dummy : Pointer; Sender: PObj ); -begin - with PControl(Sender)^ do - begin - {$IFDEF USE_FLAGS} - fFlagsG4 := fFlagsG4 + [G4_Hot]; - {$ELSE} fHot := true; {$ENDIF} - if Assigned(EV.fOnMouseEnter) and - (@EV.fOnMouseEnter <> @WndXPMouseEnter) then - EV.fOnMouseEnter(Sender); - end; -end; -{$ENDIF} -//************************* Control MouseLeave event *************************// -{$IFDEF ASM_VERSION} -procedure WndXPMouseLeave( Dummy : Pointer; Sender: PObj ); -asm - {$IFDEF USE_FLAGS} - AND [EDX].TControl.fFlagsG4, not(1 shl G4_Hot) - {$ELSE} - MOV [EDX].TControl.fHot, 0 - {$ENDIF} - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EDX].TControl.EV - MOV ECX, [EAX].TEvents.fOnMouseLeave.TMethod.Code - {$ELSE} - MOV ECX, [EDX].TControl.EV.fOnMouseLeave.TMethod.Code - {$ENDIF} - JECXZ @@fin - CMP ECX, offset[WndXPMouseLeave] - JZ @@fin - {$IFDEF EVENTS_DYNAMIC} - MOV EAX, [EAX].TEvents.fOnMouseLeave.TMethod.Data - {$ELSE} - MOV EAX, [EDX].TControl.EV.fOnMouseLeave.TMethod.Data - {$ENDIF} - CALL ECX -@@fin: -end; -{$ELSE} -procedure WndXPMouseLeave( Dummy : Pointer; Sender: PObj ); -begin - {$IFDEF USE_FLAGS} - PControl(Sender).fFlagsG4 := - PControl(Sender).fFlagsG4 - [G4_Hot]; - {$ELSE} PControl(Sender).fHot := false; {$ENDIF} - if Assigned(PControl(Sender).EV.fOnMouseLeave) and - (@PControl(Sender).EV.fOnMouseLeave <> @WndXPMouseLeave) then - PControl(Sender).EV.fOnMouseLeave(Sender); -end; -{$ENDIF} -//*************************** Control Message event **************************// -function WndXPMessage( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -var - pt : TPoint; - Mouse: TMouseEventData; - dDC : HDC; -begin - Result := false; - - case Msg.message of - WM_LBUTTONDBLCLK: - begin - if Assigned(Sender.EV.fOnMouseDblClk) then - begin - Mouse.Button := mbLeft; - Mouse.StopHandling := false; - Mouse.R1 := 0; - Mouse.R2 := 0; - Mouse.Shift := 120; - Mouse.X := 0; - Mouse.Y := 0; - GetCursorPos(pt); - if ScreenToClient(Sender.fHandle, pt) then - begin - Mouse.X := pt.X; - Mouse.Y := pt.Y; - end; - Sender.EV.fOnMouseDblClk(Sender, Mouse); - end; - if {$IFDEF USE_FLAGS} not(G5_IsSplitter in Sender.fFlagsG5) - {$ELSE} not Sender.fIsSplitter {$ENDIF} then - Sender.Perform( WM_LBUTTONDOWN, Msg.wParam, Msg.lParam ); - end; - - WM_LBUTTONDOWN: - begin - if Assigned(Sender.EV.fOnMouseDown) then - begin - Mouse.Button := mbLeft; - Mouse.StopHandling := false; - Mouse.R1 := 0; - Mouse.R2 := 0; - Mouse.Shift := 120; - Mouse.X := 0; - Mouse.Y := 0; - GetCursorPos(pt); - if ScreenToClient(Sender.fHandle, pt) then - begin - Mouse.X := pt.X; - Mouse.Y := pt.Y; - end; - Sender.EV.fOnMouseDown(Sender, Mouse); - end; - {$IFDEF USE_FLAGS} Sender.fFlagsG4 := Sender.fFlagsG4 + [G4_Pressed]; - {$ELSE} Sender.fPressed := true; {$ENDIF} - dDC := GetWindowDC(Msg.hWnd); - Sender.EV.fOnPaint(Sender, dDC); - ReleaseDC( Msg.hWnd, dDC ); // vampir_infernal 15.10.2008 - end; - - WM_LBUTTONUP: - begin - if Assigned(Sender.EV.fOnMouseUp) then - begin - Mouse.Button := mbLeft; - Mouse.StopHandling := false; - Mouse.R1 := 0; - Mouse.R2 := 0; - Mouse.Shift := 120; - Mouse.X := 0; - Mouse.Y := 0; - GetCursorPos(pt); - if ScreenToClient(Sender.fHandle, pt) then - begin - Mouse.X := pt.X; - Mouse.Y := pt.Y; - end; - Sender.EV.fOnMouseUp(Sender, Mouse); - end; - {$IFDEF USE_FLAGS} Sender.fFlagsG4 := Sender.fFlagsG4 - [G4_Pressed]; - {$ELSE} Sender.fPressed := false; {$ENDIF} - dDC := GetWindowDC(Msg.hWnd); - Sender.EV.fOnPaint(Sender, dDC); - ReleaseDC( Msg.hWnd, dDC ); - end; - - WM_KEYDOWN: - begin - if Msg.wParam = VK_SPACE then - begin - if Assigned(Sender.EV.fOnKeyDown) then - Sender.EV.fOnKeyDown(Sender, Msg.wParam, GetShiftState); - {$IFDEF USE_FLAGS} Sender.fFlagsG4 := Sender.fFlagsG4 + [G4_Pressed]; - {$ELSE} Sender.fPressed := true; {$ENDIF} - dDC := GetWindowDC(Msg.hWnd); - Sender.EV.fOnPaint(Sender, dDC); - ReleaseDC( Msg.hWnd, dDC ); - end; - end; - - WM_KEYUP: - begin - if Msg.wParam = VK_SPACE then - begin - if Assigned(Sender.EV.fOnKeyUp) then - Sender.EV.fOnKeyUp(Sender, Msg.wParam, GetShiftState); - {$IFDEF USE_FLAGS} Sender.fFlagsG4 := Sender.fFlagsG4 - [G4_Pressed]; - {$ELSE} Sender.fPressed := false; {$ENDIF} - dDC := GetWindowDC(Msg.hWnd); - Sender.EV.fOnPaint(Sender, dDC); - ReleaseDC( Msg.hWnd, dDC ); - end; - end; - - WM_KILLFOCUS: - begin - {$IFDEF USE_FLAGS} Sender.fFlagsG4 := Sender.fFlagsG4 - [G4_Hot]; - {$ELSE} Sender.fHot := false; {$ENDIF} - dDC := GetWindowDC(Msg.hWnd); - Sender.EV.fOnPaint(Sender, dDC); - ReleaseDC( Msg.hWnd, dDC ); - end; - - WM_SETFOCUS: - begin - {$IFDEF USE_FLAGS} Sender.fFlagsG4 := Sender.fFlagsG4 + [G4_Hot]; - {$ELSE} Sender.fHot := TRUE; {$ENDIF} - dDC := GetWindowDC(Msg.hWnd); - Sender.EV.fOnPaint(Sender, dDC); - ReleaseDC( Msg.hWnd, dDC ); - Result := true; - end; - end; -end; -//*************************** Events for CheckBox ****************************// -procedure XP_Themes_For_CheckBox(Sender : PControl); -begin - if AppTheming then - Sender.OnPaint := TOnPaint( MakeMethod( nil, @WndCheckBoxXPDraw ) ); -end; -//*************************** Events for RadioBox ****************************// -procedure XP_Themes_For_RadioBox(Sender : PControl); -begin - if AppTheming then - Sender.OnPaint := TOnPaint( MakeMethod( nil, @WndRadioBoxXPDraw ) ); -end; -//**************************** Events for Panel ******************************// -procedure XP_Themes_For_Panel(Sender : PControl); -begin - if AppTheming then - begin - if Sender.EdgeStyle = esTransparent then Sender.SetTransparent(True) else - begin - Sender.OnResize := TOnEvent( MakeMethod( nil, @WndPanelXPResize ) ); - Sender.OnPaint := TOnPaint( MakeMethod( nil, @WndPanelXPDraw ) ); - end; - end; -end; -//*************************** Events for Splitter ****************************// -procedure XP_Themes_For_Splitter(Sender : PControl); -begin - if AppTheming then - begin - Sender.AttachProc(WndXPMessage); - Sender.OnPaint := TOnPaint( MakeMethod( nil, @WndSplitterXPDraw ) ); - end; -end; -//**************************** Events for Label ******************************// -procedure XP_Themes_For_Label(Sender : PControl); -begin - if AppTheming then Sender.SetTransparent(True); -end; -//************************** Events for GroupBox *****************************// -procedure XP_Themes_For_GroupBox(Sender : PControl); -begin - if AppTheming then - Sender.OnPaint := TOnPaint( MakeMethod( nil, @WndGroupBoxXPDraw ) ); -end; -//************************** Events for TabPanel *****************************// -procedure XP_Themes_For_TabPanel(Sender : PControl); -begin - if AppTheming then - Sender.OnPaint := TOnPaint( MakeMethod( nil, @WndTabXPDraw ) ); -end; -//********************* Events for Button and BitButton **********************// -procedure XP_Themes_For_BitBtn(Sender : PControl); -begin - if AppTheming then - begin - Sender.AttachProc(WndXPMessage); - Sender.OnMouseEnter := TOnEvent( MakeMethod( nil, @WndXPMouseEnter ) ); - Sender.OnMouseLeave := TOnEvent( MakeMethod( nil, @WndXPMouseLeave ) ); - Sender.OnPaint := TOnPaint( MakeMethod( nil, @WndButtonXPDraw ) ); - end; -end; -//*********************** Deattach ownerdraw function ************************// -procedure Deattach(Sender : PControl; PaintProc : Pointer); -begin - if Sender.IsProcAttached(WndXPMessage) then - Sender.DetachProc(WndXPMessage); - if {$IFDEF NIL_EVENTS} Assigned(Sender.EV.fOnMouseEnter) and {$ENDIF} - (@Sender.EV.fOnMouseEnter = @WndXPMouseEnter) - and ({$IFDEF USE_FLAGS} not(G3_Flat in Sender.fFlagsG3) - {$ELSE} not Sender.fFlat {$ENDIF}) then - {$IFDEF NIL_EVENTS} Sender.EV.fOnMouseEnter := nil; - {$ELSE} TMethod( Sender.EV.fOnMouseEnter ).Code := @DummyObjProc; - {$ENDIF} - if {$IFDEF NIL_EVENTS} Assigned(Sender.EV.fOnMouseLeave) and {$ENDIF} - (@Sender.EV.fOnMouseLeave = @WndXPMouseLeave) - and ({$IFDEF USE_FLAGS} not(G3_Flat in Sender.fFlagsG3) - {$ELSE} not Sender.fFlat {$ENDIF}) then - {$IFDEF NIL_EVENTS} Sender.EV.fOnMouseLeave := nil; - {$ELSE} TMethod( Sender.EV.fOnMouseLeave ).Code := @DummyObjProc; - {$ENDIF} - if {$IFDEF NIL_EVENTS} Assigned(Sender.EV.fOnPaint) and {$ENDIF} - (@Sender.EV.fOnPaint = PaintProc) then - {$IFDEF NIL_EVENTS} Sender.EV.fOnPaint := nil; - {$ELSE} TMethod( Sender.EV.fOnPaint ).Code := @DummyObjProc; - {$ENDIF} -end; -//********************* Handling of message WM_THEMECHANGED ******************// -function WndXP_WM_THEMECHANGED( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; -begin - Result := false; - - if Msg.message = $31A {WM_THEMECHANGED} then - begin - if AppTheming then DeinitThemes; - CheckThemes; - if AppTheming then - begin - InitThemes; - if ((Sender.fStyle.Value and BS_AUTOCHECKBOX) = BS_AUTOCHECKBOX) and - (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter, G5_IsBitBtn] * Sender.fFlagsG5 = []) - {$ELSE} - (Sender.fIsGroupBox = false) and - (Sender.fIsSplitter = false) and - (Sender.fIsBitBtn = false) {$ENDIF} then - begin - XP_Themes_For_CheckBox(Sender); - exit; - end; - if ((Sender.fStyle.Value and BS_AUTO3STATE) = BS_AUTO3STATE) and - (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter, G5_IsBitBtn] * Sender.fFlagsG5 = []) - {$ELSE} - (Sender.fIsGroupBox = false) and - (Sender.fIsSplitter = false) and - (Sender.fIsBitBtn = false) {$ENDIF} then - begin - XP_Themes_For_CheckBox(Sender); - exit; - end; - if ((Sender.fStyle.Value and BS_RADIOBUTTON) = BS_RADIOBUTTON) and - (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter, G5_IsBitBtn] * Sender.fFlagsG5 = []) - {$ELSE} - (Sender.fIsGroupBox = false) and - (Sender.fIsSplitter = false) and - (Sender.fIsBitBtn = false) {$ENDIF} then - begin - XP_Themes_For_RadioBox(Sender); - exit; - end; - if ((Sender.fStyle.Value and BS_GROUPBOX) = BS_GROUPBOX) and - (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter, G5_IsBitBtn] * Sender.fFlagsG5 = - [G5_IsGroupbox]) - {$ELSE} - (Sender.fIsGroupBox = true) and - (Sender.fIsSplitter = false) and - (Sender.fIsBitBtn = false) {$ENDIF} then - begin - XP_Themes_For_GroupBox(Sender); - exit; - end; - if (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter] * Sender.fFlagsG5 = []) - {$ELSE} - (Sender.fIsGroupBox = false) and - (Sender.fIsSplitter = false) {$ENDIF} then - begin - XP_Themes_For_BitBtn(Sender); - exit; - end; - if (Sender.SubClassName = 'obj_STATIC') then - begin - if {$IFDEF USE_FLAGS} G1_IsStaticControl in Sender.fFlagsG1 - {$ELSE} Sender.fIsStaticControl > 0 {$ENDIF} then - XP_Themes_For_Label(Sender) - else - begin - if {$IFDEF USE_FLAGS} G5_IsSplitter in Sender.fFlagsG5 - {$ELSE} Sender.fIsSplitter {$ENDIF} then - XP_Themes_For_Splitter(Sender) - else - begin - if Sender.fParent.SubClassName = 'obj_SysTabControl32' then - XP_Themes_For_TabPanel(Sender) - else - XP_Themes_For_Panel(Sender); - end; - end; - exit; - end; - end else - begin - if ((Sender.fStyle.Value and BS_AUTOCHECKBOX) = BS_AUTOCHECKBOX) and - (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter, G5_IsBitBtn] * Sender.fFlagsG5 = []) - {$ELSE} - (Sender.fIsGroupBox = false) and - (Sender.fIsSplitter = false) and - (Sender.fIsBitBtn = false) {$ENDIF} then - begin - Deattach(Sender, @WndCheckBoxXPDraw); - exit; - end; - if ((Sender.fStyle.Value and BS_AUTO3STATE) = BS_AUTO3STATE) and - (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter, G5_IsBitBtn] * Sender.fFlagsG5 = []) - {$ELSE} - (Sender.fIsGroupBox = false) and - (Sender.fIsSplitter = false) and - (Sender.fIsBitBtn = false) {$ENDIF} then - begin - Deattach(Sender, @WndCheckBoxXPDraw); - exit; - end; - if ((Sender.fStyle.Value and BS_RADIOBUTTON) = BS_RADIOBUTTON) and - (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter, G5_IsBitBtn] * Sender.fFlagsG5 = []) - {$ELSE} - (Sender.fIsGroupBox = false) and - (Sender.fIsSplitter = false) and - (Sender.fIsBitBtn = false) {$ENDIF} then - begin - Deattach(Sender, @WndRadioBoxXPDraw); - exit; - end; - if ((Sender.fStyle.Value and BS_GROUPBOX) = BS_GROUPBOX) and - (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter, G5_IsBitBtn] * Sender.fFlagsG5 = - [G5_IsGroupbox]) - {$ELSE} - (Sender.fIsGroupBox = true) and - (Sender.fIsSplitter = false) and - (Sender.fIsBitBtn = false) {$ENDIF} then - begin - Deattach(Sender, @WndGroupBoxXPDraw); - exit; - end; - if (Sender.SubClassName = 'obj_BUTTON') and - {$IFDEF USE_FLAGS} - ([G5_IsGroupbox, G5_IsSplitter] * Sender.fFlagsG5 = []) - {$ELSE} - (Sender.fIsGroupBox = false) and - (Sender.fIsSplitter = false) {$ENDIF} then - begin - Deattach(Sender, @WndButtonXPDraw); - exit; - end; - if (Sender.SubClassName = 'obj_STATIC') then - begin - if {$IFDEF USE_FLAGS} G1_IsStaticControl in Sender.fFlagsG1 - {$ELSE} Sender.fIsStaticControl > 0 {$ENDIF} then - else - begin - if {$IFDEF USE_FLAGS} G5_IsSplitter in Sender.fFlagsG5 - {$ELSE} Sender.fIsSplitter {$ENDIF} then - Deattach(Sender, @WndSplitterXPDraw) - else if Sender.fParent.SubClassName = 'obj_SysTabControl32' then - Deattach(Sender, @WndTabXPDraw) - else - begin - Deattach(Sender, @WndPanelXPDraw); - case Sender.EdgeStyle of - esRaised: - begin - Sender.fStyle.Value := Sender.fStyle.Value and (not SS_SUNKEN); - Sender.fExStyle := Sender.fExStyle and (not WS_EX_STATICEDGE); - Sender.fExStyle := Sender.fExStyle or WS_EX_WINDOWEDGE; - Sender.fStyle.Value := Sender.fStyle.Value or WS_DLGFRAME; - end; - esLowered: - begin - Sender.fStyle.Value := Sender.fStyle.Value and (not WS_DLGFRAME); - Sender.fExStyle := Sender.fExStyle or WS_EX_WINDOWEDGE; - Sender.fExStyle := Sender.fExStyle or WS_EX_STATICEDGE; - Sender.fStyle.Value := Sender.fStyle.Value or SS_SUNKEN; - end; - else - Sender.fStyle.Value := Sender.fStyle.Value and (not SS_SUNKEN) and (not WS_DLGFRAME); - Sender.fExStyle := Sender.fExStyle and (not WS_EX_STATICEDGE) or WS_EX_WINDOWEDGE; - end; - end; - end; - Sender.SetTransparent( - {$IFDEF USE_FLAGS} G2_ClassicTransparent in Sender.fFlagsG2 - {$ELSE} Sender.fClassicTransparent {$ENDIF} ); - exit; - end; - end; - end; -end; -//********************* Attaching to message WM_THEMECHANGED *****************// -type TSenderProc = procedure(Sender: PControl); -{$IFDEF ASM_VERSION} -procedure Attach_WM_THEMECHANGED(Sender : PControl; const XP_Themes_for: TSenderProc); -asm - {$IFDEF USE_FLAGS} - MOV CX, word ptr [EAX].TControl.fFlagsG2 - AND CX, not(1 shl G3_ClassicTransparent)shl 8 or (1 shl G2_Transparent) - OR CL, CH - MOV [EAX].TControl.fFlagsG3, CL - {$ELSE} - MOV CL, [EAX].TControl.fTransparent - MOV [EAX].TControl.fClassicTransparent, CL - {$ENDIF} - PUSH EDX - PUSH EAX - MOV EDX, offset[WndXP_WM_THEMECHANGED] - CALL TControl.AttachProc - POP EAX - POP EDX - CALL EDX -end; -{$ELSE PASCAL} -procedure Attach_WM_THEMECHANGED(Sender : PControl; const XP_Themes_for: TSenderProc); -begin - {$IFDEF USE_FLAGS} - if G2_Transparent in Sender.fFlagsG2 then - Sender.fFlagsG3 := Sender.fFlagsG3 + [G3_ClassicTransparent] - else - Sender.fFlagsG3 := Sender.fFlagsG3 - [G3_ClassicTransparent]; - {$ELSE} Sender.fClassicTransparent := Sender.fTransparent; {$ENDIF} - Sender.AttachProc(WndXP_WM_THEMECHANGED); - XP_Themes_for(Sender); -end; -{$ENDIF ASM_VERSION} -//********************************* End File *********************************// diff --git a/plugins/ImportTXT/make.bat b/plugins/ImportTXT/make.bat index f9136ac2d4..83df36685c 100644 --- a/plugins/ImportTXT/make.bat +++ b/plugins/ImportTXT/make.bat @@ -1,13 +1,22 @@ -rem @echo off -set OUTDIR="..\..\bin10\Release\Plugins" +@echo off +if /i '%1' == 'fpc' ( + set OUTDIR="..\..\bin10\Release\Plugins" + set FPCBIN=fpc.exe +) else if /i '%1' == 'fpc64' ( + set OUTDIR="..\..\bin10\Release64\Plugins" + set FPCBIN=ppcrossx64.exe +) +set PROJECT=ImportTXT + if not exist %OUTDIR% mkdir %OUTDIR% +md tmp + +rem brcc32 -foImpTxt_Ver.res ImpTxt_Ver.rc +rem brcc32 -foImpTxtDlg.res ImpTxtDlg.rc +rem brcc32 -foImpTxtWiz.res ImpTxtWiz.rc + +%FPCBIN% @..\Utils.pas\fpc.cfg %PROJECT%.dpr %2 %3 %4 %5 %6 %7 %8 %9 -set COMPDIR=-$A8 -$D- -$J+ -$L- -$O+ -$Q- -$R- -$Y- -$C- -set INCDIR=".\kol;..\..\include\delphi;..\ExternalAPI\delphi" -set DCUDIR="tmp" -md %DCUDIR% 2>nul -brcc32 -foImpTxt_Ver.res ImpTxt_Ver.rc -brcc32 -foImpTxtDlg.res ImpTxtDlg.rc -brcc32 -foImpTxtWiz.res ImpTxtWiz.rc -dcc32 -B -CG -U%INCDIR% -R%INCDIR% -I%INCDIR% -E%OUTDIR% -LE%DCUDIR% -LN%DCUDIR% -N%DCUDIR% %COMPDIR% ImportTXT.dpr -rd /q /s %DCUDIR% +move .\tmp\%PROJECT%.dll %OUTDIR% +del /Q tmp\* +rd tmp diff --git a/plugins/Libs/CplxMath.pas b/plugins/Libs/CplxMath.pas new file mode 100644 index 0000000000..7cd180af9e --- /dev/null +++ b/plugins/Libs/CplxMath.pas @@ -0,0 +1,278 @@ +unit CplxMath; +{* This unit contains functins for working with complex numbers. To use with + KOL library and its kolmath.pas unit instead of standard math.pas, define + synmbol KOL in project options, or uncomment its definition below. } + +interface + +//{$DEFINE KOL} + +{$IFNDEF KOL} + {$IFDEF KOL_MCK} + {$DEFINE KOL} + {$ENDIF} +{$ENDIF} + +uses {$IFDEF KOL} kolmath, kol {$ELSE} math, sysutils {$ENDIF}; + +type + {$IFDEF CPLX_EXTENDED} + Double = Extended; + {$ENDIF} + + Complex = record Re, Im: double end; + {* } + + function CfromReIm( Re, Im: Double ): Complex; + {* Re + i * Im } + + function Cadd( const X, Y: Complex ): Complex; + {* X + Y } + + function Cneg( const X: Complex ): Complex; + {* -X } + + function Csub( const X, Y: Complex ): Complex; + {* X - Y } + + function Cmul( const X, Y: Complex ): Complex; + {* X * Y } + + function CmulD( const X: Complex; D: Double ): Complex; + {* X * D } + + function CmulI( const X: Complex ): Complex; + {* i * X } + + function Cdiv( const X, Y: Complex ): Complex; + {* X / Y } + + function Cmod( const X: Complex ): Double; + {* Q( X.Re^2 + X.Im^2 ) } + + function Carg( const X: Complex ): Double; + {* arctg( X.Im / X.Re ) } + + function CfromModArg( R, Arg: Double ): Complex; + {* R * ( cos Arg + i * sin Arg ) } + + function Cpow( const X: Complex; Pow: Double ): Complex; + {* X ^ Pow } + + function Cpower( const X, Pow: Complex ): Complex; + {* X ^ Pow } + + function CIntPower( const X: Complex; Pow: Integer ): Complex; + {* X ^ Pow} + + function Csqrt( const X: Complex ): Complex; + {* Q( X ) } + + function Cexp( const X: Complex ): Complex; + {* exp( X ) } + + function Cln( const X: Complex ): Complex; + {* ln( X ) } + + function Ccos( const X: Complex ): Complex; + {* cos( X ) } + + function Csin( const X: Complex ): Complex; + {* sin( X ) } + + function C2Str( const X: Complex ): String; + {* } + + function C2StrEx( const X: Complex ): String; + {* experimental } + +implementation + + function CfromReIm( Re, Im: Double ): Complex; + begin + Result.Re := Re; + Result.Im := Im; + end; + + function Cadd( const X, Y: Complex ): Complex; + begin + Result.Re := X.Re + Y.Re; + Result.Im := X.Im + Y.Im; + end; + + function Cneg( const X: Complex ): Complex; + begin + Result.Re := -X.Re; + Result.Im := -X.Im; + end; + + function Csub( const X, Y: Complex ): Complex; + begin + Result := Cadd( X, Cneg( Y ) ); + end; + + function Cmul( const X, Y: Complex ): Complex; + begin + Result.Re := X.Re * Y.Re - X.Im * Y.Im; + Result.Im := X.Re * Y.Im + X.Im * Y.Re; + end; + + function CmulD( const X: Complex; D: Double ): Complex; + begin + Result.Re := X.Re * D; + Result.Im := X.Im * D; + end; + + function CmulI( const X: Complex ): Complex; + begin + Result.Re := -X.Im; + Result.Im := X.Re; + end; + + function Cdiv( const X, Y: Complex ): Complex; + var Z: Double; + begin + Z := 1.0 / ( Y.Re * Y.Re + Y.Im * Y.Im ); + Result.Re := (X.Re * Y.Re + X.Im * Y.Im ) * Z; + Result.Im := (X.Im * Y.Re - X.Re * Y.Im ) * Z; + end; + + function Cmod( const X: Complex ): Double; + begin + Result := sqrt( X.Re * X.Re + X.Im * X.Im ); + end; + + function Carg( const X: Complex ): Double; + begin + Result := ArcTan2( X.Im, X.Re ); + end; + + function CfromModArg( R, Arg: Double ): Complex; + begin + Result.Re := R * cos( Arg ); + Result.Im := R * sin( Arg ); + end; + + function Cpow( const X: Complex; Pow: Double ): Complex; + var R, A: Double; + begin + R := power( Cmod( X ), Pow ); + A := Pow * Carg( X ); + Result := CfromModArg( R, A ); + end; + + function Cpower( const X, Pow: Complex ): Complex; + begin + Result := Cexp( Cmul( X, Cln( Pow ) ) ); + end; + + function CIntPower( const X: Complex; Pow: Integer ): Complex; + begin + if (Pow < 0) or (Pow > 100) then Result := Cpow( X, Pow ) + else if Pow = 0 then + begin + Result.Re := 1; + Result.Im := 0; + end + else + begin + Result := X; + while Pow > 1 do + begin + Result := Cmul( Result, X ); + dec( Pow ); + end; + end; + end; + + function Csqrt( const X: Complex ): Complex; + begin + Result := Cpow( X, 0.5 ); + end; + + function Cexp( const X: Complex ): Complex; + var Z: Double; + begin + Z := exp( X.Re ); + Result.Re := Z * cos( X.Im ); + Result.Im := Z * sin( X.Im ); + end; + + function Cln( const X: Complex ): Complex; + begin + Result := CfromModArg( ln( Cmod( X ) ), Carg( X ) ); + end; + + function Ccos( const X: Complex ): Complex; + begin + Result := CmulI( X ); + Result := CmulD( Cadd( Cexp( Result ), Cexp( Cneg( Result ) ) ), + 0.5 ); + end; + + function Csin( const X: Complex ): Complex; + begin + Result := CmulI( X ); + Result := CmulD( Csub( Cexp(Result), Cexp( Cneg(Result) ) ), + 0.5 ); + end; + + {$IFDEF KOL} + function Abs( X: Double ): Double; + begin + Result := EAbs( X ); + end; + {$ENDIF} + + {$IFNDEF KOL} + function Double2Str( D: Double ): String; + begin + Result := DoubleToStr( D ); + end; + {$ENDIF} + + function C2Str( const X: Complex ): String; + begin + if Abs( X.Im ) < 1e-307 then + begin + Result := Double2Str( X.Re ); + end + else + begin + Result := ''; + if Abs( X.Re ) > 1e-307 then + begin + Result := Double2Str( X.Re ); + if X.Im > 0.0 then + Result := Result + ' + '; + end; + if X.Im < 0.0 then + Result := Result + '- i * ' + Double2Str( -X.Im ) + else + Result := Result + 'i * ' + Double2Str( X.Im ); + end; + end; + + function C2StrEx( const X: Complex ): String; + begin + if Abs( X.Im ) < 1e-307 then + begin + Result := Double2StrEx( X.Re ); + end + else + begin + Result := ''; + if Abs( X.Re ) > 1e-307 then + begin + Result := Double2StrEx( X.Re ); + if X.Im > 0.0 then + Result := Result + ' + '; + end; + if X.Im < 0.0 then + Result := Result + '- i * ' + Double2StrEx( -X.Im ) + else + Result := Result + 'i * ' + Double2StrEx( X.Im ); + end; + end; + +end. diff --git a/plugins/Libs/KOLEdb.pas b/plugins/Libs/KOLEdb.pas new file mode 100644 index 0000000000..4744adc832 --- /dev/null +++ b/plugins/Libs/KOLEdb.pas @@ -0,0 +1,2209 @@ +unit KOLEdb; +{* This unit is created for KOL to allow to communicate with DB using OLE DB. +|
======================================================================== +|
Copyright (C) 2001 by Vladimir Kladov. +|

+ This unit conains three objects TDataSource, TSession and TQuery to implement + the most important things: to connect to database, to control transactions, + to perform commands (queries) and obtain results or update tables. +|

+} + +interface + +uses Windows, ActiveX, KOL, err; + +type + INT64 = I64; + PInt64 = PI64; + + tagVariant = packed Record + vt: WORD; + reserved1, + reserved2, + reserved3: WORD; + case Integer of + 0: ( bVal : Byte ); + 1: ( iVal : ShortInt ); + 2: ( lVal : Integer ); + 3: ( fltVal : Extended ); + 4: ( dblVal : Double ); + 5: ( boolVal : Bool ); + 6: ( scode : SCODE ); + //7: ( cyVal : CY ); + //8: ( date : Date ); + 9: ( bstrVal : Pointer ); // BSTR => [ Len: Integer; array[ 1..Len ] of WideChar ] + 10:( pdecVal : ^Decimal ); + end; + +(* +typedef struct tagVARIANT { + VARTYPE vt; + unsigned short wReserved1; + unsigned short wReserved2; + unsigned short wReserved3; + union { + Byte bVal; // VT_UI1. + Short iVal; // VT_I2. + long lVal; // VT_I4. + float fltVal; // VT_R4. + double dblVal; // VT_R8. + VARIANT_BOOL boolVal; // VT_BOOL. + SCODE scode; // VT_ERROR. + CY cyVal; // VT_CY. + DATE date; // VT_DATE. + BSTR bstrVal; // VT_BSTR. + DECIMAL FAR* pdecVal // VT_BYREF|VT_DECIMAL. + IUnknown FAR* punkVal; // VT_UNKNOWN. + IDispatch FAR* pdispVal; // VT_DISPATCH. + SAFEARRAY FAR* parray; // VT_ARRAY|*. + Byte FAR* pbVal; // VT_BYREF|VT_UI1. + short FAR* piVal; // VT_BYREF|VT_I2. + long FAR* plVal; // VT_BYREF|VT_I4. + float FAR* pfltVal; // VT_BYREF|VT_R4. + double FAR* pdblVal; // VT_BYREF|VT_R8. + VARIANT_BOOL FAR* pboolVal; // VT_BYREF|VT_BOOL. + SCODE FAR* pscode; // VT_BYREF|VT_ERROR. + CY FAR* pcyVal; // VT_BYREF|VT_CY. + DATE FAR* pdate; // VT_BYREF|VT_DATE. + BSTR FAR* pbstrVal; // VT_BYREF|VT_BSTR. + IUnknown FAR* FAR* ppunkVal; // VT_BYREF|VT_UNKNOWN. + IDispatch FAR* FAR* ppdispVal; // VT_BYREF|VT_DISPATCH. + SAFEARRAY FAR* FAR* pparray; // VT_ARRAY|*. + VARIANT FAR* pvarVal; // VT_BYREF|VT_VARIANT. + void FAR* byref; // Generic ByRef. + char cVal; // VT_I1. + unsigned short uiVal; // VT_UI2. + unsigned long ulVal; // VT_UI4. + int intVal; // VT_INT. + unsigned int uintVal; // VT_UINT. + char FAR * pcVal; // VT_BYREF|VT_I1. + unsigned short FAR * puiVal; // VT_BYREF|VT_UI2. + unsigned long FAR * pulVal; // VT_BYREF|VT_UI4. + int FAR * pintVal; // VT_BYREF|VT_INT. + unsigned int FAR * puintVal; //VT_BYREF|VT_UINT. + }; +}; +*) + +{============= This part of code is grabbed from OLEDB.pas ================} +const + MAXBOUND = 65535; { High bound for arrays } + DBSTATUS_S_ISNULL = $00000003; + +type + PIUnknown = ^IUnknown; + PUintArray = ^TUintArray; + TUintArray = array[0..MAXBOUND] of UINT; + + HROW = UINT; + PHROW = ^HROW; + PPHROW = ^PHROW; + + HACCESSOR = UINT; + HCHAPTER = UINT; + DBCOLUMNFLAGS = UINT; + DBTYPE = Word; + DBKIND = UINT; + DBPART = UINT; + DBMEMOWNER = UINT; + DBPARAMIO = UINT; + DBBINDSTATUS = UINT; + +const + IID_NULL : TGUID = '{00000000-0000-0000-0000-000000000000}'; + IID_IDataInitialize : TGUID = '{2206CCB1-19C1-11D1-89E0-00C04FD7A829}'; + CLSID_MSDAINITIALIZE: TGUID = '{2206CDB0-19C1-11D1-89E0-00C04FD7A829}'; + + IID_IDBInitialize : TGUID = '{0C733A8B-2A1C-11CE-ADE5-00AA0044773D}'; + //IID_IDBProperties : TGUID = '{0C733A8A-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IDBCreateSession: TGUID = '{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IDBCreateCommand: TGUID = '{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}'; + IID_ICommand : TGUID = '{0C733A63-2A1C-11CE-ADE5-00AA0044773D}'; + IID_ICommandText : TGUID = '{0C733A27-2A1C-11CE-ADE5-00AA0044773D}'; + IID_ICommandProperties: TGUID = '{0C733A79-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IRowset : TGUID = '{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IRowsetChange : TGUID = '{0C733A05-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IRowsetUpdate : TGUID = '{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IColumnsInfo : TGUID = '{0C733A11-2A1C-11CE-ADE5-00AA0044773D}'; + IID_IAccessor : TGUID = '{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}'; + + // Added By ECM !!! ================================================== + IID_ITransaction : TGUID = '{0FB15084-AF41-11CE-BD2B-204C4F4F5020}'; + IID_ITransactionLocal: TGUID = '{0C733A5F-2A1C-11CE-ADE5-00AA0044773D}'; + IID_ITransactionOptions: TGUID = '{3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD}'; + // =================================================================== + + // for version 1.5 of OLE DB: + //DBGUID_DBSQL : TGUID = '{c8b522df-5cf3-11ce-ade5-00aa0044773d}'; + + // otherwise: + DBGUID_DBSQL : TGUID = '{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}'; + DBGUID_DEFAULT : TGUID = '{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}'; + DBGUID_SQL : TGUID = '{C8B522D7-5CF3-11CE-ADE5-00AA0044773D}'; + + DBPROPSET_ROWSET : TGUID = '{C8B522BE-5CF3-11CE-ADE5-00AA0044773D}'; + + DB_S_ENDOFROWSET = $00040EC6; + +type + +// *********************************************************************// +// Interface: IDBInitialize +// GUID: {0C733A8B-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IDBInitialize = interface(IUnknown) + ['{0C733A8B-2A1C-11CE-ADE5-00AA0044773D}'] + function Initialize: HResult; stdcall; + function Uninitialize: HResult; stdcall; + end; + +// *********************************************************************// +// Interface: IDBCreateCommand +// GUID: {0C733A1D-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IDBCreateCommand = interface(IUnknown) + ['{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}'] + function CreateCommand(const punkOuter: IUnknown; const riid: TGUID; + out ppCommand: IUnknown): HResult; stdcall; + end; + + (*--- + { Safecall Version } + IDBCreateCommandSC = interface(IUnknown) + ['{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}'] + procedure CreateCommand(const punkOuter: IUnknown; const riid: TGUID; + out ppCommand: IUnknown); safecall; + end; + ---*) + +// *********************************************************************// +// Interface: IDBCreateSession +// GUID: {0C733A5D-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IDBCreateSession = interface(IUnknown) + ['{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}'] + function CreateSession(const punkOuter: IUnknown; const riid: TGUID; + out ppDBSession: IUnknown): HResult; stdcall; + end; + + (*--- + { Safecall Version } + IDBCreateSessionSC = interface(IUnknown) + ['{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}'] + procedure CreateSession(const punkOuter: IUnknown; const riid: TGUID; + out ppDBSession: IUnknown); safecall; + end; + ---*) + +// *********************************************************************// +// Interface: IDataInitialize +// GUID: {2206CCB1-19C1-11D1-89E0-00C04FD7A829} +// *********************************************************************// + IDataInitialize = interface(IUnknown) + ['{2206CCB1-19C1-11D1-89E0-00C04FD7A829}'] + function GetDataSource(const pUnkOuter: IUnknown; dwClsCtx: DWORD; + pwszInitializationString: POleStr; const riid: TIID; + var DataSource: IUnknown): HResult; stdcall; + function GetInitializationString(const DataSource: IUnknown; + fIncludePassword: Boolean; out pwszInitString: POleStr): HResult; stdcall; + function CreateDBInstance(const clsidProvider: TGUID; + const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; + riid: TIID; var DataSource: IUnknown): HResult; stdcall; + function CreateDBInstanceEx(const clsidProvider: TGUID; + const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; + pServerInfo: PCoServerInfo; cmq: ULONG; rgmqResults: PMultiQI): HResult; stdcall; + function LoadStringFromStorage(pwszFileName: POleStr; + out pwszInitializationString: POleStr): HResult; stdcall; + function WriteStringToStorage(pwszFileName, pwszInitializationString: POleStr; + dwCreationDisposition: DWORD): HResult; stdcall; + end; + + (*--- + { Safecall Version } + IDataInitializeSC = interface(IUnknown) + ['{2206CCB1-19C1-11D1-89E0-00C04FD7A829}'] + procedure GetDataSource(const pUnkOuter: IUnknown; dwClsCtx: DWORD; + pwszInitializationString: POleStr; const riid: TIID; + var DataSource: IUnknown); safecall; + procedure GetInitializationString(const DataSource: IUnknown; + fIncludePassword: Boolean; out pwszInitString: POleStr); safecall; + procedure CreateDBInstance(const clsidProvider: TGUID; + const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; + riid: TIID; var DataSource: IUnknown); safecall; + procedure CreateDBInstanceEx(const clsidProvider: TGUID; + const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr; + pServerInfo: PCoServerInfo; cmq: ULONG; rgmqResults: PMultiQI); safecall; + procedure LoadStringFromStorage(pwszFileName: POleStr; + out pwszInitializationString: POleStr); safecall; + procedure WriteStringToStorage(pwszFileName, pwszInitializationString: POleStr; + dwCreationDisposition: DWORD); safecall; + end; + ---*) + +// *********************************************************************// +// Interface: ICommand +// GUID: {0C733A63-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + ICommand = interface(IUnknown) + ['{0C733A63-2A1C-11CE-ADE5-00AA0044773D}'] + function Cancel: HResult; stdcall; + function Execute(const punkOuter: IUnknown; const riid: TGUID; + pParams: Pointer; // var pParams: DBPARAMS; + pcRowsAffected: PInteger; ppRowset: PIUnknown): HResult; stdcall; + function GetDBSession(const riid: TGUID; out ppSession: IUnknown): HResult; stdcall; + end; + + (* + { Safecall Version } + ICommandSC = interface(IUnknown) + ['{0C733A63-2A1C-11CE-ADE5-00AA0044773D}'] + procedure Cancel; safecall; + procedure Execute(const punkOuter: IUnknown; const riid: TGUID; var pParams: DBPARAMS; + pcRowsAffected: PInteger; ppRowset: PIUnknown); safecall; + procedure GetDBSession(const riid: TGUID; out ppSession: IUnknown); safecall; + end; + *) + +// *********************************************************************// +// Interface: ICommandText +// GUID: {0C733A27-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + ICommandText = interface(ICommand) + ['{0C733A27-2A1C-11CE-ADE5-00AA0044773D}'] + function GetCommandText(var pguidDialect: TGUID; + out ppwszCommand: PWideChar): HResult; stdcall; + function SetCommandText(rguidDialect: PGUID; + pwszCommand: PWideChar): HResult; stdcall; + end; + + (* + { Safecall Version } + ICommandTextSC = interface(ICommand) + ['{0C733A27-2A1C-11CE-ADE5-00AA0044773D}'] + procedure GetCommandText(var pguidDialect: TGUID; + out ppwszCommand: PWideChar); safecall; + procedure SetCommandText(rguidDialect: PGUID; + pwszCommand: PWideChar); safecall; + end; + *) + +// *********************************************************************// +// Interface: IRowset +// GUID: {0C733A7C-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IRowset = interface(IUnknown) + ['{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}'] + function AddRefRows(cRows: UINT; rghRows: PUintArray; rgRefCounts: PUintArray; + rgRowStatus: PUintArray): HResult; stdcall; + function GetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall; + function GetNextRows(hReserved: HCHAPTER; lRowsOffset: Integer; cRows: Integer; + out pcRowsObtained: UINT; {var prghRows: PUintArray} prghRows: Pointer ): HResult; stdcall; + function ReleaseRows(cRows: UINT; rghRows: PUintArray; rgRowOptions, + rgRefCounts, rgRowStatus: PUintArray): HResult; stdcall; + function RestartPosition(hReserved: HCHAPTER): HResult; stdcall; + end; + + (* + { Safecall Version } + IRowsetSC = interface(IUnknown) + ['{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}'] + procedure AddRefRows(cRows: UINT; rghRows: PUintArray; rgRefCounts: PUintArray; + rgRowStatus: PUintArray); safecall; + procedure GetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall; + procedure GetNextRows(hReserved: HCHAPTER; lRowsOffset: Integer; cRows: Integer; + out pcRowsObtained: UINT; var prghRows: PUintArray); safecall; + procedure ReleaseRows(cRows: UINT; rghRows: PUintArray; rgRowOptions, + rgRefCounts, rgRowStatus: PUintArray); safecall; + procedure RestartPosition(hReserved: HCHAPTER); safecall; + end; + *) + +// *********************************************************************// +// Interface: IRowsetChange +// GUID: {0C733A05-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IRowsetChange = interface(IUnknown) + ['{0C733A05-2A1C-11CE-ADE5-00AA0044773D}'] + function DeleteRows(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; + rgRowStatus: PUintArray): HResult; stdcall; + function SetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall; + function InsertRow(hReserved: HCHAPTER; HACCESSOR: HACCESSOR; pData: Pointer; + phRow: PHROW): HResult; stdcall; + end; + + (* + { Safecall Version } + IRowsetChangeSC = interface(IUnknown) + ['{0C733A05-2A1C-11CE-ADE5-00AA0044773D}'] + procedure DeleteRows(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; + rgRowStatus: PUintArray); safecall; + procedure SetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall; + procedure InsertRow(hReserved: HCHAPTER; HACCESSOR: HACCESSOR; pData: Pointer; + phRow: PHROW); safecall; + end; + *) + +// *********************************************************************// +// Interface: IRowsetUpdate +// GUID: {0C733A6D-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + DBPENDINGSTATUS = DWORD; + PDBPENDINGSTATUS = ^DBPENDINGSTATUS; + PPDBPENDINGSTATUS = ^PDBPENDINGSTATUS; + + DBROWSTATUS = UINT; + PDBROWSTATUS = ^DBROWSTATUS; + PPDBROWSTATUS = ^PDBROWSTATUS; + + IRowsetUpdate = interface(IRowsetChange) + ['{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}'] + function GetOriginalData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall; + function GetPendingRows(hReserved: HCHAPTER; dwRowStatus: DBPENDINGSTATUS; pcPendingRows: PUINT; + prgPendingRows: PPHROW; prgPendingStatus: PPDBPENDINGSTATUS): HResult; stdcall; + function GetRowStatus(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; + rgPendingStatus: PUintArray): HResult; stdcall; + function Undo(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRowsUndone: PUINT; + prgRowsUndone: PPHROW; prgRowStatus: PPDBROWSTATUS): HResult; stdcall; + function Update(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRows: PUINT; + prgRows: PPHROW; prgRowStatus: PPDBROWSTATUS): HResult; stdcall; + end; + + (* + { Safecall Version } + IRowsetUpdateSC = interface(IRowsetChange) + ['{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}'] + procedure GetOriginalData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall; + procedure GetPendingRows(hReserved: HCHAPTER; dwRowStatus: DBPENDINGSTATUS; pcPendingRows: PUINT; + prgPendingRows: PPHROW; prgPendingStatus: PPDBPENDINGSTATUS); safecall; + procedure GetRowStatus(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; + rgPendingStatus: PUintArray); safecall; + procedure Undo(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRowsUndone: PUINT; + prgRowsUndone: PPHROW; prgRowStatus: PPDBROWSTATUS); safecall; + procedure Update(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRows: PUINT; + prgRows: PPHROW; prgRowStatus: PPDBROWSTATUS); safecall; + end; + *) + +// *********************************************************************// +// Interface: ICommandProperties +// GUID: {0C733A79-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + + DBPROPID = UINT; + PDBPROPID = ^DBPROPID; + PDBPropIDArray = ^TDBPropIDArray; + TDBPropIDArray = array[0..MAXBOUND] of DBPROPID; + + PDBIDGuid = ^TDBIDGuid; + DBIDGUID = record + case Integer of + 0: (guid: TGUID); + 1: (pguid: ^TGUID); + end; + TDBIDGuid = DBIDGUID; + + PDBIDName = ^TDBIDName; + DBIDNAME = record + case Integer of + 0: (pwszName: PWideChar); + 1: (ulPropid: UINT); + end; + TDBIDName = DBIDNAME; + + DBPROPOPTIONS = UINT; + DBPROPSTATUS = UINT; + PPDBID = ^PDBID; + PDBID = ^DBID; + DBID = packed record + uGuid: DBIDGUID; + eKind: DBKIND; + uName: DBIDNAME; + end; + TDBID = DBID; + + PDBProp = ^TDBProp; + DBPROP = packed record + dwPropertyID: DBPROPID; + dwOptions: DBPROPOPTIONS; + dwStatus: DBPROPSTATUS; + colid: DBID; + vValue: tagVariant; // OleVariant; + end; + TDBProp = DBPROP; + + PDBPropArray = ^TDBPropArray; + TDBPropArray = array[0..MAXBOUND] of TDBProp; + + PPDBPropSet = ^PDBPropSet; + PDBPropSet = ^TDBPropSet; + DBPROPSET = packed record + rgProperties: PDBPropArray; + cProperties: UINT; + guidPropertySet: TGUID; + end; + TDBPropSet = DBPROPSET; + + PDBPropIDSet = ^TDBPropIDSet; + DBPROPIDSET = packed record + rgPropertyIDs: PDBPropIDArray; + cPropertyIDs: UINT; + guidPropertySet: TGUID; + end; + TDBPropIDSet = DBPROPIDSET; + + PDBPropIDSetArray = ^TDBPropIDSetArray; + TDBPropIDSetArray = array[0..MAXBOUND] of TDBPropIDSet; + + PDBPropSetArray = ^TDBPropSetArray; + TDBPropSetArray = array[0..MAXBOUND] of TDBPropSet; + + ICommandProperties = interface(IUnknown) + ['{0C733A79-2A1C-11CE-ADE5-00AA0044773D}'] + function GetProperties(cPropertyIDSets: UINT; rgPropertyIDSets: PDBPropIDSetArray; + var pcPropertySets: UINT; out prgPropertySets: PDBPropSet): HResult; stdcall; + function SetProperties(cPropertySets: UINT; rgPropertySets: PDBPropSetArray): HResult; stdcall; + end; + + (* + { Safecall Version } + ICommandPropertiesSC = interface(IUnknown) + ['{0C733A79-2A1C-11CE-ADE5-00AA0044773D}'] + procedure GetProperties(cPropertyIDSets: UINT; rgPropertyIDSets: PDBPropIDSetArray; + var pcPropertySets: UINT; out prgPropertySets: PDBPropSet); safecall; + procedure SetProperties(cPropertySets: UINT; rgPropertySets: PDBPropSetArray); safecall; + end; + *) + + PDBIDArray = ^TDBIDArray; + TDBIDArray = array[0..MAXBOUND] of TDBID; + + PDBColumnInfo = ^TDBColumnInfo; + DBCOLUMNINFO = packed record + pwszName: PWideChar; + pTypeInfo: ITypeInfo; + iOrdinal: UINT; + dwFlags: DBCOLUMNFLAGS; + ulColumnSize: UINT; + wType: DBTYPE; + bPrecision: Byte; + bScale: Byte; + columnid: DBID; + end; + TDBColumnInfo = DBCOLUMNINFO; + + PColumnInfo = ^TColumnInfoArray; + TColumnInfoArray = array[ 0..MAXBOUND ] of TDBColumnInfo; + +// *********************************************************************// +// Interface: IColumnsInfo +// GUID: {0C733A11-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IColumnsInfo = interface(IUnknown) + ['{0C733A11-2A1C-11CE-ADE5-00AA0044773D}'] + function GetColumnInfo(var pcColumns: UINT; out prgInfo: PDBColumnInfo; + out ppStringsBuffer: PWideChar): HResult; stdcall; + function MapColumnIDs(cColumnIDs: UINT; rgColumnIDs: PDBIDArray; + rgColumns: PUintArray): HResult; stdcall; + end; + + (* + { Safecall Version } + IColumnsInfoSC = interface(IUnknown) + ['{0C733A11-2A1C-11CE-ADE5-00AA0044773D}'] + procedure GetColumnInfo(var pcColumns: UINT; out prgInfo: PDBColumnInfo; + out ppStringsBuffer: PWideChar); safecall; + procedure MapColumnIDs(cColumnIDs: UINT; rgColumnIDs: PDBIDArray; + rgColumns: PUINTArray); safecall; + end; + *) + + PDBBindExt = ^TDBBindExt; + DBBINDEXT = packed record + pExtension: PByte; + ulExtension: UINT; + end; + TDBBindExt = DBBINDEXT; + + PDBObject = ^TDBObject; + DBOBJECT = packed record + dwFlags: UINT; + iid: TGUID; + end; + TDBObject = DBOBJECT; + + PDBBinding = ^TDBBinding; + DBBINDING = packed record + iOrdinal: UINT; + obValue: UINT; + obLength: UINT; + obStatus: UINT; + pTypeInfo: Pointer; //ITypeInfo; (reserved, should be nil) + pObject: PDBObject; + pBindExt: PDBBindExt; + dwPart: DBPART; + dwMemOwner: DBMEMOWNER; + eParamIO: DBPARAMIO; + cbMaxLen: UINT; + dwFlags: UINT; + wType: DBTYPE; + bPrecision: Byte; + bScale: Byte; + end; + TDBBinding = DBBINDING; + + PDBBindingArray = ^TDBBindingArray; + TDBBindingArray = array[0..MAXBOUND] of TDBBinding; + +const + DBTYPE_EMPTY = $00000000; + DBTYPE_NULL = $00000001; + DBTYPE_I2 = $00000002; + DBTYPE_I4 = $00000003; + DBTYPE_R4 = $00000004; + DBTYPE_R8 = $00000005; + DBTYPE_CY = $00000006; + DBTYPE_DATE = $00000007; + DBTYPE_BSTR = $00000008; + DBTYPE_IDISPATCH = $00000009; + DBTYPE_ERROR = $0000000A; + DBTYPE_BOOL = $0000000B; + DBTYPE_VARIANT = $0000000C; + DBTYPE_IUNKNOWN = $0000000D; + DBTYPE_DECIMAL = $0000000E; + DBTYPE_UI1 = $00000011; + DBTYPE_ARRAY = $00002000; + DBTYPE_BYREF = $00004000; + DBTYPE_I1 = $00000010; + DBTYPE_UI2 = $00000012; + DBTYPE_UI4 = $00000013; + DBTYPE_I8 = $00000014; + DBTYPE_UI8 = $00000015; + DBTYPE_FILETIME = $00000040; + DBTYPE_GUID = $00000048; + DBTYPE_VECTOR = $00001000; + DBTYPE_RESERVED = $00008000; + DBTYPE_BYTES = $00000080; + DBTYPE_STR = $00000081; + DBTYPE_WSTR = $00000082; + DBTYPE_NUMERIC = $00000083; + DBTYPE_UDT = $00000084; + DBTYPE_DBDATE = $00000085; + DBTYPE_DBTIME = $00000086; + DBTYPE_DBTIMESTAMP = $00000087; + DBTYPE_DBFILETIME = $00000089; + DBTYPE_PROPVARIANT = $0000008A; + DBTYPE_VARNUMERIC = $0000008B; + +type +// *********************************************************************// +// Interface: IAccessor +// GUID: {0C733A8C-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + IAccessor = interface(IUnknown) + ['{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}'] + function AddRefAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT): HResult; stdcall; + function CreateAccessor(dwAccessorFlags: UINT; cBindings: UINT; rgBindings: PDBBindingArray; + cbRowSize: UINT; var phAccessor: HACCESSOR; rgStatus: PUintArray): HResult; stdcall; + function GetBindings(HACCESSOR: HACCESSOR; pdwAccessorFlags: PUINT; var pcBindings: UINT; + out prgBindings: PDBBinding): HResult; stdcall; + function ReleaseAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT): HResult; stdcall; + end; + + (* + { Safecall Version } + IAccessorSC = interface(IUnknown) + ['{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}'] + procedure AddRefAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT); safecall; + procedure CreateAccessor(dwAccessorFlags: UINT; cBindings: UINT; rgBindings: PDBBindingArray; + cbRowSize: UINT; var phAccessor: HACCESSOR; rgStatus: PUintArray); safecall; + procedure GetBindings(HACCESSOR: HACCESSOR; pdwAccessorFlags: PUINT; var pcBindings: UINT; + out prgBindings: PDBBinding); safecall; + procedure ReleaseAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT); safecall; + end; + *) + +// Begin Added By ECM !!! ======================================================= + PBoid = ^TBoid; + BOID = packed record + rgb_: array[0..15] of Byte; + end; + TBoid = BOID; + + PXactTransInfo = ^TXactTransInfo; + XACTTRANSINFO = packed record + uow: BOID; + isoLevel: Integer; + isoFlags: UINT; + grfTCSupported: UINT; + grfRMSupported: UINT; + grfTCSupportedRetaining: UINT; + grfRMSupportedRetaining: UINT; + end; + TXactTransInfo = XACTTRANSINFO; + + PXactOpt = ^TXactOpt; + XACTOPT = packed record + ulTimeout: UINT; + szDescription: array[0..39] of Shortint; + end; + TXActOpt = XACTOPT; + +// *********************************************************************// +// Interface: ITransactionOptions +// GUID: {3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD} +// *********************************************************************// + ITransactionOptions = interface(IUnknown) + ['{3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD}'] + function SetOptions(var pOptions: XACTOPT): HResult; stdcall; + function GetOptions(var pOptions: XACTOPT): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: ITransaction +// GUID: {0FB15084-AF41-11CE-BD2B-204C4F4F5020} +// *********************************************************************// + ITransaction = interface(IUnknown) + ['{0FB15084-AF41-11CE-BD2B-204C4F4F5020}'] + function Commit(fRetaining: BOOL; grfTC: UINT; grfRM: UINT): HResult; stdcall; + function Abort(pboidReason: PBOID; fRetaining: BOOL; fAsync: BOOL): HResult; stdcall; + function GetTransactionInfo(out pinfo: XACTTRANSINFO): HResult; stdcall; + end; + +// *********************************************************************// +// Interface: ITransactionLocal +// GUID: {0C733A5F-2A1C-11CE-ADE5-00AA0044773D} +// *********************************************************************// + ITransactionLocal = interface(ITransaction) + ['{0C733A5F-2A1C-11CE-ADE5-00AA0044773D}'] + function GetOptionsObject(out ppOptions: ITransactionOptions): HResult; stdcall; + function StartTransaction(isoLevel: Integer; isoFlags: UINT; + const pOtherOptions: ITransactionOptions; pulTransactionLevel: PUINT): HResult; stdcall; + end; + +const + XACTTC_SYNC_PHASEONE = $00000001; + XACTTC_SYNC_PHASETWO = $00000002; + XACTTC_SYNC = $00000002; + XACTTC_ASYNC_PHASEONE = $00000004; + XACTTC_ASYNC = $00000004; + +// End Added By ECM !!! ========================================================= + +// Begin Added By azsd !!! ====================================================== +(* +type + PDbNumeric = ^tagDB_NUMERIC; + tagDB_NUMERIC = packed record + precision: Byte; + scale: Byte; + sign: Byte; + val: array[0..15] of Byte; + end; +*) +// End Added By azsd !!! ======================================================== + +{============= This part of code is designed by me ================} +type + PDBBINDSTATUSARRAY = ^TDBBINDSTATUSARRAY; + TDBBINDSTATUSARRAY = array[ 0..MAXBOUND ] of DBBINDSTATUS; + +//'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +// TDataSource - a connection to data base +//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, +type + PDataSource = ^TDataSource; + TDataSource = object( TObj ) + {* This object provides a connection with data base. You create it using + NewDataSource function and passing a connection string to it. The object + is initializing immediately after creating. You can get know if the + connection established successfully reading Intitialized property. } + private + fSessions: PList; + fIDBInitialize: IDBInitialize; + FInitialized: Boolean; + protected + function Initialize( const Params: String ): Boolean; + public + constructor Create; + {* Do not call this constructor. Use function NewDataSource instead. } + destructor Destroy; virtual; + {* Do not call this destructor. Use Free method instead. When TDataSource + object is destroyed, all its sessions (and consequensly, all queries) + are freed automatically. } + property Initialized: Boolean read FInitialized; + {* Returns True, if the connection with database is established. Mainly, + it is not necessary to analizy this flag. If any error occure during + initialization, CheckOle halts further execution. (But You can use + another error handler, which does not stop the application). } + end; + +function NewDataSource( const Params: String ): PDataSource; +{* Creates data source objects and initializes it. Pass a connection + string as a parameter, which determines used provider, database + location, user identification and other parameters. See demo provided + or/and read spicifications from database software vendors, which + parameters to pass. } + +//'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +// TSession - transaction session in a connection +//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, +type + PSession = ^TSession; + TSession = object( TObj ) + {* This object is intended to provide session transactions. It always + must be created as a "child" of TDataSource object, and it owns by + query objects (of type TQuery). For each TDataSource object, it is + possible to create several TSession objects, and for each session, + several TQuery objects can exist. } + private + fQueryList: PList; + fDataSource: PDataSource; + fCreateCommand: IDBCreateCommand; + + // Added By ECM !!! ================== + fTransaction: ITransaction; + fTransactionLocal: ITransactionLocal; + // =================================== + + protected + public + constructor Create; + {* } + destructor Destroy; virtual; + {* Do not call directly, call Free method instead. When TSession object is + destroyed, all it child queries are freed automatically. } + + // Added By ECM !!! ==================================== + function StartTransaction(isoLevel: Integer): HRESULT; + function Commit(Retaining: BOOL): HRESULT; + function Rollback(Retaining: BOOL): HRESULT; + function Active: Boolean; + // ===================================================== + + property DataSource: PDataSource read fDataSource; + {* Returns a pointer to owner TDataSource object. } + end; + +function NewSession( ADataSource: PDataSource ): PSession; +{* Creates session object owned by ADataSource (this last must exist). } + +//'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +// TQuery - a command and resulting rowset(s) +//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, +type + TRowsetMode = ( rmUpdateImmediate, rmUpdateDelayed, rmReadOnly ); + TFieldType = ( ftInteger, ftReal, ftString, ftDate, ftLargeInt, ftOther ); + + PQuery = ^TQuery; + TQuery = object( TObj ) + {* This is the most important object to work with database. It is always + must be created as a "child" of TSession object, and allows to perform + commands, open rowsets, scroll it, update and so on. } + private + fSession: PSession; + fText: String; + fCommand: ICommandText; + fCommandProps: ICommandProperties; + fRowsAffected: Integer; + fRowSet: IRowset; + fRowSetChg: IRowsetChange; + fRowSetUpd: IRowsetUpdate; + fColCount: UINT; + fColInfo: PColumnInfo; + fColNames: PWideChar; + fBindings: PDBBindingArray; + fBindStatus: PDBBINDSTATUSARRAY; + fRowSize: Integer; + fAccessor: HACCESSOR; + fRowHandle: THandle; + fRowBuffers: PList; + fEOF: Boolean; + fCurIndex: Integer; + fChanged: Boolean; + fMode: TRowsetMode; + procedure SetText(const Value: String); + function GetRowCount: Integer; + function GetColNames(Idx: Integer): String; + procedure SetCurIndex(const Value: Integer); + function GetRowsKnown: Integer; + function GetStrField(Idx: Integer): String; + procedure SetStrField(Idx: Integer; const Value: String); + function GetIntField(Idx: Integer): Integer; + procedure SetIntField(Idx: Integer; const Value: Integer); + function GetFltField(Idx: Integer): Double; + procedure SetFltField(Idx: Integer; const Value: Double); + function GetDField(Idx: Integer): TDateTime; + procedure SetDField(Idx: Integer; const Value: TDateTime); + function FieldPtr( Idx: Integer ): Pointer; + function Changed( Idx: Integer ): Pointer; + function GetColByName(Name: String): Integer; + function GetSFieldByName(const Name: String): String; + procedure SetSFieldByName(const Name: String; const Value: String); + function GetIFieldByName(const Name: String): Integer; + procedure SetIFieldByName(const Name: String; Value: Integer); + function GetRFieldByName(const Name: String): Double; + procedure SetRFieldByName(const Name: String; const Value: Double); + function GetDFlfByName(const Name: String): TDateTime; + procedure SetDFldByName(const Name: String; const Value: TDateTime); + function GetColType(Idx: Integer): TFieldType; + function GetColTypeByName(const Name: String): TFieldType; + function GetIsNull(Idx: Integer): Boolean; + procedure SetIsNull(Idx: Integer; const Value: Boolean); + function GetIsNullByName(const Name: String): Boolean; + procedure SetIsNullByName(const Name: String; const Value: Boolean); + function GetFByNameAsStr(const Name: String): String; + function GetFieldAsStr(Idx: Integer): String; + procedure SetFByNameFromStr(const Name, Value: String); + procedure SetFieldFromStr(Idx: Integer; const Value: String); + function GetI64Field(Idx: Integer): Int64; + function GetI64FldByName(const Name: String): Int64; + procedure SetI64Field(Idx: Integer; const Value: Int64); + procedure SetI64FldByName(const Name: String; const Value: Int64); + function GetFixupNumeric(Idx: Integer): Int64; //add by azsd + function GetRawType(Idx: Integer): DWORD; + function GetRawTypeByName(const Name: String): DWORD; + function GetFieldAsHex(Idx: Integer): Pointer; + function GetFieldByNameAsHex(const Name: String): Pointer; + protected + fDelList: PList; + procedure ClearRowset; + procedure ReleaseHandle; + procedure FetchData; + procedure NextWOFetch( Skip: Integer ); + public + destructor Destroy; virtual; + {* Do not call the destructor directly, call method Free instead. When + "parent" TSession object is destroyed, all queries owned by the session + are destroyed automatically. } + property Session: PSession read fSession; + {* Returns owner session object. } + property Text: String read FText write SetText; + {* Query command text. When You change it, currently opened rowset (if any) + is closed, so there are no needs to call Close method before preparing + for new command. Current version does not support passing "parameters", + so include all values into Text as a part of string. } + procedure Close; + {* Closes opened rowset if any. It is not necessary to call close after + Execute. Also, rowset is closed automatically when another value is + assigned to Text property. } + procedure Execute; + {* Call this method to execute command (stored in Text), which does not + open a rowset (thus is, "insert", "delete", and "update" SQL statements + do so). } + procedure Open; + {* Call this method for executing command, which opens a rowset (table of + data). This can be "select" SQL statement, or call to stored procedure, + which returns result in a table. } + property RowCount: Integer read GetRowCount; + {* For commands, such as "insert", "delete" or "update" SQL statements, + this property returns number of rows affected by a command. For "select" + statement performed using Open method, this property should return + a number of rows selected. By for (the most) providers, this value is + unknown for first time (-1 is returned). To get know how much rows are + in returned rowset, method Last should be called first. But for large + data returned this is not efficient way, because actually a loop + "while not EOF do Next" is performed to do so. + |
+ Tip: to get count of rows, You can call another query, which executes + "select count(*) where..." SQL statement with the same conditions. } + property RowsKnown: Integer read GetRowsKnown; + {* Returns actual number or selected rows, if this is "known" value, or number + of rows already fetched. } + property ColCount: UINT read fColCount; + {* Returns number of columns in opened rowset. } + property ColNames[ Idx: Integer ]: String read GetColNames; + {* Return names of columns. } + property ColByName[ Name: String ]: Integer read GetColByName; + {* Returns column index by name. Comparing of names is ANSI and case insensitive. } + property ColType[ Idx: Integer ]: TFieldType read GetColType; + {* } + property ColTypeByName[ const Name: String ]: TFieldType read GetColTypeByName; + {* } + function FirstColumn: Integer; + {* by Alexander Shakhaylo. To return an index of the first column, + containing actual data. (for .mdb, the first can contain special + control information, but not for .dbf) } + property RawType[ Idx: Integer ]: DWORD read GetRawType; + {*} + property RawTypeByName[ const Name: String ]: DWORD read GetRawTypeByName; + {*} + property EOF: Boolean read fEOF; + {* Returns True, if end of data is achived (usually after calling Next + or Prev method, or immediately after Open, if there are no rows in opened + rowset). } + procedure First; + {* Resets a position to the start of rowset. This method is called + automatically when Open is called successfully. } + procedure Next; + {* Moves position to the next row if possible. If EOF achived, a position + is not changed. } + procedure Prev; + {* Moves position to a previous row (but if CurIndex > 0). } + procedure Last; + {* Moves position to the last row. This method can be unefficient for + large datasets, because implemented as a loop where method Next is + called repeteadly, while EOF is not achieved. } + property Mode: TRowsetMode read fMode write fMode; + {* } + procedure Post; + {* Applyes changes made in a record, writing changed row to database table. } + procedure Delete; + {* Deletes a row. In rmUpdateDelayed Mode, rows are only added to a list + for later deleting it when Update called. } + procedure Update; + {* Allows to apply all updates far later, not when Post method is called. + To use TQuery in this manner, its Mode should be set to rmUpdateDelayed. } + property CurIndex: Integer read fCurIndex write SetCurIndex; + {* Index of current row. It is possible to change it directly even if + specified row is not yet fetched. But check at least what new value is + stored in CurIndex after such assignment. } + property SField[ Idx: Integer ]: String read GetStrField write SetStrField; + {* Access to a string field by index. You should be sure, that a field + has string type. } + property SFieldByName[ const Name: String ]: String read GetSFieldByName write SetSFieldByName; + {* } + property IField[ Idx: Integer ]: Integer read GetIntField write SetIntField; + {* Access to a integer field by index. You should be sure, that a field + has integer type or compatible. } + property IFieldByName[ const Name: String ]: Integer read GetIFieldByName write SetIFieldByName; + {* } + property LField[ Idx: Integer ]: Int64 read GetI64Field write SetI64Field; + {* } + property LFieldByName[ const Name: String ]: Int64 read GetI64FldByName write SetI64FldByName; + {* } + property RField[ Idx: Integer ]: Double read GetFltField write SetFltField; + {* Access to a real (Double) field by index. You should be sure, that a field + has numeric (with floating decimal point) type. } + property RFieldByName[ const Name: String ]: Double read GetRFieldByName write SetRFieldByName; + {* } + property DField[ Idx: Integer ]: TDateTime read GetDField write SetDField; + {* } + property DFieldByName[ const Name: String ]: TDateTime read GetDFlfByName write SetDFldByName; + {* } + property IsNull[ Idx: Integer ]: Boolean read GetIsNull write SetIsNull; + {* } + property IsNullByName[ const Name: String ]: Boolean read GetIsNullByName write SetIsNullByName; + {* } + property FieldAsStr[ Idx: Integer ]: String read GetFieldAsStr write SetFieldFromStr; + {* } + property FieldByNameAsStr[ const Name: String ]: String read GetFByNameAsStr write SetFByNameFromStr; + {* } + property FieldAsHex[ Idx: Integer ]: Pointer read GetFieldAsHex; + {* Access to field data directly. If you change field data inplace, call + MarkRecordChanged by yourself. If field IsNull, data found at the address + provided have no sense. } + property FieldByNameAsHex[ const Name: String ]: Pointer read GetFieldByNameAsHex; + {* See FieldByNameAsHex. } + procedure MarkFieldChanged( Idx: Integer ); + {* See also MarkRecordChangedByName. } + procedure MarkFieldChangedByName( const Name: String ); + {* When record field changed directly (using FieldAsHex property, for ex.), + use this method to signal to record set container, that record is changed, + and to ensure that field no more marked as null. } + end; + +function NewQuery( Session: PSession ): PQuery; +{* Creates query object. } + +// Error handling routines: + +function CheckOLE( Rslt: HResult ): Boolean; +function CheckOLEex( Rslt: HResult; const OKResults: array of HResult ): Boolean; +procedure DummyOleError( Result: HResult ); +var OleError: procedure( Result: HResult ) = DummyOleError; + +implementation + +type + PDBNumeric = ^TDBNumeric; + TDBNUMERIC = packed record + precision: Byte; + scale: Byte; + sign: Byte; + val: array[0..15] of Byte; + end; + + PDBVarNumeric = ^TDBVarNumeric; + TDBVARNUMERIC = packed record + precision: Byte; + scale: ShortInt; + sign: Byte; + val: ^Byte; + end; + + PDBDate = ^TDBDate; + TDBDATE = packed record + year: Smallint; + month: Word; + day: Word; + end; + + PDBTime = ^TDBTIME; + TDBTIME = packed record + hour: Word; + minute: Word; + second: Word; + end; + + PDBTimeStamp = ^TDBTimeStamp; + TDBTIMESTAMP = packed record + year: Smallint; + month: Word; + day: Word; + hour: Word; + minute: Word; + second: Word; + fraction: UINT; + end; + +var fIMalloc: IMalloc = nil; + +(* procedure DummyOleError( Result: HResult ); +begin + MsgOK( 'OLE DB error ' + Int2Hex( Result, 8 ) ); + Halt; +end; *) + +procedure DummyOleError( Result: HResult ); +begin + raise Exception.Create( e_Custom, 'OLE DB error ' + Int2Hex( Result, 8 ) ); +end; + +function CheckOLE( Rslt: HResult ): Boolean; +begin + Result := Rslt = 0; + if not Result then + OleError( Rslt ); +end; + +function CheckOLEex( Rslt: HResult; const OKResults: array of HResult ): Boolean; +var I: Integer; +begin + Result := TRUE; + for I := Low( OKResults ) to High( OKResults ) do + if Rslt = OKResults[ I ] then Exit; + Result := FALSE; + OleError( Rslt ); +end; + +{ TDataSource } + +function NewDataSource( const Params: String ): PDataSource; +begin + new( Result, Create ); + Result.Initialize( Params ); +end; + +constructor TDataSource.Create; +var clsid: TCLSID; +begin + inherited; + fSessions := NewList; + //if CheckOLEex( CoInitialize( nil ), [ S_OK, S_FALSE ] ) then + OleInit; + if CheckOLE( CoGetMalloc( MEMCTX_TASK, fIMalloc ) ) then + if CheckOLE( CLSIDFromProgID( 'SQLOLEDB', clsid ) ) then + CheckOLE( CoCreateInstance( clsid, nil, CLSCTX_INPROC_SERVER, + IID_IDBInitialize, fIDBInitialize ) ); +end; + +destructor TDataSource.Destroy; +var I: Integer; +begin + for I := fSessions.Count - 1 downto 0 do + PObj( fSessions.Items[ I ] ).Free; + fSessions.Free; + if Initialized then + CheckOLE( fIDBInitialize.UnInitialize ); + OleUnInit; + inherited; +end; + +function TDataSource.Initialize( const Params: String ): Boolean; +var DI: IDataInitialize; + Unk: IUnknown; +begin + Result := FALSE; + if Initialized then + begin + Result := TRUE; + Exit; + end; + if CheckOLE( CoCreateInstance( CLSID_MSDAINITIALIZE, nil, + CLSCTX_ALL, IID_IDataInitialize, DI ) ) then + if CheckOLE( DI.GetDataSource( nil, CLSCTX_ALL, StringToOleStr( Params ), + IID_IDBInitialize, Unk ) ) then + if CheckOLE( Unk.QueryInterface( IID_IDBInitialize, fIDBInitialize ) ) then + if CheckOLE( fIDBInitialize.Initialize ) then + begin + Result := TRUE; + FInitialized := Result; + end; +end; + +{ TSession } + +function NewSession( ADataSource: PDataSource ): PSession; +var CreateSession: IDBCreateSession; + Unk: IUnknown; +begin + new( Result, Create ); + Result.fDataSource := ADataSource; + ADataSource.fSessions.Add( Result ); + // Modified by ECM !!! =============================================================================== + if CheckOLE( ADataSource.fIDBInitialize.QueryInterface( IID_IDBCreateSession, CreateSession ) ) then begin + CheckOLE( CreateSession.CreateSession( nil, IID_IDBCreateCommand, + IUnknown( Result.fCreateCommand ) ) ); + + Unk := Result.fCreateCommand; + if Assigned(Unk) then begin + CheckOLE(Unk.QueryInterface(IID_ITransaction,Result.fTransaction)); + CheckOLE(Unk.QueryInterface(IID_ITransactionLocal,Result.fTransactionLocal)); + end; + end; + // ================================================================================================= +end; + +// Added By ECM !!! ============================================== +function TSession.Active: Boolean; +var + xinfo: TXactTransInfo; + Ret: HRESULT; +begin + if not Assigned(fTransaction) then Result := FALSE + else begin + FillChar(xinfo,SizeOf(xinfo),0); + Ret := fTransaction.GetTransactionInfo(xinfo); + Result := Ret = S_OK; + CheckOLE(Ret); + end; +end; + +function TSession.Commit(Retaining: BOOL): HRESULT; +begin + Assert(Assigned(fTransaction)); + Result := fTransaction.Commit(Retaining,XACTTC_SYNC,0); + CheckOLE(Result); +end; +// =============================================================== + +constructor TSession.Create; +begin + inherited; + fQueryList := NewList; +end; + +destructor TSession.Destroy; +var I: Integer; +begin + for I := fQueryList.Count - 1 downto 0 do + PObj( fQueryList.Items[ I ] ).Free; + fQueryList.Free; + I := fDataSource.fSessions.IndexOf( @Self ); + fDataSource.fSessions.Delete( I ); + // Add By ECM !!! ================ + // if Active then Rollback(FALSE); + //================================ + fCreateCommand := nil; + inherited; +end; + +// Added By ECM !!! =============================================== +function TSession.Rollback(Retaining: BOOL): HRESULT; +begin + Assert(Assigned(fTransaction)); + Result := fTransaction.Abort(nil,Retaining,FALSE); + CheckOLE(Result); +end; + +function TSession.StartTransaction(isoLevel: Integer): HRESULT; +begin + Assert(Assigned(fTransactionLocal)); + Result := fTransactionLocal.StartTransaction(isoLevel,0,nil,nil); + CheckOLE(Result); +end; +// ================================================================ + +{ TQuery } + +function NewQuery( Session: PSession ): PQuery; +begin + new( Result, Create ); + Result.fSession := Session; + Session.fQueryList.Add( Result ); + CheckOLE( Session.fCreateCommand.CreateCommand( nil, IID_ICommandText, + IUnknown( Result.fCommand ) ) ); +end; + +function TQuery.Changed( Idx: Integer ): Pointer; +begin + fChanged := TRUE; + Result := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + + fBindings[ Idx ].obStatus ); + PDWORD( Result )^ := 0; // set to NOT NULL +end; + +procedure TQuery.ClearRowset; +var I: Integer; + AccessorIntf: IAccessor; +begin + ReleaseHandle; + + if fAccessor <> 0 then + begin + if CheckOLE( fRowSet.QueryInterface( IID_IAccessor, AccessorIntf ) ) then + AccessorIntf.ReleaseAccessor( fAccessor, nil ); + fAccessor := 0; + end; + + if fRowBuffers <> nil then + begin + for I := fRowBuffers.Count - 1 downto 0 do + FreeMem( fRowBuffers.Items[ I ] ); + fRowBuffers.Free; + fRowBuffers := nil; + end; + fRowSize := 0; + + if fBindings <> nil then + begin + //for I := 0 to fColCount - 1 do + // fBindings[ I ].pTypeInfo := nil; + FreeMem( fBindings ); + fBindings := nil; + FreeMem( fBindStatus ); + fBindStatus := nil; + end; + + if fColInfo <> nil then + fIMalloc.Free( fColInfo ); + fColInfo := nil; + + if fColNames <> nil then + fIMalloc.Free( fColNames ); + fColNames := nil; + + fColCount := 0; + fRowSetUpd := nil; + fRowSet := nil; + fRowSetChg := nil; + fRowsAffected := 0; + + fEOF := TRUE; +end; + +procedure TQuery.Close; +begin + Update; + ClearRowset; +end; + +procedure TQuery.Delete; +var Params, Results: array of DWORD; +begin + //if fRowHandle = 0 then Exit; + CASE fMode OF + rmUpdateImmediate: + begin + SetLength( Results, 1 ); + SetLength( Params, 1 ); + Params[ 0 ] := fRowHandle; + CheckOLE( fRowSetUpd.DeleteRows( 0, 1, @ Params[ 0 ], @ Results[ 0 ] ) ); + end; + rmUpdateDelayed: + begin + if fDelList = nil then + fDelList := NewList; + fDelList.Add( Pointer( fRowHandle ) ); + end; + END; +end; + +destructor TQuery.Destroy; +var I: Integer; +begin + Close; //ClearRowset; + I := fSession.fQueryList.IndexOf( @Self ); + if I >= 0 then + fSession.fQueryList.Delete( I ); + fText := ''; + fCommandProps := nil; + fCommand := nil; + fDelList.Free; + inherited; +end; + +procedure TQuery.Execute; +begin + ClearRowset; + // first set txt to fCommand just before execute + if CheckOLE( fCommand.SetCommandText( @DBGUID_DBSQL, StringToOleStr( fText ) ) ) then + CheckOLE( fCommand.Execute( nil, IID_NULL, nil, @fRowsAffected, nil ) ); +end; + +procedure TQuery.FetchData; +var Buffer: Pointer; +begin + if fRowHandle = 0 then + Exit; + if fRowBuffers.Items[ fCurIndex ] = nil then + begin + GetMem( Buffer, fRowSize ); + FillChar( Buffer^, fRowSize, 0 ); //fixup the varnumberic random bytes by azsd + fRowBuffers.Items[ fCurIndex ] := Buffer; + CheckOLE( fRowSet.GetData( fRowHandle, fAccessor, fRowBuffers.Items[ fCurIndex ] ) ); + end; +end; + +function TQuery.FieldPtr(Idx: Integer): Pointer; +begin + if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then + Result := nil + else + Result := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + + fBindings[ Idx ].obValue ); +end; + +procedure TQuery.First; +begin + if fCurIndex = 0 then Exit; + ReleaseHandle; + fCurIndex := -1; + if CheckOLE( fRowSet.RestartPosition( 0 ) ) then + begin + fEOF := FALSE; + Next; + end; +end; + +function TQuery.FirstColumn: Integer; +var i: integer; +begin + Result := -1; + for i := 0 to fColCount - 1 do begin + if fBindings[i].iOrdinal > 0 then begin + Result := i; + exit; + end; + end; +end; + +function TQuery.GetColByName(Name: String): Integer; +var I: Integer; +begin + Result := -1; + for I := 0 to fColCount - 1 do + begin + if AnsiCompareStrNoCase( Name, ColNames[ I ] ) = 0 then + begin + Result := I; + break; + end; + end; +end; + +function TQuery.GetColNames(Idx: Integer): String; +begin + Result := fColInfo[ Idx ].pwszName; +end; + +function TQuery.GetColType(Idx: Integer): TFieldType; +begin + Result := ftOther; + if fBindings = nil then Exit; + case fBindings[ Idx ].wType of + DBTYPE_I1, DBTYPE_I2, DBTYPE_I4, DBTYPE_BOOL, + DBTYPE_UI1, DBTYPE_UI2, DBTYPE_UI4 : Result := ftInteger; + DBTYPE_I8, DBTYPE_UI8 : Result := ftLargeInt; + DBTYPE_BSTR, DBTYPE_WSTR, DBTYPE_STR: Result := ftString; + DBTYPE_R4, DBTYPE_R8, DBTYPE_CY, + DBTYPE_NUMERIC, DBTYPE_VARNUMERIC, + DBTYPE_DECIMAL : Result := ftReal;// no need new cate here,moved to GetFieldAsStr + DBTYPE_DATE, DBTYPE_FILETIME, //DBTYPE_DBFILETIME, + DBTYPE_DBDATE, DBTYPE_DBTIME, + DBTYPE_DBTIMESTAMP : Result := ftDate; + else Result := ftOther; + end; +end; + +function TQuery.GetColTypeByName(const Name: String): TFieldType; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >= 0, 'Incorrect column name (' + Name + ').' ); + Result := ColType[ Idx ]; +end; + +function TQuery.GetDField(Idx: Integer): TDateTime; +var P: Pointer; + ST: TSystemTime; + pD: PDBDate; + pT: PDBTime; + TS: PDBTimeStamp; + pFT: PFileTime; +begin + P := FieldPtr( Idx ); + if P = nil then + Result := 0.0 + else + begin + FillChar( ST, Sizeof(ST), 0 ); + case fBindings[ Idx ].wType of + DBTYPE_DATE: Result := PDouble( P )^ + VCLDate0; + DBTYPE_DBDATE: + begin + pD := P; + ST.wYear := pD.year; + ST.wMonth := pD.month; + ST.wDay := pD.day; + SystemTime2DateTime( ST, Result ); + end; + DBTYPE_DBTIME: + begin + pT := P; + ST.wYear := 1899; + ST.wMonth := 12; + ST.wDay := 31; + ST.wHour := pT.hour; + ST.wMinute := pT.minute; + ST.wSecond := pT.second; + SystemTime2DateTime( ST, Result ); + Result := Result - VCLDate0; + end; + DBTYPE_DBTIMESTAMP: + begin + TS := P; + ST.wYear := TS.year; + ST.wMonth := TS.month; + ST.wDay := TS.day; + ST.wHour := TS.hour; + ST.wMinute := TS.minute; + ST.wSecond := TS.second; + ST.wMilliseconds := TS.fraction div 1000000; + SystemTime2DateTime( ST, Result ); + end; + DBTYPE_FILETIME: + begin + pFT := P; + FileTimeToSystemTime( pFT^, ST ); + SystemTime2DateTime( ST, Result ); + end; + else Result := 0.0; + end; + end; +end; + +function TQuery.GetDFlfByName(const Name: String): TDateTime; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := DField[ Idx ]; +end; + +function TQuery.GetFByNameAsStr(const Name: String): String; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := FieldAsStr[ Idx ]; +end; + +function TQuery.GetFieldAsHex(Idx: Integer): Pointer; +begin + {if IsNull[ Idx ] then + Result := nil + else} + Result := FieldPtr( Idx ); +end; + +function TQuery.GetFieldAsStr(Idx: Integer): String; +begin + if IsNull[ Idx ] then + Result := '(null)' + else + case ColType[ Idx ] of + ftReal: + //added optimize by azsd + begin + case fBindings[ Idx ].wType of + DBTYPE_NUMERIC,DBTYPE_VARNUMERIC: + if ShortInt(PDBNumeric(FieldPtr(Idx)).scale)<>0 then + Result := Double2Str( RField[ Idx ] ) + else + Result := Int64_2Str( LField[ Idx ] ); + else + Result := Double2Str( RField[ Idx ] ); + end; + end; + ftString: Result := SField[ Idx ]; + ftDate: Result := DateTime2StrShort( DField[ Idx ] ); + ftLargeInt: Result := Int64_2Str( LField[ Idx ] );//add by azsd + //ftInteger: + else Result := Int2Str( IField[ Idx ] ); + //else Result := '(?)'; + end; +end; + +function TQuery.GetFieldByNameAsHex(const Name: String): Pointer; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := FieldAsHex[ Idx ]; +end; + +function TQuery.GetFltField(Idx: Integer): Double; +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Result := 0.0 + else + case fBindings[ Idx ].wType of + DBTYPE_R4: Result := PSingle( P )^; + DBTYPE_R8: Result := PDouble( P )^; + DBTYPE_CY: Result := PInteger( P )^ * 0.0001; + //TODO: DBTYPE_DECIMAL + DBTYPE_NUMERIC, DBTYPE_VARNUMERIC: + begin + Result := Int64_2Double(GetFixupNumeric(Idx)); + if PDBNumeric(P).sign=0 then Result := 0 - Result; + if PDBNumeric(P).scale<>0 then Result := Result * IntPower( 10, 0 - Shortint(PDBNumeric(P).scale)); + end; + else Result := 0.0; + end; +end; + +function TQuery.GetFixupNumeric(Idx: Integer): Int64; +var + P: Pointer; +begin + P := FieldPtr( Idx ); + Result := MakeInt64( 0, 0 ); + if P=nil then Exit; + case fBindings[ Idx ].wType of + DBTYPE_NUMERIC: + Result := PInt64( DWORD(P)+3 )^; //131 filled with 00 + DBTYPE_VARNUMERIC: + begin + Result := PInt64( DWORD(P)+3 )^; //139 containing some shit bytes + //vn := P; + //if vn.precision> then + //fix-up done in Fetchdata + end; + else + Result := MakeInt64( PDWORD( DWORD(P)+3 )^, 0 ); + end; +end; + +function TQuery.GetI64Field(Idx: Integer): Int64; +const His: array[ 0..1 ] of Integer = ( 0, -1 and not 255 ); +var P: Pointer; + B: Byte; +begin + P := FieldPtr( Idx ); + Result := MakeInt64( 0, 0 ); + if P <> nil then + case fBindings[ Idx ].wType of + DBTYPE_I8, DBTYPE_UI8, DBTYPE_CY: + Result := PInt64( P )^; + DBTYPE_I1: + begin + B := PByte( P )^; + Result := Int2Int64( Integer( B ) or His[ B shr 7 ] ); + end; + DBTYPE_UI1: Result := MakeInt64( PByte( P )^, 0 ); + DBTYPE_I2: Result := Int2Int64( PShortInt( P )^ ); + DBTYPE_UI2: Result := MakeInt64( PWord( P )^, 0 ); + DBTYPE_I4: Result := Int2Int64( PInteger( P )^ ); + DBTYPE_NUMERIC, DBTYPE_VARNUMERIC: + begin + if ShortInt(PDBNumeric(P).scale)<>0 then + Result := Double2Int64( RField[Idx] ) + else + Result := GetFixupNumeric(Idx); + end; + //DBTYPE_UI4: + else Result := MakeInt64( PInteger( P )^, 0 ); + end; +end; + +function TQuery.GetI64FldByName(const Name: String): Int64; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := LField[ Idx ]; +end; + +function TQuery.GetIFieldByName(const Name: String): Integer; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := IField[ Idx ]; +end; + +function TQuery.GetIntField(Idx: Integer): Integer; +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Result := 0 + else + case fBindings[ Idx ].wType of + DBTYPE_I1: begin + Result := PByte( P )^; + if LongBool( Result and $80) then + Result := Result or not $7F; + end; + DBTYPE_UI1: Result := PByte( P )^; + DBTYPE_I2, DBTYPE_UI2, DBTYPE_BOOL: Result := PShortInt( P )^; + DBTYPE_NUMERIC, DBTYPE_VARNUMERIC: + begin + if ShortInt(PDBNumeric(P).scale)<>0 then + Result := Round( RField[Idx] ) + else + Result := GetFixupNumeric(Idx).Lo; + end; + //DBTYPE_I4, DBTYPE_UI4, DBTYPE_HCHAPTER: + else Result := PInteger( P )^; + end; +end; + +function TQuery.GetIsNull(Idx: Integer): Boolean; +var P: PDWORD; +begin + Result := TRUE; + if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then + Exit; + P := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + + fBindings[ Idx ].obStatus ); + Result := P^ = DBSTATUS_S_ISNULL; +end; + +function TQuery.GetIsNullByName(const Name: String): Boolean; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := IsNull[ Idx ]; +end; + +function TQuery.GetRawType(Idx: Integer): DWORD; +begin + Result := 0; + if fBindings = nil then Exit; + Result := fBindings[ Idx ].wType; +end; + +function TQuery.GetRawTypeByName(const Name: String): DWORD; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := RawType[ Idx ]; +end; + +function TQuery.GetRFieldByName(const Name: String): Double; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := RField[ Idx ]; +end; + +function TQuery.GetRowCount: Integer; +begin + {if fRowsAffected = DB_S_ASYNCHRONOUS then + begin + // only for asynchronous connections - do not see now + end;} + Result := fRowsAffected; +end; + +function TQuery.GetRowsKnown: Integer; +begin + Result := fRowsAffected; + if Result = 0 then + if fRowBuffers <> nil then + Result := fRowBuffers.Count; +end; + +function TQuery.GetSFieldByName(const Name: String): String; +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + Result := SField[ Idx ]; +end; + +function TQuery.GetStrField(Idx: Integer): String; +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Result := '' + else + if fBindings[ Idx ].wType = DBTYPE_STR then + Result := PChar( P ) + else + Result := PWideChar( P ); +end; + +procedure TQuery.Last; +begin + while not EOF do + Next; //WOFetch( 0 ); + if RowsKnown > 0 then + fCurIndex := RowsKnown; + Prev; + //FetchData; + fEOF := FALSE; +end; + +procedure TQuery.MarkFieldChanged(Idx: Integer); +begin + Changed( Idx ); +end; + +procedure TQuery.MarkFieldChangedByName(const Name: String); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + MarkFieldChanged( Idx ); +end; + +procedure TQuery.Next; +begin + NextWOFetch( 0 ); + FetchData; +end; + +procedure TQuery.NextWOFetch( Skip: Integer ); +var Obtained: UINT; + PHandle: Pointer; + hr: HResult; +begin + ReleaseHandle; + PHandle := @fRowHandle; + if (fCurIndex = fRowsAffected) and (Skip = -2) then + hr := fRowSet.GetNextRows( 0, -1, 1, Obtained, @PHandle ) + else + hr := fRowSet.GetNextRows( 0, Skip, 1, Obtained, @PHandle ); + if hr <> DB_S_ENDOFROWSET then + CheckOLE( hr ); + Inc( fCurIndex, Skip + 1 ); + if Obtained = 0 then + begin + fEOF := TRUE; + if fRowBuffers <> nil then + fRowsAffected := fRowBuffers.Count; + end + else + begin + if fRowBuffers = nil then + fRowBuffers := NewList; + if fCurIndex >= fRowBuffers.Count then + fRowBuffers.Add( nil ); + end; +end; + +procedure TQuery.Open; +const + DB_NULLID: DBID = (uguid: (guid: (D1: 0; D2: 0; D3:0; D4: (0, 0, 0, 0, 0, 0, 0, 0))); + ekind: 1 {DBKIND_GUID_PROPID}; uname: (ulpropid:0)); + +var ColInfo: IColumnsInfo; + AccessorIntf: IAccessor; + I: Integer; + OK: Boolean; + + PropSets: array[0..0] of TDBPropset; + Props: array[ 0..0 ] of TDBProp; +begin + ClearRowset; + if CheckOLE( fCommand.SetCommandText( @DBGUID_DBSQL, StringToOleStr( fText ) ) ) then + begin + if Mode = rmReadOnly then + begin + if not CheckOLE( fCommand.Execute( nil, IID_IROWSET, nil, @fRowsAffected, PIUnknown( @fRowSet ) ) ) then + Exit; + end + else + begin + // Add by ECM !!! + {$IFNDEF IBPROVIDER} + if fCommandProps = nil then + begin + if CheckOLE( fCommand.QueryInterface( IID_ICommandProperties, fCommandProps ) ) then + begin + PropSets[0].rgProperties := @ Props[ 0 ]; + PropSets[0].cProperties := 1; + PropSets[0].guidPropertySet := DBPROPSET_ROWSET; + + Props[0].dwPropertyID := $00000075; //DBPROP_UPDATABILITY + Props[0].dwOptions := 0; //DBPROPOPTIONS_REQUIRED; + Props[0].dwStatus := 0; //DBPROPSTATUS_OK; + Props[0].colid := DB_NULLID; + Props[0].vValue.vt := VT_I4; + Props[0].vValue.lVal := 1; //DBPROPVAL_UP_CHANGE; + end; + end; + CheckOLE( fCommandProps.SetProperties( 1, @ PropSets[ 0 ] ) ); + {$ENDIF} + if not CheckOLE( fCommand.Execute( nil, IID_IROWSETCHANGE, nil, nil, PIUnknown( @ fRowSetChg ) ) ) then + Exit; + if not CheckOLE( fRowSetChg.QueryInterface( IID_IROWSET, fRowSet ) ) then + Exit; + if Mode = rmUpdateDelayed then + CheckOLE( fRowSetChg.QueryInterface( IID_IROWSETUPDATE, fRowSetUpd ) ); + end; + + if fRowsAffected = 0 then + Dec( fRowsAffected ); // RowCount = -1 means that RowCount is an unknown value + if fRowSetChg <> nil then + begin + OK := CheckOLE( fRowSetChg.QueryInterface( IID_IColumnsInfo, ColInfo ) ); + end + else + begin + OK := CheckOLE( fRowSet.QueryInterface( IID_IColumnsInfo, ColInfo ) ); + end; + if OK then + if CheckOLE( ColInfo.GetColumnInfo( fColCount, PDBColumnInfo( fColInfo ), fColNames ) ) then + begin + fBindings := AllocMem( Sizeof( TDBBinding ) * fColCount); + for I := 0 to fColCount - 1 do + begin + fBindings[ I ].iOrdinal := fColInfo[ I ].iOrdinal; + fBindings[ I ].obValue := fRowSize + 4; + // fBindings[ I ].obLength := 0; + fBindings[ I ].obStatus := fRowSize; + // fBindings[ I ].pTypeInfo := nil; + // fBindings[ I ].pObject := nil; + // fBindings[ I ].pBindExt := nil; + fBindings[ I ].dwPart := 1 + 4; //DBPART_VALUE + DBPART_STATUS; + // fBindings[ I ].dwMemOwner := 0; //DBMEMOWNER_CLIENTOWNED; + // fBindings[ I ].eParamIO := 0; //DBPARAMIO_NOTPARAM; + fBindings[ I ].cbMaxLen := fColInfo[ I ].ulColumnSize; + case fColInfo[ I ].wType of + DBTYPE_BSTR: Inc( fBindings[ I ].cbMaxLen, 1 ); + DBTYPE_WSTR: fBindings[ I ].cbMaxLen := fBindings[ I ].cbMaxLen * 2 + 2; + end; + fBindings[ I ].cbMaxLen := (fBindings[ I ].cbMaxLen + 3) and not 3; + // fBindings[ I ].dwFlags := 0; + fBindings[ I ].wType := fColInfo[ I ].wType; + fBindings[ I ].bPrecision := fColInfo[ I ].bPrecision; + fBindings[ I ].bScale := fColInfo[ I ].bScale; + Inc( fRowSize, fBindings[ I ].cbMaxLen + 4 ); + end; + fBindStatus := AllocMem( Sizeof( DBBINDSTATUS ) * fColCount ); + if fRowSetChg <> nil then + begin + OK := CheckOLE( fRowSetChg.QueryInterface( IID_IAccessor, AccessorIntf ) ); + end + else + begin + OK := CheckOLE( fRowSet.QueryInterface( IID_IAccessor, AccessorIntf ) ); + end; + if OK then + CheckOLE( + AccessorIntf.CreateAccessor( + 2, //DBACCESSOR_ROWDATA, // Accessor will be used to retrieve row data + fColCount, // Number of columns being bound + fBindings, // Structure containing bind info + 0, // Not used for row accessors + fAccessor, // Returned accessor handle + PUIntArray( fBindStatus ) // Information about binding validity + ) + ); + fEOF := FALSE; + fCurIndex := -1; + First; + end; + end; +end; + +procedure TQuery.Post; +var R: HResult; + {P: PChar; + I: Integer;} +begin + if not fChanged then Exit; + if fRowSetChg = nil then Exit; + R := fRowSetChg.SetData( fRowHandle, fAccessor, fRowBuffers.Items[ fCurIndex ] ); + if R <> HResult( $00040EDA {DB_S_ERRORSOCCURED} ) then + CheckOLE( R ) + { // я вижу только статус DBSTATUS_E_INTEGRITYVIOLATION касательно 0-й колонки, + // которую никто не просил добавлять во время выборки. + else + begin + asm + int 3 + end; + for I := 0 to fColCount-1 do + begin + P := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) + + fBindings[ I ].obStatus ); + ShowMessage( fColInfo[I].pwszName + '.Status=' + Int2Hex( PDWORD( P )^, 8 ) ); + end; + end}; + fChanged := FALSE; +end; + +procedure TQuery.Prev; +begin + if CurIndex > 0 then + begin + NextWOFetch( -2 ); //*** + //Dec( fCurIndex ); + fEOF := FALSE; + FetchData; //*** + end; +end; + +procedure TQuery.ReleaseHandle; +begin + if fRowHandle <> 0 then + CheckOLE( fRowSet.ReleaseRows( 1, @fRowHandle, nil, nil, nil ) ); + fRowHandle := 0; +end; + +procedure TQuery.SetCurIndex(const Value: Integer); +var OldCurIndex: Integer; +begin + OldCurIndex := fCurIndex; + if fCurIndex = Value then + begin + if fRowHandle = 0 then + FetchData; + if fRowHandle <> 0 then + Exit; + end; + if Value = 0 then + First + else + if Value >= fRowsAffected - 1 then + Last; + + fEOF := FALSE; + while (fCurIndex < Value) and not EOF do + Next; + while (fCurIndex > Value) and not EOF do + Prev; + + if fCurIndex = Value then + FetchData + else + fCurIndex := OldCurIndex; +end; + +procedure TQuery.SetDField(Idx: Integer; const Value: TDateTime); +var P: Pointer; + ST: TSystemTime; + pD: PDBDate; + pT: PDBTime; + TS: PDBTimeStamp; + pFT: PFileTime; +begin + P := FieldPtr( Idx ); + if P = nil then Exit; + case fBindings[ Idx ].wType of + DBTYPE_DATE: PDouble( P )^ := Value - VCLDate0; + DBTYPE_DBDATE: + begin + pD := P; + DateTime2SystemTime( Value, ST ); + pD.year := ST.wYear; + pD.month := ST.wMonth; + pD.day := ST.wDay; + end; + DBTYPE_DBTIME: + begin + pT := P; + DateTime2SystemTime( Value, ST ); + pT.hour := ST.wHour; + pT.minute := ST.wMinute; + pT.second := ST.wSecond; + end; + DBTYPE_DBTIMESTAMP: + begin + TS := P; + DateTime2SystemTime( Value, ST ); + TS.year := ST.wYear; + TS.month := ST.wMonth; + TS.day := ST.wDay; + TS.hour := ST.wHour; + TS.minute := ST.wMinute; + TS.second := ST.wSecond; + TS.fraction := ST.wMilliseconds * 1000; + end; + DBTYPE_FILETIME: + begin + pFT := P; + DateTime2SystemTime( Value, ST ); + SystemTimeToFileTime( ST, pFT^ ); + end; + else Exit; + end; + Changed( Idx ); +end; + +procedure TQuery.SetDFldByName(const Name: String; const Value: TDateTime); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + DField[ Idx ] := Value; +end; + +procedure TQuery.SetFByNameFromStr(const Name, Value: String); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + FieldAsStr[ Idx ] := Value; +end; + +procedure TQuery.SetFieldFromStr(Idx: Integer; const Value: String); +begin + if StrEq( Value, '(null)' ) and (ColType[ Idx ] <> ftString) then + IsNull[ Idx ] := TRUE + else + case ColType[ Idx ] of + ftInteger: IField[ Idx ] := Str2Int( Value ); + ftReal: RField[ Idx ] := Str2Double( Value ); + ftString: SField[ Idx ] := Value; + ftDate: DField[ Idx ] := Str2DateTimeShort( Value ); + end; +end; + +procedure TQuery.SetFltField(Idx: Integer; const Value: Double); +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Exit; + case fBindings[ Idx ].wType of + DBTYPE_R4: PExtended( P )^ := Value; + DBTYPE_R8: PDouble( P )^ := Value; + DBTYPE_CY: PInteger( P )^ := Round( Value * 10000 ); + //TODO: DBTYPE_NUMERIC, DBTYPE_VARNUMERIC, DBTYPE_DECIMAL + else Exit; + end; + Changed( Idx ); +end; + +procedure TQuery.SetI64Field(Idx: Integer; const Value: Int64); +begin + +end; + +procedure TQuery.SetI64FldByName(const Name: String; const Value: Int64); +begin + +end; + +procedure TQuery.SetIFieldByName(const Name: String; Value: Integer); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + IField[ Idx ] := Value; +end; + +procedure TQuery.SetIntField(Idx: Integer; const Value: Integer); +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Exit; + case fBindings[ Idx ].wType of + DBTYPE_I1, DBTYPE_UI1: PByte( P )^ := Byte( Value ); + DBTYPE_I2, DBTYPE_UI2: PShortInt( P )^ := Value; + DBTYPE_BOOL: if Value <> 0 then PShortInt( P )^ := -1 + else PShortInt( P )^ := 0; + else PInteger( P )^ := Value; + end; + Changed( Idx ); +end; + +procedure TQuery.SetIsNull(Idx: Integer; const Value: Boolean); +var P: PDWORD; +begin + if not Value then Exit; + if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then + Exit; + P := Changed( Idx ); + P^ := DBSTATUS_S_ISNULL; +end; + +procedure TQuery.SetIsNullByName(const Name: String; const Value: Boolean); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + IsNull[ Idx ] := Value; +end; + +procedure TQuery.SetRFieldByName(const Name: String; const Value: Double); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + RField[ Idx ] := Value; +end; + +procedure TQuery.SetSFieldByName(const Name: String; const Value: String); +var Idx: Integer; +begin + Idx := ColByName[ Name ]; + Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' ); + SField[ Idx ] := Value; +end; + +procedure TQuery.SetStrField(Idx: Integer; const Value: String); +var P: Pointer; +begin + P := FieldPtr( Idx ); + if P = nil then + Exit; + if fBindings[ Idx ].wType = DBTYPE_STR then + StrLCopy( PChar( P ), @ Value[ 1 ], fBindings[ Idx ].cbMaxLen ) + else + StringToWideChar( Value, PWideChar( P ), fBindings[ Idx ].cbMaxLen ); + Changed( Idx ); +end; + +procedure TQuery.SetText(const Value: String); +begin + // clear here current rowset if any: + ClearRowset; + {// set txt to fCommand -- do this at the last moment just before execute + CheckOLE( fCommand.SetCommandText( DBGUID_DBSQL, StringToOleStr( Value ) ) );} + FText := Value; +end; + +procedure TQuery.Update; +var Params, Results: array of DWORD; + I: Integer; +begin + if Mode <> rmUpdateDelayed then Exit; + if (fDelList <> nil) and (fDelList.Count > 0) then + begin + SetLength( Params, fDelList.Count ); + SetLength( Results, fDelList.Count ); + for I := 0 to fDelList.Count-1 do + Params[ I ] := DWORD( fDelList.Items[ I ] ); + CheckOLE( fRowSetUpd.DeleteRows( 0, fDelList.Count, @ Params[ 0 ], @ Results[ 0 ] ) ); + Free_And_Nil( fDelList ); + end; + if fRowSetUpd = nil then Exit; + CheckOLE( fRowSetUpd.Update( 0, 0, nil, nil, nil, nil ) ); +end; + +end. diff --git a/plugins/Libs/KOLMHTooltip_implem.inc b/plugins/Libs/KOLMHTooltip_implem.inc new file mode 100644 index 0000000000..869ba0233d --- /dev/null +++ b/plugins/Libs/KOLMHTooltip_implem.inc @@ -0,0 +1,437 @@ +// part of KOLMHToolTip -- interface_part. +// Moved to separate inc-file still Delphi20XX does not allow compile +// in DEBUG mode. + +const + Dummy1 = 1; + + TTDT_AUTOMATIC = 0; + TTDT_RESHOW = 1; + TTDT_AUTOPOP = 2; + TTDT_INITIAL = 3; + +function NewMHToolTip(AParent: PControl): PMHToolTip; +const + CS_DROPSHADOW = $00020000; +begin + DoInitCommonControls(ICC_BAR_CLASSES); + New(Result, Create); + + Result.fHandle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, '', 0, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, AParent.GetWindowHandle, 0, HInstance, nil); +end; + +function TMHToolTip.GetDelay(const Index: Integer): Integer; +begin + Result := SendMessage(fHandle, TTM_GETDELAYTIME, Index, 0); +end; + + +procedure TMHToolTip.SetDelay(const Index, Value: Integer); +begin + SendMessage(handle, TTM_SETDELAYTIME, Index, MAKELONG(Value, 0)); +end; + + +function TMHToolTip.GetColor(const Index: Integer): TColor; +begin + Result := SendMessage(handle, TTM_GETTIPBKCOLOR + Index, 0, 0); +end; + +procedure TMHToolTip.SetColor(const Index: Integer; const Value: TColor); +begin + SendMessage(handle, TTM_SETTIPBKCOLOR + Index, Value, 0); +end; + +function TMHToolTip.GetMaxWidth: Integer; +begin + Result := SendMessage(fHandle, TTM_GETMAXTIPWIDTH, 0, 0); +end; + +procedure TMHToolTip.SetMaxWidth(const Value: Integer); +begin + SendMessage(fHandle, TTM_SETMAXTIPWIDTH, 0, Value); +end; + +function TMHToolTip.GetMargin: TRect; +begin + SendMessage(fHandle, TTM_GETMARGIN, 0, DWord(@Result)); +end; + +procedure TMHToolTip.SetMargin(const Value: TRect); +begin + SendMessage(fHandle, TTM_SETMARGIN, 0, DWord(@Value)); +end; + +function TMHToolTip.GetActivate: Boolean; +begin + // ?????? + Result := False; +end; + +procedure TMHToolTip.SetActivate(const Value: Boolean); +begin + SendMessage(fHandle, TTM_ACTIVATE, DWord(Value), 0); +end; + +procedure TMHToolTip.Pop; +begin + SendMessage(fHandle, TTM_POP, 0, 0); +end; + +procedure TMHToolTip.Popup; +begin + SendMessage(fHandle, $0422 {TTM_POPUP}, 0, 0); +end; + +procedure TMHToolTip.Update; +begin + inherited; // ??? + SendMessage(fHandle, TTM_UPDATE, 0, 0); +end; + +function NewHint(A: PControl): PMHHint; +begin + New(Result, Create); + + with Result^ do + begin + Parent := A; + ToolTip := nil; // ??? + HasTool := False; // ??? + end; + A.Add2AutoFree(Result); +end; + +function NewManager: PMHToolTipManager; +begin + New(Result, Create); +end; + +{ TMHHint } + +function TMHHint.GetDelay(const Index: Integer): Integer; +begin +// CreateToolTip; + Result := 0; + if Assigned(ToolTip) then + Result := ToolTip.GetDelay(Index); +end; + +function TMHHint.GetFI: TFI; +begin + /// !!! DANGER-WITH !!! + with Result, ToolTip^ do + begin + FE := FE + [eTextColor]; + Colors[1] := TextColor; + + FE := FE + [eBkColor]; + Colors[0] := BkColor; + + FE := FE + [eAPDelay]; + Delays[TTDT_AUTOPOP] := AutoPopDelay; + + FE := FE + [eRDelay]; + Delays[TTDT_RESHOW] := ReshowDelay; + + FE := FE + [eIDelay]; + Delays[TTDT_INITIAL] := InitialDelay; + end; +end; + +procedure TMHHint.ReConnect(FI: TFI); +var + TMP: PMHToolTip; +begin + with GetManager^ do + begin + TMP := FindNeed(FI); + if not Assigned(TMP) then + TMP := CreateNeed(FI); + if Assigned(ToolTip) and HasTool then + MoveTool(TMP); + ToolTip := TMP; + end; +end; + +procedure TMHHint.MoveTool(T1: PMHToolTip); +var + TI: TToolInfo; + TextL: array[0..255] of KOLChar; +begin + if T1 = ToolTip then + Exit; + with TI do + begin + cbSize := SizeOf(TI); + hWnd := Parent.GetWindowHandle; + uId := Parent.GetWindowHandle; + lpszText := @TextL[0]; + end; + + SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); + SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI)); + ToolTip.Count := ToolTip.Count - 1; + SendMessage(T1.handle, TTM_ADDTOOL, 0, DWORD(@TI)); + T1.Count := T1.Count - 1; + + HasTool := True; + +end; + +procedure TMHHint.SetColor(const Index: Integer; const Value: TColor); +var + FI: TFI; +begin + if Assigned(ToolTip) then + begin + if ToolTip.Count + Byte(not HasTool) = 1 then + begin + ToolTip.SetColor(Index, Value); + Exit; + end; + FI := GetFI; + end; + + case Index of + 0: FI.FE := FI.FE + [eBkColor]; + 1: FI.FE := FI.FE + [eTextColor]; + end; + FI.Colors[Index] := Value; + + ReConnect(FI); +end; + +function TMHHint.GetColor(const Index: Integer): TColor; +begin + Result := 0; + if Assigned(ToolTip) then + Result := ToolTip.GetColor(Index); +end; + +procedure TMHHint.SetDelay(const Index, Value: Integer); +var + FI: TFI; +begin + if Assigned(ToolTip) then + begin + if ToolTip.Count + Byte(not HasTool) = 1 then + begin + ToolTip.SetDelay(Index, Value); + Exit; + end; + FI := GetFI; + end; + + case Index of + TTDT_AUTOPOP: FI.FE := FI.FE + [eAPDelay]; // Spec + TTDT_INITIAL: FI.FE := FI.FE + [eIDelay]; // Spec + TTDT_RESHOW: FI.FE := FI.FE + [eRDelay]; // Spec + end; //case + + FI.Delays[Index] := Value; //Spec + + ReConnect(FI); +end; + +procedure TMHHint.SetText(Value: KOLString); +var + TI: TToolInfo; +begin + ProcBegin(TI); + + with TI do + begin + uFlags := TTF_SUBCLASS or TTF_IDISHWND; // Spec + lpszText := PKOLChar(Value); // Spec + end; + + procEnd(TI); + + if HasTool then + begin + TI.lpszText := PKOLChar(Value); + SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); + end; + +end; + +{ TMHToolTipManager } + +function TMHToolTipManager.AddTip: Integer; +begin + SetLength(TTT, Length(TTT) + 1); + TTT[Length(TTT) - 1] := NewMHToolTip(Applet); + Result := Length(TTT) - 1; +end; + +function TMHToolTipManager.FindNeed(FI: TFI): PMHToolTip; +var + i: Integer; +begin + Result := nil; + for i := 0 to length(TTT) - 1 do + begin + if ((eTextColor in FI.FE) and (not (FI.Colors[1] = TTT[i].TextColor))) or + ((eBkColor in FI.FE) and (not (FI.Colors[0] = TTT[i].BkColor))) or + ((eAPDelay in FI.FE) and (not (FI.Delays[TTDT_AUTOPOP] = TTT[i].AutoPopDelay))) or + ((eIDelay in FI.FE) and (not (FI.Delays[TTDT_INITIAL] = TTT[i].InitialDelay))) or + ((eRDelay in FI.FE) and (not (FI.Delays[TTDT_RESHOW] = TTT[i].ReshowDelay))) then + Continue; + Result := TTT[i]; + Break; + end; +end; + +function TMHToolTipManager.CreateNeed(FI: TFI): PMHToolTip; + +begin + Setlength(TTT, length(TTT) + 1); + TTT[length(TTT) - 1] := NewMHToolTip(Applet); + with TTT[length(TTT) - 1]^ do + begin + if (eTextColor in FI.FE) then + TextColor := FI.Colors[1]; + if (eBkColor in FI.FE) then + BkColor := FI.Colors[0]; + if (eAPDelay in FI.FE) then + AutoPopDelay := FI.Delays[TTDT_AUTOPOP]; + if (eIDelay in FI.FE) then + InitialDelay := FI.Delays[TTDT_INITIAL]; + if (eRDelay in FI.FE) then + ReshowDelay := FI.Delays[TTDT_RESHOW]; + end; + Result := TTT[length(TTT) - 1]; +end; + +procedure TMHHint.ProcBegin(var TI: TToolInfo); +begin + CreateToolTip; + + with TI do + begin + cbSize := SizeOf(TI); + hWnd := Parent.GetWindowHandle; + uId := Parent.GetWindowHandle; + hInst := 0; + end; +end; + +procedure TMHHint.ProcEnd(var TI: TToolInfo); +var + TextLine: array[0..255] of KOLChar; +begin + if not HasTool then + begin + SendMessage(ToolTip.handle, TTM_ADDTOOL, 0, DWORD(@TI)); + HasTool := True; + ToolTip.Count := ToolTip.Count + 1; + end + else + begin + with TI do + begin + lpszText := @TextLine[0]; + end; + SendMessage(ToolTip.handle, TTM_SETTOOLINFO, 0, DWord(@TI)); + end; +end; + +destructor TMHToolTipManager.Destroy; +var + i: Integer; +begin + for i := 0 to Length(TTT) - 1 do + TTT[i].Free; + SetLength(TTT, 0); + inherited; +end; + +procedure TMHHint.Pop; +begin + if Assigned(ToolTip) and (HasTool) then + begin // ^^^^^^^^^^^^ ??? +// CreateToolTip; + ToolTip.Pop; + end; +end; + +procedure TMHHint.Popup; +begin + if Assigned(ToolTip) and (HasTool) then + begin // ^^^^^^^^^^^^ ??? +// CreateToolTip; + ToolTip.Popup; + end; +end; + +destructor TMHHint.Destroy; +var + TI: TToolInfo; + i: integer; +begin + with TI do + begin + cbSize := SizeOf(TI); + hWnd := Parent.GetWindowHandle; + uId := Parent.GetWindowHandle; + end; + + SendMessage(ToolTip.handle, TTM_DELTOOL, 0, DWORD(@TI)); + ToolTip.Count := ToolTip.Count - 1; + if ToolTip.Count <= 0 then begin + i:=Length(Manager.TTT); + if i > 1 then begin + Manager.TTT[i - 1].Free; + SetLength(Manager.TTT, i - 1); + end + else + Free_And_Nil(Manager); + end; + inherited; +end; + +destructor TMHToolTip.Destroy; +begin + inherited; +end; + +procedure TMHHint.CreateToolTip; +begin + if not Assigned(ToolTip) then + begin + if Length(GetManager.TTT) = 0 then + GetManager.AddTip; + ToolTip := GetManager.TTT[0]; + end; +end; + +function TMHHint.GetText: KOLString; +var + TI: TToolInfo; + TextL: array[0..255] of KOLChar; +begin + if Assigned(ToolTip) and (HasTool) then + begin + // !!! + with TI do + begin + // ???? +// FillChar(TI, SizeOf(TI), 0); + cbSize := SizeOf(TI); + hWnd := Parent.GetWindowHandle; + uId := Parent.GetWindowHandle; + lpszText := @TextL[0]; + end; + SendMessage(ToolTip.handle, TTM_GETTOOLINFO, 0, DWord(@TI)); + Result := TextL; //TI.lpszText;// := PChar(Value); + end; +end; + +function TMHHint.GetManager: PMHToolTipManager; +begin + if Manager=nil then + Manager:=NewManager; + Result:=Manager; +end; + diff --git a/plugins/Libs/KOLMHTooltip_interface.inc b/plugins/Libs/KOLMHTooltip_interface.inc new file mode 100644 index 0000000000..0e2e9d0d83 --- /dev/null +++ b/plugins/Libs/KOLMHTooltip_interface.inc @@ -0,0 +1,95 @@ +// part of KOLMHToolTip -- interface_part. +// Moved to separate inc-file still Delphi20XX does not allow compile +// in DEBUG mode. + + TFE = (eTextColor, eBkColor, eAPDelay, eRDelay, eIDelay); + + TFI = record + FE: set of TFE; + Colors: array[0..1] of TColor; + Delays: array[0..3] of Integer; + end; + + PMHToolTipManager = ^TMHToolTipManager; + TKOLMHToolTipManager = PMHToolTipManager; + + PMHToolTip = ^TMHToolTip; + TKOLMHToolTip = PMHToolTip; + + TMHToolTipManager = object(TObj) + protected + destructor Destroy; virtual; + public + TTT: array of PMHToolTip; + function AddTip: Integer; + function FindNeed(FI: TFI): PMHToolTip; + function CreateNeed(FI: TFI): PMHToolTip; + end; + + //P_MHHint = ^TMHHint; + TMHHint = object(TObj) + private + function GetManager:PMHToolTipManager; + // Spec + procedure ProcBegin(var TI: TToolInfo); + procedure ProcEnd(var TI: TToolInfo); + procedure ReConnect(FI: TFI); + procedure MoveTool(T1: PMHToolTip); + procedure CreateToolTip; + function GetFI: TFI; + + // Group + function GetDelay(const Index: Integer): Integer; + procedure SetDelay(const Index: Integer; const Value: Integer); + function GetColor(const Index: Integer): TColor; + procedure SetColor(const Index: Integer; const Value: TColor); + + // Local + procedure SetText(Value: KOLString); + function GetText: KOLString; + public + ToolTip: PMHToolTip; + HasTool: Boolean; + Parent: PControl; + destructor Destroy; virtual; + procedure Pop; + procedure Popup; + + property AutoPopDelay: Integer index 2 read GetDelay write SetDelay; + property InitialDelay: Integer index 3 read GetDelay write SetDelay; + property ReshowDelay: Integer index 1 read GetDelay write SetDelay; + + property TextColor: TColor index 1 read GetColor write SetColor; + property BkColor: TColor index 0 read GetColor write SetColor; + property Text: KOLString read GetText write SetText; + end; + + TMHToolTip = object(TObj) + private + fHandle: THandle; + Count: Integer; + function GetDelay(const Index: Integer): Integer; + procedure SetDelay(const Index: Integer; const Value: Integer); + function GetColor(const Index: Integer): TColor; + procedure SetColor(const Index: Integer; const Value: TColor); + function GetMaxWidth: Integer; + procedure SetMaxWidth(const Value: Integer); + function GetMargin: TRect; + procedure SetMargin(const Value: TRect); + function GetActivate: Boolean; + procedure SetActivate(const Value: Boolean); + public + destructor Destroy; virtual; + procedure Pop; + procedure Popup; + procedure Update; + property AutoPopDelay: Integer index 2 read GetDelay write SetDelay; + property InitialDelay: Integer index 3 read GetDelay write SetDelay; + property ReshowDelay: Integer index 1 read GetDelay write SetDelay; + property TextColor: TColor index 1 read GetColor write SetColor; + property BkColor: TColor index 0 read GetColor write SetColor; + property MaxWidth: Integer read GetMaxWidth write SetMaxWidth; + property Margin: TRect read GetMargin write SetMargin; + property Activate: Boolean read GetActivate write SetActivate; + property Handle: THandle read fHandle; + end; diff --git a/plugins/Libs/KOLMHTooltip_intf2.inc b/plugins/Libs/KOLMHTooltip_intf2.inc new file mode 100644 index 0000000000..3478eab17a --- /dev/null +++ b/plugins/Libs/KOLMHTooltip_intf2.inc @@ -0,0 +1,13 @@ +// part of KOLMHToolTip -- interface_part. +// Moved to separate inc-file still Delphi20XX does not allow compile +// in DEBUG mode. +const + Dummy = 0; + + +function NewHint(A: PControl): PMHHint; +function NewManager: PMHToolTipManager; +function NewMHToolTip(AParent: PControl): PMHToolTip; + +var + Manager: PMHToolTipManager; diff --git a/plugins/Libs/LICENSE.txt b/plugins/Libs/LICENSE.txt new file mode 100644 index 0000000000..44ce85874a --- /dev/null +++ b/plugins/Libs/LICENSE.txt @@ -0,0 +1,150 @@ +KOL&MCK Library Software License Agreement + +BEFORE PROCEEDING WITH THE INSTALLATION +AND/OR USE OF THIS SOFTWARE, CAREFULLY +READ THE FOLLOWING TERMS AND CONDITIONS +OF THIS LICENSE AGREEMENT AND LIMITED +WARRANTY (The "Agreement"). + +BY INSTALLING OR USING THIS SOFTWARE YOU +INDICATE YOUR ACCEPTANCE OF THIS +AGREEMENT. IF YOU DO NOT ACCEPT OR AGREE +WITH THESE TERMS, YOU MAY NOT INSTALL OR +USE THIS SOFTWARE! + +PREAMBLE + +The terms and conditions of the KOL&MCK +Library Software License Agreement have +one major goal in mind; to foster a development +community based around the KOL (Key Objects +Library) and MCK (Mirror Classes Kit for KOL) +and associated source code. +KOL&MCK Library does however reserve the +right as the sole distributor of the library +source code. Hence although I encourage +you to change and modify the library to +suit your needs, you may not distribute +derivative works based on the library +source code without express written +permission from KOL&MCK Library author. +Worthwhile changes and modifications to +the libraries may be submitted to KOL&MCK +Library author for integration into a +future release of the product. + +LICENSE + +This software, including documentation, +source code, object code and/or additional +materials (the "Software") is owned by +KOL&MCK author. +This Agreement does not provide you with +title or ownership of Product, but only a +right of limited use as outlined in this +license agreement. KOL&MCK Library author +hereby grant you a non-exclusive, +royalty free license to use the Software +as set forth below: + + . integrate the Software with your + Applications or DLLs, subject to the + redistribution terms below. + . modify or adapt the Software in whole + or in part for the development of + Applications based on the Software. + . use portions of the KOL&MCK Library + source code or KOL&MCK Library Demo + Programs in your own products and + libraries. + +REDISTRIBUTION RIGHTS + +You are granted a non-exclusive, +royalty-free right to reproduce and +redistribute executable files created +using the Software (the "Executable Code") +in conjunction with software products that +you develop and/or market (the +"Applications"). + +RESTRICTIONS + +Without the expressed, written consent of +KOL&MCK Library author, you may NOT: + + . distribute modified versions of the + Software, in whole or in part without + providing an information about it for + your customers (such information + must refer to any Copyright and legal + notes on portions of Software distributed, + version information on Software used + to redistribute, notes on changes + made, if any, and must include any + necessary information to provide a chance + for your customers to find and re-use + the original Software if they want to + do so). + . rent or lease the Software. + . sell any portion of the Software on + its own, without integrating it into + your Applications or DLLs as Executable + Code. + +SELECTION AND USE + +You assume full responsibility for the +selection of the Software to achieve your +intended results and for the installation, +use and results obtained from the Software. + +LIMITED WARRANTY + +THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT +WARRANTY OF ANY KIND EITHER EXPRESSED OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE +IMPLIED WARRANTIES MERCHANTIBILITY AND +FITNESS FOR A PARTICULAR PURPOSE. THE +ENTIRE RISK AS TO THE QUALITY AND +PERFORMANCE OF THE PRODUCT IS WITH YOU. +SHOULD THE PRODUCT PROVE DEFECTIVE, YOU +ASSUME THE COST OF ALL NECESSARY SERVICING +OR ERROR CORRECTION. + +KOL&MCK LIBRARY AUTHOR DO NOT WARRANT THAT +THE FUNCTIONS CONTAINED IN THE SOFTWARE +WILL MEET YOUR REQUIREMENTS OR THAT THE +OPERATION OF THE SOFTWARE WILL BE +UNINTERRUPTED OR ERROR FREE. + +No oral or written information given by +KOL&MCK Library shall create a warranty. + +LIMITATION OF REMEDIES AND LIABILITY. + +IN NO EVENT SHALL KOL&MCK LIBRARY AUTHOR, OR +ANY OTHER PARTY WHO MAY HAVE DISTRIBUTED +THE SOFTWARE AS PERMITTED ABOVE, BE LIABLE +FOR DAMAGES, INCLUDING ANY GENERAL, +SPECIAL, INCIDENTAL, OR CONSEQUENTIAL +DAMAGES ARISING OUT OF THE USE OR +INABILITY TO USE THE SOFTWARE (INCLUDING +BUT NOT LIMITED TO LOSS OF DATA OR DATA +BEING RENDERED INACCURATE OR LOSSES +SUSTAINED BY YOU OR THIRD PARTIES OR +FAILURE OF THE SOFTWARE TO OPERATE WITH +ANY OTHER PRODUCTS), EVEN IF SUCH HOLDER +OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + +If you have any questions regarding this +agreement, please contact KOL&MCK Library +author at his e-mail addresses: + + vk@kolmck.net + bonanzas@online.sinor.ru + +KOL&MCK Library Web Site: + http://www.kolmck.net + diff --git a/plugins/Libs/Mmx.pas b/plugins/Libs/Mmx.pas new file mode 100644 index 0000000000..cb9ee7c8b7 --- /dev/null +++ b/plugins/Libs/Mmx.pas @@ -0,0 +1,361 @@ +unit Mmx; +{* MMX support unit. By Vladimir Kladov, 2003. } + +interface + +{$I KOLDEF.INC} + +uses + Windows, Kol; + +type + TCpuId = ( cpuNew486, cpuMMX, cpuMMX_Plus, cpu3DNow, cpu3DNow_Plus, + cpuSSE, cpuSSE2 ); + {* Enumeration type to represent CPU type. + cpuOld486: Old 486 Processor and earlier + cpuNew486: New 486 Processor to Pentium1 without MMX + cpuMMX : MMX supported (but not SSE or SSE2) + cpuSSE : MMX and SSE supported (but not SSE2) + cpuSSE2 : MMX, SSE and SSE2 supported + } + + TCpuCaps = set of TCpuId; + +function GetCPUType: TCpuCaps; +{* Checks CPU (Intel PC x86 Architecture) for MMX support. +|

+ +Use following constants in shuffle commands (like "pshufw") as third operand +to instruct to which locations (0,1,2,3) source parts should be placed: } +const + SH0000 = $00; + SH0001 = $01; + SH0002 = $02; + SH0003 = $03; + SH0010 = $04; + SH0011 = $05; + SH0012 = $06; + SH0013 = $07; + SH0020 = $08; + SH0021 = $09; + SH0022 = $0A; + SH0023 = $0B; + SH0030 = $0C; + SH0031 = $0D; + SH0032 = $0E; + SH0033 = $0F; + SH0100 = $10; + SH0101 = $11; + SH0102 = $12; + SH0103 = $13; + SH0110 = $14; + SH0111 = $15; + SH0112 = $16; + SH0113 = $17; + SH0120 = $18; + SH0121 = $19; + SH0122 = $1A; + SH0123 = $1B; + SH0130 = $1C; + SH0131 = $1D; + SH0132 = $1E; + SH0133 = $1F; + SH0200 = $20; + SH0201 = $21; + SH0202 = $22; + SH0203 = $23; + SH0210 = $24; + SH0211 = $25; + SH0212 = $26; + SH0213 = $27; + SH0220 = $28; + SH0221 = $29; + SH0222 = $2A; + SH0223 = $2B; + SH0230 = $2C; + SH0231 = $2D; + SH0232 = $2E; + SH0233 = $2F; + SH0300 = $30; + SH0301 = $31; + SH0302 = $32; + SH0303 = $33; + SH0310 = $34; + SH0311 = $35; + SH0312 = $36; + SH0313 = $37; + SH0320 = $38; + SH0321 = $39; + SH0322 = $3A; + SH0323 = $3B; + SH0330 = $3C; + SH0331 = $3D; + SH0332 = $3E; + SH0333 = $3F; + SH1000 = $40; + SH1001 = $41; + SH1002 = $42; + SH1003 = $43; + SH1010 = $44; + SH1011 = $45; + SH1012 = $46; + SH1013 = $47; + SH1020 = $48; + SH1021 = $49; + SH1022 = $4A; + SH1023 = $4B; + SH1030 = $4C; + SH1031 = $4D; + SH1032 = $4E; + SH1033 = $4F; + SH1100 = $50; + SH1101 = $51; + SH1102 = $52; + SH1103 = $53; + SH1110 = $54; + SH1111 = $55; + SH1112 = $56; + SH1113 = $57; + SH1120 = $58; + SH1121 = $59; + SH1122 = $5A; + SH1123 = $5B; + SH1130 = $5C; + SH1131 = $5D; + SH1132 = $5E; + SH1133 = $5F; + SH1200 = $60; + SH1201 = $61; + SH1202 = $62; + SH1203 = $63; + SH1210 = $64; + SH1211 = $65; + SH1212 = $66; + SH1213 = $67; + SH1220 = $68; + SH1221 = $69; + SH1222 = $6A; + SH1223 = $6B; + SH1230 = $6C; + SH1231 = $6D; + SH1232 = $6E; + SH1233 = $6F; + SH1300 = $70; + SH1301 = $71; + SH1302 = $72; + SH1303 = $73; + SH1310 = $74; + SH1311 = $75; + SH1312 = $76; + SH1313 = $77; + SH1320 = $78; + SH1321 = $79; + SH1322 = $7A; + SH1323 = $7B; + SH1330 = $7C; + SH1331 = $7D; + SH1332 = $7E; + SH1333 = $7F; + SH2000 = $80; + SH2001 = $81; + SH2002 = $82; + SH2003 = $83; + SH2010 = $84; + SH2011 = $85; + SH2012 = $86; + SH2013 = $87; + SH2020 = $88; + SH2021 = $89; + SH2022 = $8A; + SH2023 = $8B; + SH2030 = $8C; + SH2031 = $8D; + SH2032 = $8E; + SH2033 = $8F; + SH2100 = $90; + SH2101 = $91; + SH2102 = $92; + SH2103 = $93; + SH2110 = $94; + SH2111 = $95; + SH2112 = $96; + SH2113 = $97; + SH2120 = $98; + SH2121 = $99; + SH2122 = $9A; + SH2123 = $9B; + SH2130 = $9C; + SH2131 = $9D; + SH2132 = $9E; + SH2133 = $9F; + SH2200 = $A0; + SH2201 = $A1; + SH2202 = $A2; + SH2203 = $A3; + SH2210 = $A4; + SH2211 = $A5; + SH2212 = $A6; + SH2213 = $A7; + SH2220 = $A8; + SH2221 = $A9; + SH2222 = $AA; + SH2223 = $AB; + SH2230 = $AC; + SH2231 = $AD; + SH2232 = $AE; + SH2233 = $AF; + SH2300 = $B0; + SH2301 = $B1; + SH2302 = $B2; + SH2303 = $B3; + SH2310 = $B4; + SH2311 = $B5; + SH2312 = $B6; + SH2313 = $B7; + SH2320 = $B8; + SH2321 = $B9; + SH2322 = $BA; + SH2323 = $BB; + SH2330 = $BC; + SH2331 = $BD; + SH2332 = $BE; + SH2333 = $BF; + SH3000 = $C0; + SH3001 = $C1; + SH3002 = $C2; + SH3003 = $C3; + SH3010 = $C4; + SH3011 = $C5; + SH3012 = $C6; + SH3013 = $C7; + SH3020 = $C8; + SH3021 = $C9; + SH3022 = $CA; + SH3023 = $CB; + SH3030 = $CC; + SH3031 = $CD; + SH3032 = $CE; + SH3033 = $CF; + SH3100 = $D0; + SH3101 = $D1; + SH3102 = $D2; + SH3103 = $D3; + SH3110 = $D4; + SH3111 = $D5; + SH3112 = $D6; + SH3113 = $D7; + SH3120 = $D8; + SH3121 = $D9; + SH3122 = $DA; + SH3123 = $DB; + SH3130 = $DC; + SH3131 = $DD; + SH3132 = $DE; + SH3133 = $DF; + SH3200 = $E0; + SH3201 = $E1; + SH3202 = $E2; + SH3203 = $E3; + SH3210 = $E4; + SH3211 = $E5; + SH3212 = $E6; + SH3213 = $E7; + SH3220 = $E8; + SH3221 = $E9; + SH3222 = $EA; + SH3223 = $EB; + SH3230 = $EC; + SH3231 = $ED; + SH3232 = $EE; + SH3233 = $EF; + SH3300 = $F0; + SH3301 = $F1; + SH3302 = $F2; + SH3303 = $F3; + SH3310 = $F4; + SH3311 = $F5; + SH3312 = $F6; + SH3313 = $F7; + SH3320 = $F8; + SH3321 = $F9; + SH3322 = $FA; + SH3323 = $FB; + SH3330 = $FC; + SH3331 = $FD; + SH3332 = $FE; + SH3333 = $FF; + +implementation + +var cpu: TCpuCaps = [ ]; + +function GetCPUType: TCpuCaps; +var I, J: Integer; + Vend1: array[ 0..3 ] of Char; +begin + Result := cpu; // old 486 and earlier + if Result <> [] then Exit; + I := 0; + asm // check if bit 21 of EFLAGS can be set and reset + PUSHFD + POP EAX + OR EAX, 1 shl 21 + PUSH EAX + POPFD + PUSHFD + POP EAX + TEST EAX, 1 shl 21 + JZ @@1 + AND EAX, not( 1 shl 21 ) + PUSH EAX + POPFD + PUSHFD + POP EAX + TEST EAX, 1 shl 21 + JNZ @@1 + INC [ I ] + @@1: + end; + if I = 0 then Exit; // CPUID not supported + Include( Result, cpuNew486 ); // at least cpuNew486 + asm // get CPU features flags using CPUID command + PUSH EBX + MOV EAX, 0 + DB $0F, $A2 //CPUID : EAX, EBX, EDX and ECX are changed!!! + MOV [ Vend1 ], EBX + + MOV EAX, 1 + DB $0F, $A2 //CPUID : EAX, EBX, EDX and ECX are changed!!! + MOV [ I ], EDX // I := features information + POP EBX + end; + if (I and (1 shl 23)) = 0 then Exit; // MMX not supported at all + Include( Result, cpuMMX ); // MMX supported. + if Vend1 = 'Auth' then // AuthenticAMD ? + begin + asm + PUSH EBX + MOV EAX, $80000001 + DB $0F, $A2 //CPUID : EAX, EBX, EDX and ECX are changed!!! + MOV [ J ], EDX + POP EBX + end; + if (J and (1 shl 22)) <> 0 then + Include( Result, cpuMMX_Plus ); // MMX+ supported. + if (J and (1 shl 31)) <> 0 then + begin + Include( Result, cpu3DNow ); // 3DNow! supported. + if (J and (1 shl 30)) <> 0 then + Include( Result, cpu3DNow_Plus );// 3DNow!+ supported. + end; + end; + if (I and (1 shl 25)) <> 0 then + begin + Include( Result, cpuSSE ); // SSE supported. + if (I and (1 shl 26)) <> 0 then + Include( Result, cpuSSE2 ); // SSE2 supported. + end; + cpu := Result; +end; + +end. diff --git a/plugins/Libs/delphidef.inc b/plugins/Libs/delphidef.inc new file mode 100644 index 0000000000..a6a6e51c93 --- /dev/null +++ b/plugins/Libs/delphidef.inc @@ -0,0 +1,48 @@ +//{$DEFINE _FPC} +{$DEFINE ASM_VERSION} // Comment this line to produce Pascal code. + // Or, just add PAS_VERSION to conditionals + // of your project (must be rebuilt). + +{$IFDEF ASM_VERSION} + {$IFDEF PAS_VERSION} + {$UNDEF ASM_VERSION} + // To compile a project with ASM_VERSION option turned off, + // define a symbol PAS_VERSION in project options. + {$ENDIF} +{$ENDIF} + +{$I KOLDEF.INC} + +//{$DEFINE USE_CONSTRUCTORS} +// Comment this line to produce smaller code if constructors are not used. +// When uncommented, this definition allows to create descendant controls +// and objects overriding constructors, which are actually members of objects. +// Otherwise, global functions (usually named New) are used to +// create and initialize object instances. This gives smaller code, but +// prevents from using OOP inheritance. +// Note: creating descendant objects derived from TObj does not require using +// of this option. It is actually needed only for deriving new controls on +// base of TControl. See also option USE_CUSTOMEXTENSIONS below. + +//{$DEFINE USE_CUSTOMEXTENSIONS} +// Uncomment this option or add it to your project conditional defines, +// if You wish to extend existing TControl object from +// the inner of those. When this option is turned on, include directive at the +// tail of TControl declaration is enabled, causing a compiler to include your +// portion of source directly into the TControl body. See comments near this +// directive there. (Search the word: USE_CUSTOMEXTENSIONS). +// Please note, that this option is not fully supported now. + +{$IFNDEF NOT_UNLOAD_RICHEDITLIB} + {$DEFINE UNLOAD_RICHEDITLIB} +{$ENDIF} +// You can freely comment this directive. 1st, if the application does not +// use richedit control. 2nd, even if it does, freeing the library handle +// actually is not needed. +// Another way to turn this option off is to define symbol NOT_UNLOAD_RICHEDITLIB +// in your project options. + +//{$DEFINE TEST_VERSION} +{$IFNDEF _D6orHigher} + {$DEFINE PARANOIA} //seems not needed under D6 !!! Inprise fixed this, finally... +{$ENDIF} \ No newline at end of file diff --git a/plugins/Libs/read1st.txt b/plugins/Libs/read1st.txt new file mode 100644 index 0000000000..3657c8d07d --- /dev/null +++ b/plugins/Libs/read1st.txt @@ -0,0 +1,63 @@ +KEY OBJECTS LIBRARY for Delphi (and Free Pascal Compiler) - to make applications small and power. This library is freeware and open source. Delphi 2, 3, 4, 5, 6, 7, 8, BDS 2005, 2006, 2010, TurboDelphi, Delphi XE, Delphi XE2 and Free Pascal Compiler 1.0.5, 1.0.6, and higher (2.0.4) are supported. Partially compatible with Kylix (Linux/Qt platform, use special converting tool and provided files in Tools section on the site http://bonanzas.rinet.ru) + +Copyright (C) by Vladimir Kladov, 1999-2010. +Some parts of code are Copyright (C) intellectual property by other people, see comments in code and on KOL site. Thanks to all for help with KOL and MCK! + +v. 3.18 (23-Apr-2012) + +To get newer version, go to Web-page http://www.kolmck.net and get there updates. + +__________________ +BRIEF DESCRIPTION: +    KOL - Key Objects Library is a set of objects to develop applications using Delphi. It is distributed free of charge, with source code. +   KOL allows to create very compact GUI applications (starting from ~14,0K without compression - if suggested system units replacement used). The majority of the code is converted to assembly. +   A Help generating tool, xHelpGen is provided for KOL, which creates detailed documentation in html format. Documentation is generated on from the source code comments, so developers instantly  have access to the most fresh and complete documentation. +   With advent of the MCK (Mirror Classes Kit) package, all advantages of visual programming are available for developers who use KOL. Additionally with MCK it is possible to make large enough projects smaller converting part of machine code to a byte code of Forth-like virtual (emulated at run time) machint (see more detailed: Collapse). + A lot of additions are available for KOL, which allow to work with data bases, Active-X components, print reports, different image and compression formats, etc. +-------------------------------------------- + +This archive contains Key Objects Library main part: KOL.PAS and several test samples. At the KOL Web page (http://bonanzas.rinet.ru), you can download also additional components: + +MCK - Mirror Classes Kit - visual programming environment for KOL +xHelpGen - utility to generate html-documentation from comments within the source code; +KolErr (~25K) - "light" (for 6K), but functional exception handling unit +KOLEdb, KOLODBC, StrDb (by Mike Talcott), TdkDbKol (by Thaddy de Koning) - DB-extensions for KOL +KolGif (~20K) - GIF (animated, transparent) support for KOL +KolJpegObj (~127K + 340K) - JPEG support for KOL +KolOGL12 (~59K) - OpenGL support for KOL +KOLword (~12K) - MS Word automation +Service (~20K) - writing NT services with KOL +KOLSocket (~30K) - sockets for KOL (by Alexander Shakhaylo) +TestKOLRas (~20K) - RAS dial-up for KOL (by Alexander Shakhaylo) +sysdcu (~200K) - system.dcu, sysinit.dcu replacement for Delphi5 (it provides a savings of 9KBytes from the .exe's file size) +sysdcuD6 (~200K) - system.dcu, ... replacement for Delphi6 +HeapMM (~1K) - alteranative memory manager +MapMem +Widgets +ZLib +... and many others, this list is constantly extended with new items. + + +_____________ +INSTALLATION: + +1. When You install KOL the first time, create a new directory for KOL (e.g., E:\KOL). + +2. Unpack all files from KOL.ZIP there. (If upgrading, confirm overwriting of old files with new ones). + +3. If You downloaded xhelpgen.zip package, also unpack it into the same directory. Read also docs for xHelpGen from the package. + +4. If You downloaded SYSDCU.ZIP, create subdirectory for it (e.g. E:\KOL\SYS) and unpack it there. Read also docs for system units replacement in the package. + +5. To learn how to install the MCK (Mirror Classes Kit) see instructions in the MCK archive. + +6. To learn how to install KOLEdb, see instructions in KOLEDB.ZIP archive. + +7. For more information on the use and or installation of any of the packages packages and programs found on KOL site: look for help within it's package. + +Note: KOL itself does not require creating a package since it has no design-time components to install it onto Component Palette. See MCK, which has such components and allows visual programming using KOL. +-------------------------------------------------- + +Web address: http://kolmck.net +vk@kolmck.net +Vladimir Kladov \ No newline at end of file diff --git a/plugins/Libs/read1st_rus.txt b/plugins/Libs/read1st_rus.txt new file mode 100644 index 0000000000..60219b29fc --- /dev/null +++ b/plugins/Libs/read1st_rus.txt @@ -0,0 +1,61 @@ +KEY OBJECTS LIBRARY для Delphi (и Free Pascal Compiler) - предназначен для того, чтобы сделать программы, изготовленные с использованием языка Паскаль, маленькими и очень маленькими. +Copyright (C) by Vladimir Kladov, 1999-2007. Бесплатно, с исходными текстами. + +версия 3.18 (23 апреля 2012 г.) + +_________________ +КРАТКОЕ ОПИСАНИЕ: +   KOL - Key Objects Library - это библиотека объектов для программирования в среде Delphi. +   Поддерживаются версии Delphi2, Delph3, Delphi4, Delphi5, Delphi6, Delphi7, Delphi8, BDS2005, BDS2006, BDS2010, Turbo-Delphi, Delphi XE, Delphi XE2, а так же Free Pascal v1.0.5, v2.0.4 и выше. Имеется так же частичная совместимость с Kylix (требуется конвертер и набор файлов, см. в разделе "Инструменты разработчика" на сайте http://bonanzas.rinet.ru). Ведется работа над портированием на другие платформы (Linux, Win CE). + Библиотека KOL позволяет разрабатывать чрезвычайно компактные GUI-приложения (от 11К без сжатия - при условии использования предлагаемой замены системных модулей system, sysinit, см. на сайте раздел "Архивы"). Большая часть кода переведана на ассемблер. +   К библиотеке прилагается программа - генератор справки (xHelpGen), формирующая подробную документацию по библиотеке в html-формате. Справка формируется на основе комментариев в исходных текстах, так что разработчики всегда имеют доступ к самой свежей и полной документации. +   С использованием MCK (Mirror Classes Kit - набор зеркальных классов) все прелести визуальной разработки программ в полной мере доступны и для разработчиков, использующих KOL. Дополнительно с MCK имеется возможность еще более уменьшать приложения, автоматически генерируя П-код виртуальной машины вместо Паскаль-кода для инициализации форм (см. подроблее: Collapse). +---------------------------------- + +Данный архив содержит самодостаточную часть библиотеки Key Objects Library: файл KOL.PAS. На странице (http://www.kolmck.net) возможно также загрузить дополнительные расширения, в том числе: + +MCK - Mirror Classes Kit - полноценная визуальная среда для KOL +xHelpGen (~50K) - генератор html-справки на основе комментариев в исходном коде +KolErr (~20K) - "облегченная" (на 6К), но вполне фунциональная обработка исключений +KOLEdb, KOLODBC, StrDb, TdkDbKol - расширения для работы с БД +KOLWord (~12K) - MS Word automation +KolGif (~20K) - поддержка анимированных gif-файлов +KolJpegObj (~127K) - поддержка JPEG +KolOgl12 (~59K) - поддержка OpenGL +Service (~30K) - написание NT сервисов в KOL +KOLSocket (~30K) - сокеты +sysdcu (~200K) - замена system.dcu, sysinit.dcu для Delphi5 (экономия еще 9К в .exe) +HeapMM (~1K) - альтернативный менеджер памяти + +... +И так далее, список пополняется постоянно. + +__________________________________________________ +УСТАНОВКА И ПЕРЕУСТАНОВКА (УСТАНОВКА НОВОЙ ВЕРСИИ): + +1. При первой установке создать новую директорию (например, E:\KOL). + +2. Распаковать файлы из KOL.ZIP туда же. (При переустановке подтвердить замещение старых файлов новыми). + +4. Если Вы загрузили архив xhelpgen.zip, так же распаковывайте его в ту же директорию. Не забудьте прочитать прилагаемую к нему инструкцию. + +5. Если Вы загрузили архив SYSDCU.ZIP, создайте поддиректорию для него (например, E:\KOL\SYS) и распакуйте туда его содержимое. К нему так же прилагается своя инструкция. + +6. Инструкции по установке MCK (Mirror Classes Kit) см. в архиве MCK.ZIP. + +7. Аналогично для koledb, kolword и других дополнений. + +Примечание: для самого KOL не требуется создавать Package, т.к. KOL не имеет компонент времени разработки, требующих установки на палтру компонентов. См. пакет MCK, которое имеет такие компоненты, и позволяет разрабатывать приложения с использованием KOL, визуально. +------------------------------------------------------------- + +ЛИЦЕНЗИРОВАНИЕ. + +Данный параграф введен здесь, чтобы не переводить на русский язык лицензию, см. файл LICENSE.txt. + +На использование библиотеки в качестве инструмента для разработки исполнимых модулей (exe, dll и т.д.) не накладывается никаких ограничений. Нельзя продавать библиотеку полностью или частично. Нельзя распространять ее бесплатно, полностью или частично, без согласия автора и без ссылок на автора. В случае, если распространяется модифицированная библиотека, пользователи обязаны быть информированы о первоисточнике и о том, кто является автором оригинальной библиотеки, и как с ним связаться. + +------------------------------------------------------------- + +http://kolmck.net +vk@kolmck.net +Владимир Кладов \ No newline at end of file -- cgit v1.2.3