diff options
| -rw-r--r-- | plugins/ImportTXT/kol/KOLDEF.INC | 303 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/KOL_ASM.inc | 15855 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/KOL_ASM_NOUNICODE.inc | 4351 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/KOL_ansi.inc | 2316 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/KOL_unicode.inc | 1277 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/MCKfakeClasses.inc | 79 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/MCKfakeClasses200x.inc | 51 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/MsgDecode.pas | 4957 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/delphicommctrl.inc | 1594 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/err.pas | 1197 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/kol.pas | 61852 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/kolmath.pas | 1845 | ||||
| -rw-r--r-- | plugins/ImportTXT/kol/visual_xp_styles.inc | 1448 | ||||
| -rw-r--r-- | plugins/ImportTXT/make.bat | 31 | ||||
| -rw-r--r-- | plugins/Libs/CplxMath.pas (renamed from plugins/ImportTXT/kol/CplxMath.pas) | 0 | ||||
| -rw-r--r-- | plugins/Libs/KOLEdb.pas (renamed from plugins/ImportTXT/kol/KOLEdb.pas) | 0 | ||||
| -rw-r--r-- | plugins/Libs/KOLMHTooltip_implem.inc (renamed from plugins/ImportTXT/kol/KOLMHTooltip_implem.inc) | 0 | ||||
| -rw-r--r-- | plugins/Libs/KOLMHTooltip_interface.inc (renamed from plugins/ImportTXT/kol/KOLMHTooltip_interface.inc) | 0 | ||||
| -rw-r--r-- | plugins/Libs/KOLMHTooltip_intf2.inc (renamed from plugins/ImportTXT/kol/KOLMHTooltip_intf2.inc) | 0 | ||||
| -rw-r--r-- | plugins/Libs/LICENSE.txt (renamed from plugins/ImportTXT/kol/LICENSE.txt) | 0 | ||||
| -rw-r--r-- | plugins/Libs/Mmx.pas (renamed from plugins/ImportTXT/kol/Mmx.pas) | 0 | ||||
| -rw-r--r-- | plugins/Libs/delphidef.inc (renamed from plugins/ImportTXT/kol/delphidef.inc) | 0 | ||||
| -rw-r--r-- | plugins/Libs/read1st.txt (renamed from plugins/ImportTXT/kol/read1st.txt) | 0 | ||||
| -rw-r--r-- | plugins/Libs/read1st_rus.txt (renamed from plugins/ImportTXT/kol/read1st_rus.txt) | 0 |
24 files changed, 20 insertions, 97136 deletions
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<ObjectName>) 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/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/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/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/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).
- |<br><br>
- 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 = '<unknown>';
- //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:
-|<br>
- - to create objects dynamically, use P<objname> instead of
- T<objname> to allocate a pointer for dynamically created
- object instance;
-|<br>
- - remember, that constructors of objects can not be virtual.
- Override procedure Init instead in your own derived objects;
-|<br>
- - rather then call constructors of objects, call global procedures
- New<objname> (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.
-|<br>
- - 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".
-|<br>
-|<hr>
- 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; ]
-|<hr>
-|&U= <a href="#%0">%0</a><br>
-|&B=<a href="%1.htm">%0</a><br>
-|&C=<a href="%1.htm">%0</a>
-| <table border=1 cellpadding=6 width=100%>
-| <colgroup valign=top span=2>
-| <tr>
-| <td> objects </td> <td> functions by category </td>
-| </tr>
-| <td>
- <C _TObj> <B TObj>
- <C TList> <C TListEx> <C TStrList> <B TStrListEx>
- <C TTree> <C TDirList> <C TIniFile> <C TCabFile>
- <B TStream>
- <B TControl>
- <C TGraphicTool> <C TCanvas> <C TImageList> <C TIcon> <C TBitmap>
- <C TGif> <C TGifDecoder> <B TJpeg>
- <C TTimer> <C TThread> <C TTrayIcon> <C TDirChange> <B TMediaPlayer>
- <C TMenu> <C TOpenSaveDialog> <C TOpenDirDialog> <B TColorDialog>
- <C TAction> <B TActionList>
- <B Exception>
-| </td>
-| <td>
-|<a href="kol_pas.htm#visual_objects_constructors">
- Visual objects constructing functions
-|</a><br><br>
- <U Working with null-terminated and ansi strings>
- <U Small bit arrays (max 32 bits in array)>
- <U Arithmetics, geometry and other utility functions>
- <U Data sorting (quicksort implementation)>
- <U String to number and number to string conversions>
- <U 64-bit integer numbers>
- <U Floating point numbers>
- <U Date and time handling>
- <U File and directory routines>
- <U System functions and working with windows>
- <U Text in clipboard operations>
- <U Wrappers to registry API functions>
-| </td>
-| </table>
-
- Following conditional symbols can be used in a project
- (Project | Options | Directories/Conditional Defines)
- to change code generated a bit. There are following:
-|<pre>
-
- 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).
- |</pre>
-}
-{= 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".
- |<br>
- 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.
- |<br>
- 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).
- |<br>
- 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 áûë
- âûçâàí".
- |<br>
- Èñïîëüçóéòå RefInc..RefDec äëÿ ïðåäîòâðàùåíèÿ ðàçðóøåíèÿ îáúåêòà íà
- íåêîòîðîì ó÷àñòêå êîäà (åñëè åñòü òàêàÿ íåîáõîäèìîñòü).
- |<br>
- Åñëè íóæíî óáèòü (âðåìåííûé) îáúåêò âìåñòå ñ ïîñëåäíèì 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<objectname> 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.
- |<br><br>
- Aknowledgements. Originally class ZThread was developed for XCL:
- |<br> * By: Tim Slusher : junior@nlcomm.com
- |<br> * 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.
- |<br>
- 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:
- |<pre>
-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
- |</pre>
- |<br>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 e1<e2 and e2>e2), 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.
- |<br>
- 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<br>
- | cmDstInvert<br>
- | cmMergeCopy<br>
- | cmMergePaint<br>
- | cmNotSrcCopy<br>
- | cmNotSrcErase<br>
- | cmPatCopy<br>
- | cmPatInvert<br>
- | cmPatPaint<br>
- | cmSrcAnd<br>
- | cmSrcCopy<br>
- | cmSrcErase<br>
- | cmSrcInvert<br>
- | cmSrcPaint<br>
- | cmWhiteness<br>
- 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:
- |<pre>
- 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
- |</pre> }
- 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:
- |<pre>
- 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.
- |</pre> 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:
- |<br> <font face="Courier"><b>
- | Method.Code := @MyProcedure;
- |</b></font> }
- 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.:
- |<br> <font face="Courier"><b>
- | SomeObject.OnSomeEvent := TOnSomeEvent( Method );
- |</b></font><br> }
-///////////////////////////////////////////
-{$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
- |<a href="kol_pas.htm#visual_objects_constructors">
- constructing functions
- |</a>
- 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.
- |<br>odsSelected - The menu item's status is selected.
- |<br>odsGrayed - The item is to be grayed. This bit is used only in a menu.
- |<br>odsDisabled - The item is to be drawn as disabled.
- |<br>odsChecked - The menu item is to be checked. This bit is used only in
- a menu.
- |<br>odsFocused - The item has the keyboard focus.
- |<br>odsDefault - The item is the default item.
- |<br>odsHotList - <b>Windows 98, Windows 2000:</b> The item is being
- hot-tracked, that is, the item will be highlighted when
- the mouse is on the item.
- |<br>odsInactive - <b>Windows 98, Windows 2000:</b> The item is inactive
- and the window associated with the menu is inactive.
- |<br>odsNoAccel - <b>Windows 2000:</b> The control is drawn without the
- keyboard accelerator cues.
- |<br>odsNoFocusRect - <b>Windows 2000:</b> The control is drawn without
- focus indicator cues.
- |<br>odsComboboxEdit - The drawing takes place in the selection field
- (edit control) of an owner-drawn combo box.
- |<br>odsMarked - for Common controls only. The item is marked. The meaning
- of this is up to the implementation.
- |<br>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.
- |<br> 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.
- |<pre>
- 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
- |</pre> }
- 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).
- |<pre>
- 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).
- |</pre> }
- TRichNumBrackets = ( rnbRight, rnbBoth, rnbPeriod, rnbPlain, rnbNoNumber );
- {* Brackets around number:
- |<pre>
- rnbRight - 1) 2) 3) - this is default !
- rnbBoth - (1) (2) (3)
- rnbPeriod - 1. 2. 3.
- rnbPlain - 1 2 3
- |</pre> }
- 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.
- |<br> <b> 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
- |<a href="kol_pas.htm#visual_objects_constructors">
- |constructing functions definitions</a></b>. }
- 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.
- |<br>
- 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.
- |<br>
- 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).
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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:
- |<table border=0>
- |&L=<tr><td valign=top><font face=Fixedsys>%1</font></td><td>
- |&E=</td></tr>
- |&N=<br>
- <L CS_BYTEALIGNCLIENT> - Aligns the window's client area on the byte boundary
- (in the x direction) to enhance performance during
- drawing operations. <E>
- <L CS_BYTEALIGNWINDOW> - Aligns a window on a byte boundary (in the x
- direction). <E>
- <L CS_CLASSDC> - Allocates one device context to be shared by all
- windows in the class. <E>
- <L CS_DBLCLKS> - 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. <E>
- <L CS_GLOBALCLASS> - Allows an application to create a window of
- the class regardless of the value of the hInstance parameter.
- <N> 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. <E>
- <L CS_HREDRAW> - Redraws the entire window if a movement or
- size adjustment changes the width of the client area. <E>
- <L CS_NOCLOSE> - Disables the Close command on the System menu. <E>
- <L CS_OWNDC> - Allocates a unique device context for each window
- in the class. <E>
- <L CS_PARENTDC> - Sets the clipping region of the child window to
- that of the parent window so that the child can draw on the parent. <E>
- <L CS_SAVEBITS> - 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. <E>
- <L CS_VREDRAW> - Redraws the entire window if a movement or size
- adjustment changes the height of the client area. <E>
- |</table> 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:
- |<table border=0>
- <L WS_BORDER> Creates a window that has a thin-line border. <E>
- <L WS_CAPTION> Creates a window that has a title bar (includes the
- WS_BORDER style). <E>
- <L WS_CHILD> Creates a child window. This style cannot be used with
- the WS_POPUP style. <E>
- <L WS_CHILDWINDOW> Same as the WS_CHILD style. <E>
- <L WS_CLIPCHILDREN> Excludes the area occupied by child windows
- when drawing occurs within the parent window. This style is used
- when creating the parent window. <E>
- <L WS_CLIPSIBLINGS> 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. <E>
- <L WS_DISABLED> Creates a window that is initially disabled. A
- disabled window cannot receive input from the user. <E>
- <L WS_DLGFRAME> 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. <E>
- <L WS_GROUP> 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. <E>
- <L WS_HSCROLL> Creates a window that has a horizontal scroll bar. <E>
- <L WS_ICONIC> Creates a window that is initially minimized. Same as
- the WS_MINIMIZE style. <E>
- <L WS_MAXIMIZE> Creates a window that is initially maximized. <E>
- <L WS_MAXIMIZEBOX> 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. <E>
- <L WS_MINIMIZE> Creates a window that is initially minimized.
- Same as the WS_ICONIC style. <E>
- <L WS_MINIMIZEBOX> 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. <E>
- <L WS_OVERLAPPED> Creates an overlapped window. An overlapped
- window has a title bar and a border. Same as the WS_TILED style. <E>
- <L WS_OVERLAPPEDWINDOW> 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. <E>
- <L WS_POPUP> Creates a pop-up window. This style cannot be used with
- the WS_CHILD style. <E>
- <L WS_POPUPWINDOW> 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. <E>
- <L WS_SIZEBOX> Creates a window that has a sizing border. Same as the
- WS_THICKFRAME style. <E>
- <L WS_SYSMENU> Creates a window that has a window-menu on its title
- bar. The WS_CAPTION style must also be specified. <E>
- <L WS_TABSTOP> 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. <E>
- <L WS_THICKFRAME> Creates a window that has a sizing border.
- Same as the WS_SIZEBOX style. <E>
- <L WS_TILED> Creates an overlapped window. An overlapped window has
- a title bar and a border. Same as the WS_OVERLAPPED style. <E>
- <L WS_TILEDWINDOW> 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. <E>
- <L WS_VISIBLE> Creates a window that is initially visible. <E>
- <L WS_VSCROLL> Creates a window that has a vertical scroll bar. <E>
- |</table>
- See also Win32.hlp (topic CreateWindow).
- }
- property ExStyle: DWord read fExStyle write SetExStyle;
- {* Extra window styles. Available flags are following:
- |<table border=0>
- <L WS_EX_ACCEPTFILES> Specifies that a window created with this style
- accepts drag-drop files. <E>
- <L WS_EX_APPWINDOW> Forces a top-level window onto the taskbar
- when the window is minimized. <E>
- <L WS_EX_CLIENTEDGE> Specifies that a window has a border with a
- sunken edge. <E>
- <L WS_EX_CONTEXTHELP> 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. <E>
- <L WS_EX_CONTROLPARENT> Allows the user to navigate among the child
- windows of the window by using the TAB key. <E>
- <L WS_EX_DLGMODALFRAME> 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. <E>
- <L WS_EX_LEFT> Window has generic "left-aligned" properties. This
- is the default. <E>
- <L WS_EX_LEFTSCROLLBAR> 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. <E>
- <L WS_EX_LTRREADING> The window text is displayed using Left to
- Right reading-order properties. This is the default. <E>
- <L WS_EX_MDICHILD> Creates an MDI child window. <E>
- <L WS_EX_NOPARENTNOTIFY> 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. <E>
- <L WS_EX_OVERLAPPEDWINDOW> Combines the WS_EX_CLIENTEDGE and
- WS_EX_WINDOWEDGE styles. <E>
- <L WS_EX_PALETTEWINDOW> Combines the WS_EX_WINDOWEDGE,
- WS_EX_TOOLWINDOW, and WS_EX_TOPMOST styles. <E>
- <L WS_EX_RIGHT> 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. <E>
- <L WS_EX_RIGHTSCROLLBAR> Vertical scroll bar (if present) is to the
- right of the client area. This is the default. <E>
- <L WS_EX_RTLREADING> 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. <E>
- <L WS_EX_STATICEDGE> Creates a window with a three-dimensional
- border style intended to be used for items that do not accept
- user input. <E>
- <L WS_EX_TOOLWINDOW> 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. <E>
- <L WS_EX_TOPMOST> 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. <E>
- <L WS_EX_TRANSPARENT> 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. <E>
- <L WS_EX_WINDOWEDGE> Specifies that a window has a border with
- a raised edge. <E>
- |</table>
- 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).
- |<br>
- 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).
- |<br>
- 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.
- |<br>
- 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).
- |<br>
- You cannot use it to set or remove a selection in a multiple-selection
- list box, so you should set option loNoExtendSel to true.
- |<br>
- 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:
- |<table border=0>
- |&L=<tr><td>%1</td><td>
- <L DDL_ARCHIVE> Include archived files. <E>
- <L DDL_DIRECTORY> Includes subdirectories. Subdirectory names are
- enclosed in square brackets ([ ]). <E>
- <L DDL_DRIVES> Includes drives. Drives are listed in the form [-x-],
- where x is the drive letter. <E>
- <L DDL_EXCLUSIVE> 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. <E>
- <L DDL_HIDDEN> Includes hidden files. <E>
- <L DDL_READONLY> Includes read-only files. <E>
- <L DDL_READWRITE> Includes read-write files with no additional
- attributes. <E>
- <L DDL_SYSTEM> Includes system files. <E>
- </table>
- 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.
- |<br>
- 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.
- |<br>
- Do not forget that if You have more than a single form in your project,
- separate Applet object should be used.
- |<br>
- 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.
- |<br>
- 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).
- |<br>
- Originally was named Margin, now I recommend to use the name 'Border' to
- avoid confusion with MarginTop, MarginBottom, MarginLeft and
- MarginRight properties.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- Originally this property was introduced to compensate incorrect
- ClientRect property, calculated for some types of controls.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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).
- |<br>
- Depending on value assigned, it is possible to adjust transparency
- level ( 0 - totally transparent, 255 - totally opaque).
- |<br>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.
- |<br>
- 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.
- |<br>
- 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).
- |<br>
- 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).
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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:
- |<br> LVSCW_AUTOSIZE - Automatically sizes the column
- |<br> LVSCW_AUTOSIZE_USEHEADER - Automatically sizes the column to fit
- the header text
- |<br>
- 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.
- |<br><br>
- 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.
- |<br><br>
- 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 ().
- |<br>
- Returns an index of added item.
- |<br>
- 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.
- |<br> Returns an index of item inserted.
- |<br> 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.
- |<br>
- If this method is called to set data for column > 0, parameters ImgIdx and
- Data are ignored anyway.
- |<br> 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;
- |<br>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.
- |<br>
- 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:
- |<pre>
- CDDS_PREERASE
- CDDS_POSTERASE
- CDDS_ITEMPREERASE
- CDDS_PREPAINT
- CDDS_ITEMPREPAINT
- CDDS_ITEM
- CDDS_SUBITEM + CDDS_ITEMPREPAINT
- CDDS_SUBITEM + CDDS_ITEMPOSTPAINT
- CDDS_ITEMPOSTPAINT
- CDDS_POSTPAINT
- </pre>
- 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:
- |<pre>
- 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;
- |</pre>
- 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.
- |<br>
- 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:
- |<pre>
- 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.
- |</pre> }
- 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.
- |<br>Please note, that returned path has no trailing delimiter, this
- character is only separating different parts of the path.
- |<br>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:
- |<pre>
- 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
- |</pre> }
-
- 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:
- <pre>
- 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.
- </pre>
- }
- 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:
- |<br> THandle(-1) to add standard small icons,
- |<br> THandle(-2) to add standard large icons,
- |<br> THandle(-5) to add standard small view icons,
- |<br> THandle(-6) to add standard large view icons,
- |<br> THandle(-9) to add standard small history icons,
- |<br> THandle(-10) to add standard large history icons,
- (in that case use following values as indexes to the standard and view
- bitmaps:
- |<br>
- 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,
- |<br>
- 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).
- |<br>
- 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).
- |<br>
- 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).
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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=<a href=#RE_CharFmtArea target=main>%0</a>
- }
- 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 <A area>. To apply only needed attributes, use another
- properties: RE_FmtBold, RE_FmtItalic, RE_FmtStrikeout, RE_FmtUnderline,
- RE_FmtName, etc.
- |<br>
- 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 <A area>. }
- 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 <A area>. }
- 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 <A area>. }
- 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 <A area>. }
- 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 <A area> 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 <A area> (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 <A area> (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 <A area> (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
- <A area>. 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 <A area>, 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 <A area>, 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:
- |<pre>
- 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
- |</pre>
- 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:
- |<pre>
- 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
- |</pre>
- 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;
- |<br>
- 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:
- |<br>
- 0: No EN_CHANGED or EN_SELCHANGE notifications during undetermined state.
- Send notification when final string comes in. (default)
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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).
- |<br>
- 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.
- |<br> 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:
- | <a href=mailto:"bw@sunv.com">Wei Bao</a>. Implementation:
- | <a href=mailto:"bonanzas@xcl.cjb.net">Kladov Vladimir</a>. }
-
-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).
- |<br><br>
- |<h1 align=center><font color=#FF8040><a name="visual_objects_constructors"></a>
- Visual objects constructing functions
- |</font></h1>
- 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:
- |<pre>
- 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
- |</pre>
- }
-
-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.
- |<br>
- 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.
- |<br>
- |&D=<a href="tcontrol.htm#%1" target=_top> %0 </a>
- Following methods, properties and events are useful to work with forms
- (ones common for all visual objects, such as <D Left>, <D Top>, <D Width>,
- <D Height>, 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 <D Font> color
- and to be <D Transparent>.
- |<br> 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.
- |<br>
- 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).
- |<br>
- 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.
- |<br>
- 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 <D Font>, <D Color>,
- and to be totally <D Transparent>.
- Moreover, BitBtn can be <D Flat>, bboFixed, <D SpeedButton> and
- have property <D RepeatInterval>.
- |<br>
- Note: if You use bboFixed Style, use OnChange event instead of OnClick,
- because <D Checked> 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 <D Caption> at run time to change label text. Also
- it is possible to adjust label <D Font>, <D Brush> or <D Color>.
- Label can be <D Transparent>. If You want to have rotated text
- label, call NewLabelEffect instead and change its <D Font>.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 <D Caption>, which
- is controlled by changing <D Font>.FontOrientation property. If You want
- to get flat effect label (e.g. to rotate it only), pass <D ShadowDeep> = 0.
- Please note, that drawing procedure uses <D Canvas> 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 <D OnPaint> 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 <D Color1> and <D Color2> properties (which initially are
- assigned from Color1, Color2 parameters), and call <D Invalidate> 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 <D Color1> and <D Color2> properties (which initially are
- assigned from Color1, Color2 parameters), and call <D Invalidate> 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.
- |<br>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).
- |<br>
- 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).
- |<br>
- 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).
- |<br>
- 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).
- |<br>
- 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.
- |<br>
- 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_...).
- |<br>
- 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.
- |<br>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 <D Count>;
- |<br> to determine which page is currently selected (or to change
- selection), use property <D CurIndex>;
- |<br> to feedback to switch between tabs assign your handler to OnSelChange
- event;
- |<br>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.
- |<br> 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 <D OnTBDropDown> 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).
- |<br>
- Following properties, methods and event are specially designed to work with
- toolbar control:
- |#toolbar
- |<br>
- 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.
- |<br>
- 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.
- |<br><br>
- 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.
- |<br>
- 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).
- |<br>
- 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).
- |<br>
- 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.
- <br>
- 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).
- <br>
- 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 ñàìîñòîÿòåëüíî.
- <br>
- Ñóùåñòâóåò èçâåñòíûé BUG ñ ïîäîáíûìè íåâèäèìûìè ìèíèìèçèðîâàííûìè â òðåé
- ïðèëîæåíèÿìè. Êîãäà â îòâåò íà ñîáûòèå ìûøè àêòèâèçèðâàíî âûïàäàþùåå ìåíþ,
- îíî íå èñ÷åçàåò ïî ùåë÷êó ìûøè âíå ýòîãî ìåíþ. Ïðîèñõîäèò ýòî â Windows9x/ME.
- ÷òîáû ðåøèòü ýòó ïðîáëåìó, ñíà÷àëà àêòèâèçèðóéòå ñâîå îêíî (ôîðìó). Ýòî îêíî
- äîëæíî áûòü âèäèìûì (íî, êîíå÷íî, åãî ìîæíî ðàçìåñòèòü âíå ïðåäåëîâ âèäèìîé
- ÷àñòè ýêðàíà, òàê ÷òî ïîëüçîâàòåëþ åãî âèäíî íå áóäåò).
- <br>
- Òàê æå, ÷òîáû ñäåëàòü ïðèëîæåíèå íåâèäèìûì, ïî êðàéíåé ìåðå, ïîêà ýòî íå
- ïîòðåáóåòñÿ, èñïîëüçóéòå îòäåëüíûé ïðåäñòàâèòåëü êëàññà 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).
- |<br>
- 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=<a name="%0"></a><font color=#FF8040><h1>%0</h1></font>
- <R 64-bit integer numbers>
-}
-{$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.:
- |<br>
- if X < 0 then -1
- |<br>
- if X = 0 then 0
- |<br>
- if X > 0 then 1 }
-function Cmp64( const X, Y: I64 ): Integer;
-{* Result := sign( X - Y ); i.e.
- |<br>
- if X < Y then -1
- |<br>
- if X = Y then 0
- |<br>
- 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}
-{*
-
- <R Floating point numbers>
-}
-
-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;
-|<hr>
-
- <R Small bit arrays (max 32 bits in array)>
- 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 <first> and to <last> inclusively. }
-function GetBitsL( N: DWORD; from, len: Byte ): DWord;
-{* Retuns len bits starting from index <from>.
-|<hr>
-
- <R Arithmetics, geometry and other utility functions>
-
- 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
- |<hr>
- <R String to number and number to string conversions>
-}
-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).
-|<hr>
-
- <R Working with null-terminated and ansi strings>
-}
-{$ENDIF _FPC}
-{$ENDIF WIN}
-function StrComp(const Str1, Str2: PAnsiChar): Integer;
-{* Compares two strings fast. -1: Str1<Str2; 0: Str1=Str2; +1: Str1>Str2 }
-
-{$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 Str1<Str2; 0 when Str1=Str2; +1 when Str1>Str2 }
-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 Str1<Str2; 0 when Str1=Str2; +1 when Str1>Str2 }
-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.
- |<hr>
-
- <R Text in clipboard operations>
-}
-{$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.
-|<hr>
-}
-{$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).
-
- <R Date and time handling>
-}
-{$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):
- |<pre>
- 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).
- |</pre>
- 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.
-|<hr>
-
- <R File and directory routines>
-}
-{$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:
- |<table border=0>
- |&L=<tr><td valign=top>%0</td><td valign=top>
- |&E=</td></tr>
- <L ofOpenRead, ofOpenWrite, ofOpenReadWrite> - 1st group. Here You decide
- wish You open file for read, write or read-and-write operations; <E>
- <L ofShareExclusive, ofShareDenyWrite, ofShareDenyRead, ofShareDenyNone> -2nd
- group - sharing. Here You can mark out sharing mode, which is used to
- open file. <E>
- <L ofCreateNew, ofCreateAlways, ofOpenExisting, ofOpenAlways, ofTruncateExisting>
- - 3rd group - creation disposition. Here You determine, either to create new
- or open existing file and if to truncate existing or not.
- |</table> }
-function FileClose(Handle: THandle): Boolean;
-{* Call it to close opened earlier file. }
-function FileExists( const FileName: KOLString ) : Boolean;
-{* Returns True, if given file exists.
- |<br>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.
- |<br>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.
- |<br>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.
- |<br>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 FT1<FT2, FT1=FT2, FT1>FT2. }
-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'
- |<br>
- FALSE is returned only in case when at least one file was not deleted
- successfully.
- |<br>
- 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:\'.
- |<hr>
-
- <R Wrappers to registry API functions>
-
- 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.
- |<br>
- 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.
- |<br>
- 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 <luft@valerian.de>
-//-------------------------------------------------------
-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.
- |<br>
- If the function fails, the return value is the Key value.
- |<br>
- If the function succeeds, the return value return will be one of the following:
- |<br>
- 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
-
-|<hr>
-
- <R Data sorting (quicksort implementation)>
- This part contains implementation of 'quick sort' algorithm,
- based on following code:
-
-|<pre>
-| 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).
-|</pre>
-
- 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.
-|<hr>
-}
-{ ------------------- 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.
- |<br>
- 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.
- |<br>
- 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.
- |<pre>
- | C:\Projects
- | Test1.Dpr
- | Test2.Dpr
- |</pre>
- If only one file is selected, it is provided as (e.g.)
- C:\Projects\Test1.dpr
- |<br> 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.
- |<br>
- 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.
- |<br>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).
- |<br>
- 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:
- |<br>
- TPM_CENTERALIGN or TPM_LEFTALIGN or TPM_RIGHTALIGN
- |<br>
- TPM_BOTTOMALIGN or TPM_TOPALIGN or TPM_VCENTERALIGN
- |<br>
- TPM_NONOTIFY or TPM_RETURNCMD
- |<br>
- TPM_LEFTBUTTON or TPM_RIGHTBUTTON
- |<br>
- TPM_HORNEGANIMATION or TPM_HORPOSANIMATION or TPM_NOANIMATION or
- TPM_VERNEGANIMATION or TPM_VERPOSANIMATION
- |<br>
- TPM_HORIZONTAL or TPM_VERTICAL.
- |<br>
- 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.
-|<br>
- 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.
-|<br>
- Following formatting characters can be used in menu template strings:
-|&L=<br><b>%1</b>
- <L & (in identifier)> - to underline next character and use it as a shortcut character
- when possible;
- <L + (in front of identifier)> - to make item checked. If also
-|<b>!</b> is used before <b>
- &
-|</b> than radioitem is defined;
- <L - (in front of identifier)> - item not checked;
- <L - (separate)> - separator (between two items);
- <L ( (separate)> - start of submenu;
- <L ) (separate)> - end of submenu;
-|<br>
- 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).
-|<br>
-}
-
-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.
- |<hr>
-
- <R System functions and working with windows>
-}
-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).
- |<br>
- This function allows only to post typeable characters (including
- such special symbols as #13 (Enter), #9 (Tab), #8 (BackSpace), etc.
- |<br>
- 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).
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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.
- |<br>
- 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.
-|<hr>
-}
-{$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 <luft@valerian.de>
-//-----------------------------------------------
-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 C<BufSz then rd:=c else rd:=BufSz;
- rd:=src.read(buf^,rd);
- wr := dst.write(buf^,rd);
- inc(result,wr);
- dec(C, rd);
- until (rd<>BufSz) 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 );//? <U>m</U> ?
- 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 <nil>
- 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 <no>
-{$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<Bmp.Height) and (DWORD(pb) - DWORD(Data) < MaxSize) do
- begin
- if pb^=0 then
- begin
- Inc(pb);
- z:=pb^;
- case pb^ of
- 0: begin
- Inc(y);
- x:=0;
- end;
- 1: Break;
- 2: begin
- Inc(pb); Inc(x,pb^);
- Inc(pb); Inc(y,pb^);
- end;
- else
- begin
- Inc(pb);
- i:=(z+1)shr 1;
- if i and 1 = 1 then Inc( i );
- if x + z <= bmp.Width then
- if x and 1 =1 then
- OddMove(pb,@PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],(z+1)shr 1)
- else
- Move(pb^,PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],(z+1)shr 1);
- Inc(pb,i-1);
- Inc(x,z);
- end;
- end;
- end else
- begin
- z:=pb^;
- Inc(pb);
- if x + z <= Bmp.Width then
- if x and 1 = 1 then
- OddFill(@PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],(z+1) shr 1,pb^)
- else
- FillChar( PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x shr 1],
- (z+1) shr 1, AnsiChar( pb^ ));
- Inc(x,z);
- end;
- Inc(pb);
- end;
-end;
-
-// by Vyacheslav A. Gavrik
-procedure DecodeRLE8(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD);
-var
- pb: PByte;
- x,y,z,i: Integer;
-begin
- pb:=Data; y:=0; x:=0;
- if Bmp.fScanLineSize = 0 then
- Bmp.ScanLineSize;
-
- while (y<Bmp.Height) and (DWORD(pb) - DWORD(Data) < MaxSize) do
- begin
- if pb^=0 then
- begin
- Inc(pb);
- case pb^ of
- 0: begin
- Inc(y);
- x:=0;
- end;
- 1: Break;
- 2: begin
- Inc(pb); Inc(x,pb^);
- Inc(pb); Inc(y,pb^);
- end;
- else
- begin
- i:=pb^;
- z:=(i+1)and(not 1);
- Inc(pb);
- Move(pb^,PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x],i);
- Inc(pb,z-1);
- Inc(x,i);
- end;
- end;
- end else
- begin
- i:=pb^; Inc(pb);
- if x + i <= Bmp.Width then
- FillChar( PByteArray(Integer( Bmp.fDIBBits ) + Bmp.fScanLineSize * y)[x],
- i, AnsiChar( pb^ ));
- Inc(x,i);
- end;
- Inc(pb);
- end;
-end;
-
-function TBitmap.LoadFromFileEx(const Filename: KOLString): Boolean; // by Vyacheslav A. Gavrik
-var Strm: PStream;
-begin
- Strm := NewReadFileStream( Filename );
- Result := LoadFromStreamEx(Strm);
- Strm.Free;
-end;
-
-function TBitmap.LoadFromStreamEx(Strm: PStream): Boolean; // by Vyacheslav A. Gavrik
-var Pos : DWORD;
- i: Integer;
-
- function ReadBitmap : Boolean;
- var Off, Size, ColorCount: Integer;
- BFH : TBitmapFileHeader;
- BCH: TBITMAPCOREHEADER;
- BFHValid: Boolean;
- Buffer: Pointer;
- L: DWORD;
- ColorTriples: Boolean;
- PColr: PDWORD;
- FinalPos: DWORD;
- ZI: DWORD;
- begin
- fHandleType := bmDIB;
- Result := False;
- BFHValid := FALSE;
- if Strm.Read( BFH, Sizeof( BFH ) ) <> 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/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/ImportTXT/kol/CplxMath.pas b/plugins/Libs/CplxMath.pas index 7cd180af9e..7cd180af9e 100644 --- a/plugins/ImportTXT/kol/CplxMath.pas +++ b/plugins/Libs/CplxMath.pas diff --git a/plugins/ImportTXT/kol/KOLEdb.pas b/plugins/Libs/KOLEdb.pas index 4744adc832..4744adc832 100644 --- a/plugins/ImportTXT/kol/KOLEdb.pas +++ b/plugins/Libs/KOLEdb.pas diff --git a/plugins/ImportTXT/kol/KOLMHTooltip_implem.inc b/plugins/Libs/KOLMHTooltip_implem.inc index 869ba0233d..869ba0233d 100644 --- a/plugins/ImportTXT/kol/KOLMHTooltip_implem.inc +++ b/plugins/Libs/KOLMHTooltip_implem.inc diff --git a/plugins/ImportTXT/kol/KOLMHTooltip_interface.inc b/plugins/Libs/KOLMHTooltip_interface.inc index 0e2e9d0d83..0e2e9d0d83 100644 --- a/plugins/ImportTXT/kol/KOLMHTooltip_interface.inc +++ b/plugins/Libs/KOLMHTooltip_interface.inc diff --git a/plugins/ImportTXT/kol/KOLMHTooltip_intf2.inc b/plugins/Libs/KOLMHTooltip_intf2.inc index 3478eab17a..3478eab17a 100644 --- a/plugins/ImportTXT/kol/KOLMHTooltip_intf2.inc +++ b/plugins/Libs/KOLMHTooltip_intf2.inc diff --git a/plugins/ImportTXT/kol/LICENSE.txt b/plugins/Libs/LICENSE.txt index 44ce85874a..44ce85874a 100644 --- a/plugins/ImportTXT/kol/LICENSE.txt +++ b/plugins/Libs/LICENSE.txt diff --git a/plugins/ImportTXT/kol/Mmx.pas b/plugins/Libs/Mmx.pas index cb9ee7c8b7..cb9ee7c8b7 100644 --- a/plugins/ImportTXT/kol/Mmx.pas +++ b/plugins/Libs/Mmx.pas diff --git a/plugins/ImportTXT/kol/delphidef.inc b/plugins/Libs/delphidef.inc index a6a6e51c93..a6a6e51c93 100644 --- a/plugins/ImportTXT/kol/delphidef.inc +++ b/plugins/Libs/delphidef.inc diff --git a/plugins/ImportTXT/kol/read1st.txt b/plugins/Libs/read1st.txt index 3657c8d07d..3657c8d07d 100644 --- a/plugins/ImportTXT/kol/read1st.txt +++ b/plugins/Libs/read1st.txt diff --git a/plugins/ImportTXT/kol/read1st_rus.txt b/plugins/Libs/read1st_rus.txt index 60219b29fc..60219b29fc 100644 --- a/plugins/ImportTXT/kol/read1st_rus.txt +++ b/plugins/Libs/read1st_rus.txt |