/KOLadd.pas

//[START OF KOL.pas]

{****************************************************************

                                                                    d       d

        KKKKK    KKKKK    OOOOOOOOO    LLLLL                        d       d

        KKKKK    KKKKK  OOOOOOOOOOOOO  LLLLL                        d       d

        KKKKK    KKKKK  OOOOO   OOOOO  LLLLL          aaaa          d       d

        KKKKK  KKKKK    OOOOO   OOOOO  LLLLL              a         d       d

        KKKKKKKKKK      OOOOO   OOOOO  LLLLL              a         d       d

        KKKKK  KKKKK    OOOOO   OOOOO  LLLLL          aaaaa    dddddd  dddddd

        KKKKK    KKKKK  OOOOO   OOOOO  LLLLL         a     a  d     d d     d

        KKKKK    KKKKK  OOOOOOOOOOOOO  LLLLLLLLLLLLL a     a  d     d d     d

        KKKKK    KKKKK    OOOOOOOOO    LLLLLLLLLLLLL  aaaaa aa dddddd  dddddd



  Key Objects Library (C) 2000 by Kladov Vladimir.



//[VERSION]

****************************************************************

* VERSION 2.04

****************************************************************

//[END OF VERSION]



The only reason why this part of KOL separated into another unit is that

Delphi has a restriction to DCU size exceeding which it is failed to debug

it normally and in attempt to execute code step by step an internal error

is occur which stops Delphi from working at all.



Version indicated above is a version of KOL, having place when KOLadd.pas was

modified last time, this is not a version of KOLadd itself.

}



unit KOLadd;



interface



{$I KOLDEF.INC}



uses Windows, KOL;



{------------------------------------------------------------------------------)

|                                                                              |

|                                  T L i s t E x                               |

|                                                                              |

(------------------------------------------------------------------------------}

type



//[TListEx DEFINITION]

  {++}(*TListEx = class;*){--}

  PListEx = {-}^{+}TListEx;

  TListEx = object( TObj )

  {* Extended list, with Objects[ ] property. Created calling NewListEx function. }

  protected

    fList: PList;

    fObjects: PList;

    function GetEx(Idx: Integer): Pointer;

    procedure PutEx(Idx: Integer; const Value: Pointer);

    function GetCount: Integer;

    function GetAddBy: Integer;

    procedure Set_AddBy(const Value: Integer);

  public

    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}

    {* }

    property AddBy: Integer read GetAddBy write Set_AddBy;

    {* }

    property Items[ Idx: Integer ]: Pointer read GetEx write PutEx;

    {* }

    property Count: Integer read GetCount;

    {* }

    procedure Clear;

    {* }

    procedure Add( Value: Pointer );

    {* }

    procedure AddObj( Value, Obj: Pointer );

    {* }

    procedure Insert( Idx: Integer; Value: Pointer );

    {* }

    procedure InsertObj( Idx: Integer; Value, Obj: Pointer );

    {* }

    procedure Delete( Idx: Integer );

    {* }

    procedure DeleteRange( Idx, Len: Integer );

    {* }

    function IndexOf( Value: Pointer ): Integer;

    {* }

    function IndexOfObj( Obj: Pointer ): Integer;

    {* }

    procedure Swap( Idx1, Idx2: Integer );

    {* }

    procedure MoveItem( OldIdx, NewIdx: Integer );

    {* }

    property ItemsList: PList read fList;

    {* }

    property ObjList: PList read fObjects;

    {* }

    function Last: Pointer;

    {* }

    function LastObj: Pointer;

    {* }

  end;

//[END OF TListEx DEFINITION]



//[NewListEx DECLARATION]

function NewListEx: PListEx;

{* Creates extended list. }



{------------------------------------------------------------------------------)

|                                                                              |

|                                  T B i t s                                   |

|                                                                              |

(------------------------------------------------------------------------------}

type

//[TBits DEFINITION]

  {++}(*TBits = class;*){--}

  PBits = {-}^{+}TBits;

  TBits = object( TObj )

  {* Variable-length bits array object. Created using function NewBits. See also

     |<a href="kol_pas.htm#Small bit arrays (max 32 bits in array)">

     Small bit arrays (max 32 bits in array)

     |</a>. }

  protected

    fList: PList;

    fCount: Integer;

    function GetBit(Idx: Integer): Boolean;

    procedure SetBit(Idx: Integer; const Value: Boolean);

    function GetCapacity: Integer;

    function GetSize: Integer;

    procedure SetCapacity(const Value: Integer);

  public

    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}

    {* }

    property Bits[ Idx: Integer ]: Boolean read GetBit write SetBit;

    {* }

    property Size: Integer read GetSize;

    {* Size in bytes of the array. To get know number of bits, use property Count. }

    property Count: Integer read fCount;

    {* Number of bits an the array. }

    property Capacity: Integer read GetCapacity write SetCapacity;

    {* Number of bytes allocated. Can be set before assigning bit values

       to improve performance (minimizing amount of memory allocation

       operations).  }

    function Copy( From, BitsCount: Integer ): PBits;

    {* Use this property to get a sub-range of bits starting from given bit

       and of BitsCount bits count. }

    function IndexOf( Value: Boolean ): Integer;

    {* Returns index of first bit with given value (True or False). }

    function OpenBit: Integer;

    {* Returns index of the first bit not set to true. }

    procedure Clear;

    {* Clears bits array. Count, Size and Capacity become 0. }

    function LoadFromStream( strm: PStream ): Integer;

    {* Loads bits from the stream. Data should be stored in the stream

       earlier using SaveToStream method. While loading, previous bits

       data are discarded and replaced with new one totally. In part,

       Count of bits also is changed. Count of bytes read from the stream

       while loading data is returned. }

    function SaveToStream( strm: PStream ): Integer;

    {* Saves entire array of bits to the stream. First, Count of bits

       in the array is saved, then all bytes containing bits data. }

    function Range( Idx, N: Integer ): PBits;

    {* Creates and returns new TBits object instance containing N bits

       starting from index Idx. If you call this method, you are responsible

       for destroying returned object when it become not neccessary. }

    procedure AssignBits( ToIdx: Integer; FromBits: PBits; FromIdx, N: Integer );

    {* Assigns bits from another bits array object. N bits are assigned

       starting at index ToIdx. }

  end;

//[END OF TBits DEFINITION]



//[NewBits DECLARATION]

function NewBits: PBits;

{* Creates variable-length bits array object. }



{------------------------------------------------------------------------------)

|                                                                              |

|                         T F a s t S t r L i s t                              |

|                                                                              |

(------------------------------------------------------------------------------}

type

  PFastStrListEx = ^TFastStrListEx;

  TFastStrListEx = object( TObj )

  private

    function GetItemLen(Idx: Integer): Integer;

    function GetObject(Idx: Integer): DWORD;

    procedure SetObject(Idx: Integer; const Value: DWORD);

    function GetValues(AName: PChar): PChar;

  protected

    procedure Init; virtual;

  protected

    fList: PList;

    fCount: Integer;

    fCaseSensitiveSort: Boolean;

    fTextBuf: PChar;

    fTextSiz: DWORD;

    fUsedSiz: DWORD;

  protected

    procedure ProvideSpace( AddSize: DWORD );

    function Get(Idx: integer): string;

    function GetTextStr: string;

    procedure Put(Idx: integer; const Value: string);

    procedure SetTextStr(const Value: string);

    function GetPChars( Idx: Integer ): PChar;

  {++}(*public*){--}

    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}

  public

    function AddAnsi( const S: String ): Integer;

    {* Adds Ansi String to a list. }

    function AddAnsiObject( const S: String; Obj: DWORD ): Integer;

    {* Adds Ansi String and correspondent object to a list. }

    function Add(S: PChar): integer;

    {* Adds a string to list. }

    function AddLen(S: PChar; Len: Integer): integer;

    {* Adds a string to list. The string can contain #0 characters. }

  public

    FastClear: Boolean;

    {* }

    procedure Clear;

    {* Makes string list empty. }

    procedure Delete(Idx: integer);

    {* Deletes string with given index (it *must* exist). }

    function IndexOf(const S: string): integer;

    {* Returns index of first string, equal to given one. }

    function IndexOf_NoCase(const S: string): integer;

    {* Returns index of first string, equal to given one (while comparing it

       without case sensitivity). }

    function IndexOfStrL_NoCase( Str: PChar; L: Integer ): integer;

    {* Returns index of first string, equal to given one (while comparing it

       without case sensitivity). }

    function Find(const S: String; var Index: Integer): Boolean;

    {* Returns Index of the first string, equal or greater to given pattern, but

       works only for sorted TFastStrListEx object. Returns TRUE if exact string found,

       otherwise nearest (greater then a pattern) string index is returned,

       and the result is FALSE. }

    procedure InsertAnsi(Idx: integer; const S: String);

    {* Inserts ANSI string before one with given index. }

    procedure InsertAnsiObject(Idx: integer; const S: String; Obj: DWORD);

    {* Inserts ANSI string before one with given index. }

    procedure Insert(Idx: integer; S: PChar);

    {* Inserts string before one with given index. }

    procedure InsertLen( Idx: Integer; S: PChar; Len: Integer );

    {* Inserts string from given PChar. It can contain #0 characters. }

    function LoadFromFile(const FileName: string): 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: string);

    {* Merges string list with strings in a file. Fast. }

    procedure Move(CurIndex, NewIndex: integer);

    {* Moves string to another location. }

    procedure SetText(const S: string; Append2List: boolean);

    {* Allows to set strings of string list from given string (in which

       strings are separated by $0D,$0A or $0D characters). Text can

       contain #0 characters. Works very fast. This method is used in

       all others, working with text arrays (LoadFromFile, MergeFromFile,

       Assign, AddStrings). }

    function SaveToFile(const FileName: string): Boolean;

    {* Stores string list to a file. }

    procedure SaveToStream(Stream: PStream);

    {* Saves string list to a stream (from current position). }

    function AppendToFile(const FileName: string): Boolean;

    {* Appends strings of string list to the end of a file. }

    property Count: integer read fCount;

    {* Number of strings in a string list. }

    property Items[Idx: integer]: string 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 ]: PChar read GetPChars;

    {* Fast access to item strings as PChars. }

    property ItemLen[ Idx: Integer ]: Integer read GetItemLen;

    {* Length of string item. }

    function Last: String;

    {* Last item (or '', if string list is empty). }

    property Text: string 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. }

  public

    function AddObject( S: PChar; Obj: DWORD ): Integer;

    {* Adds string S (null-terminated) with associated object Obj. }

    function AddObjectLen( S: PChar; Len: Integer; Obj: DWORD ): Integer;

    {* Adds string S of length Len with associated object Obj. }

    procedure InsertObject( Idx: Integer; S: PChar; Obj: DWORD );

    {* Inserts string S (null-terminated) at position Idx in the list,

       associating it with object Obj. }

    procedure InsertObjectLen( Idx: Integer; S: PChar; Len: Integer; Obj: DWORD );

    {* Inserts string S of length Len at position Idx in the list,

       associating it with object Obj. }

    property Objects[ Idx: Integer ]: DWORD read GetObject write SetObject;

    {* Access to objects associated with strings in the list. }

  public

    procedure Append( S: PChar );

    {* Appends S (null-terminated) to the last string in FastStrListEx object, very fast. }

    procedure AppendLen( S: PChar; Len: Integer );

    {* Appends S of length Len to the last string in FastStrListEx object, very fast. }

    procedure AppendInt2Hex( N: DWORD; MinDigits: Integer );

    {* Converts N to hexadecimal and appends resulting string to the last

       string, very fast. }

  public

    property Values[ Name: PChar ]: PChar read GetValues;

    {* Returns a value correspondent to the Name an ini-file-like string list

       (having Name1=Value1 Name2=Value2 etc. in each string). }

    function IndexOfName( AName: PChar ): Integer;

    {* Searches string starting from 'AName=' in string list like ini-file. }

  end;



function NewFastStrListEx: PFastStrListEx;

         {* Creates FastStrListEx object. }



var Upper: array[ Char ] of Char;

    {* An table to convert char to uppercase very fast. First call InitUpper. }



    Upper_Initialized: Boolean;

procedure InitUpper;

          {* Call this fuction ones to fill Upper[ ] table before using it. }



//[TWStrList]



{-}

{$IFNDEF _FPC}

procedure WStrCopy( Dest, Src: PWideChar );

{* Copies null-terminated Unicode string (terminated null also copied). }

function WStrCmp( W1, W2: PWideChar ): Integer;

{* Compares two null-terminated Unicode strings. }

{$ENDIF _FPC}



{$IFNDEF _D2} //------------------ WideString is not supported in D2 -----------



type

  PWStrList = ^TWstrList;

  {* }

//[TWstrList DEFINITION]

  TWStrList = object( TObj )

  {* String list to store Unicode (null-terminated) strings. }

  protected

    function GetCount: Integer;

    function GetItems(Idx: Integer): WideString;

    procedure SetItems(Idx: Integer; const Value: WideString);

    function GetPtrs(Idx: Integer): PWideChar;

    function GetText: WideString;

  protected

    fList: PList;

    fText: PWideChar;

    fTextBufSz: Integer;

    fTmp1, fTmp2: WideString;

    procedure Init; virtual;

  public

    procedure SetText(const Value: WideString);

    {* See also TStrList.SetText }

    destructor Destroy; virtual;

    {* }

    procedure Clear;

    {* See also TStrList.Clear }

    property Items[ Idx: Integer ]: WideString 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: WideString ): Integer;

    {* See also TStrList.Add }

    procedure Insert( Idx: Integer; const W: WideString );

    {* See also TStrList.Insert }

    procedure Delete( Idx: Integer );

    {* See also TStrList.Delete }

    property Text: WideString 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: String ): Boolean;

    {* See also TStrList.LoadFromFile }

    procedure LoadFromStream( Strm: PStream );

    {* See also TStrList.LoadFromStream }

    function MergeFromFile( const Filename: String ): Boolean;

    {* See also TStrList.MergeFromFile }

    procedure MergeFromStream( Strm: PStream );

    {* See also TStrList.MergeFromStream }

    function SaveToFile( const Filename: String ): Boolean;

    {* See also TStrList.SaveToFile }

    procedure SaveToStream( Strm: PStream );

    {* See also TStrList.SaveToStream }

    function AppendToFile( const Filename: String ): 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 }

  end;

//[END OF TWStrList DEFINITION]



//[TWStrListEx]

  PWStrListEx = ^TWStrListEx;



//[TWStrListEx DEFINITION]

  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 );

    {* }

    function AddObject( const S: WideString; 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: WideString; 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. }

  end;

//[END OF TWStrListEx DEFINITION]



//[NewWStrList DECLARATION]

function NewWStrList: PWStrList;

{* Creates new TWStrList object and returns a pointer to it. }



//[NewWStrListEx DECLARATION]

function NewWStrListEx: PWStrListEx;

{* Creates new TWStrListEx objects and returns a pointer to it. }



{$ENDIF}



//[CABINET FILES OBJECT]

type

  {++}(*TCabFile = class;*){--}

  PCABFile = {-}^{+}TCABFile;



  TOnNextCAB = function( Sender: PCABFile ): String of object;

  TOnCABFile = function( Sender: PCABFile; var FileName: String ): Boolean of object;



{ ----------------------------------------------------------------------



                TCabFile - windows cabinet files



----------------------------------------------------------------------- }

//[TCabFile DEFINITION]

  TCABFile = object( TObj )

  {* An object to simplify extracting files from a cabinet (.CAB) files.

     The only what need to use this object, setupapi.dll. It is provided

     with all latest versions of Windows. }

  protected

    FPaths: PStrList;

    FNames: PStrList;

    FOnNextCAB: TOnNextCAB;

    FOnFile: TOnCABFile;

    FTargetPath: String;

    FSetupapi: THandle;

    function GetNames(Idx: Integer): String;

    function GetCount: Integer;

    function GetPaths(Idx: Integer): String;

    function GetTargetPath: String;

  protected

    FGettingNames: Boolean;

    FCurCAB: Integer;

  public

    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}

    {* }

    property Paths[ Idx: Integer ]: String read GetPaths;

    {* A list of CAB-files. It is stored, when constructing function

       OpenCABFile called. }

    property Names[ Idx: Integer ]: String read GetNames;

    {* A list of file names, stored in a sequence of CAB files. To get know,

       how many files are there, check Count property. }

    property Count: Integer read GetCount;

    {* Number of files stored in a sequence of CAB files. }

    function Execute: Boolean;

    {* Call this method to extract or enumerate files in CAB. For every

       file, found during executing, event OnFile is alled (if assigned).

       If the event handler (if any) does not provide full target path for

       a file to extract to, property TargetPath is applyed (also if it

       is assigned), or file is extracted to the default directory (usually

       the same directory there CAB file is located, or current directory

       - by a decision of the system).

       |<br>

       If a sequence of CAB files is used, and not all names for CAB files

       are provided (absent or represented by a string '?' ), an event

       OnNextCAB is called to obtain the name of the next CAB file.}

    property CurCAB: Integer read FCurCAB;

    {* Index of current CAB file in a sequence of CAB files. When OnNextCAB

       event is called (if any), CurCAB property is already set to the

       index of path, what should be provided. }

    property OnNextCAB: TOnNextCAB read FOnNextCAB write FOnNextCAB;

    {* This event is called, when a series of CAB files is needed and not

       all CAB file names are provided (absent or represented by '?' string).

       If this event is not assigned, the user is prompted to browse file. }

    property OnFile: TOnCABFile read FOnFile write FOnFile;

    {* This event is called for every file found during Execute method.

       In an event handler (if any assigned), it is possible to return

       False to skip file, or to provide another full target path for

       file to extract it to, then default. If the event is not assigned,

       all files are extracted either to default directory, or to the

       directory TargetPath, if it is provided. }

    property TargetPath: String read GetTargetPath write FTargetPath;

    {* Optional target directory to place there extracted files. }

  end;

//[END OF TCABFile DEFINITION]



//[OpenCABFile DECLARATION]

function OpenCABFile( const APaths: array of String ): PCABFile;

{* This function creates TCABFile object, passing a sequence of CAB file names

   (fully qualified). It is possible not to provide all names here, or pass '?'

   string in place of some of those. For such files, either an event OnNextCAB

   will be called, or (and) user will be prompted to browse file during

   executing (i.e. Extracting). }



//[DIRCHANGE]

type

  {++}(*TDirChange = class;*){--}

  PDirChange = {-}^{+}TDirChange;

  {* }



  TOnDirChange = procedure (Sender: PDirChange; const Path: string) of object;

  {* Event type to define OnChange event for folder monitoring objects. }



  TFileChangeFilters = (fncFileName, fncDirName, fncAttributes, fncSize,

      fncLastWrite, fncLastAccess, fncCreation, fncSecurity);

  {* Possible change monitor filters. }

  TFileChangeFilter = set of TFileChangeFilters;

  {* Set of filters to pass to a constructor of TDirChange object. }



{ ----------------------------------------------------------------------



                          TDirChange object



----------------------------------------------------------------------- }

//[TDirChange DEFINITION]

  TDirChange = object(TObj)

  {* Object type to monitor changes in certain folder. }

  protected

    FOnChange: TOnDirChange;

    FHandle: THandle;

    FPath: string;

    FMonitor: PThread;

    function Execute( Sender: PThread ): Integer;

    procedure Changed;

  protected

  {++}(*public*){--}

    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}

    {*}

  public

    property Handle: THandle read FHandle;

    {* Handle of file change notification object. *}

    property Path: String read FPath; //write SetPath;

    {* Path to monitored folder (to a root, if tree of folders

       is under monitoring). }

  end;

//[END OF TDirChange DEFINITION]



//[NewDirChangeNotifier DECLARATION]

function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;

                               WatchSubtree: Boolean; ChangeProc: TOnDirChange ): PDirChange;

{* Creates notification object TDirChangeNotifier. If something wrong (e.g.,

   passed directory does not exist), nil is returned as a result. When change

   is notified, ChangeProc is called always in main thread context.

   (Please note, that ChangeProc can not be nil).

   If empty filter is passed, default filter is used:

   [fncFileName..fncLastWrite]. }



//[METAFILES]



type

  {++}(*TMetafile = class;*){--}

  PMetafile = {-}^{+}TMetafile;

{ ----------------------------------------------------------------------



      TMetafile - Windows metafile and Enchanced Metafile image



----------------------------------------------------------------------- }

//[TMetafile DEFINITION]

  TMetafile = object( TObj )

  {* Object type to incapsulate metafile image. }

  protected

    function GetHeight: Integer;

    function GetWidth: Integer;

    procedure SetHandle(const Value: THandle);

  protected

    fHandle: THandle;

    fHeader: PEnhMetaHeader;

    procedure RetrieveHeader;

  public

    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}

    {* }

    procedure Clear;

    {* }

    function Empty: Boolean;

    {* Returns TRUE if empty}

    property Handle: THandle read fHandle write SetHandle;

    {* Returns handle of enchanced metafile. }

    function LoadFromStream( Strm: PStream ): Boolean;

    {* Loads emf or wmf file format from stream. }

    function LoadFromFile( const Filename: String ): Boolean;

    {* Loads emf or wmf from stream. }

    procedure Draw( DC: HDC; X, Y: Integer );

    {* Draws enchanced metafile on DC. }

    procedure StretchDraw( DC: HDC; const R: TRect );

    {* Draws enchanced metafile stretched. }

    property Width: Integer read GetWidth;

    {* Native width of the metafile. }

    property Height: Integer read GetHeight;

    {* Native height of the metafile. }

  end;

//[END OF TMetafile DEFINITION]



//[NewMetafile DECLARATION]

function NewMetafile: PMetafile;

{* Creates metafile object. }



//[Metafile CONSTANTS, STRUCTURES, ETC.]

const

  WMFKey = Integer($9AC6CDD7);

  WMFWord = $CDD7;

type

  TMetafileHeader = packed record

    Key: Longint;

    Handle: SmallInt;

    Box: TSmallRect;

    Inch: Word;

    Reserved: Longint;

    CheckSum: Word;

  end;



function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;



{++}(*

function SetEnhMetaFileBits(p1: UINT; p2: PChar): HENHMETAFILE; stdcall;

function PlayEnhMetaFile(DC: HDC; p2: HENHMETAFILE; const p3: TRect): BOOL; stdcall;

*){--}



// NewActionList, TAction - by Yury Sidorov

//[ACTIONS OBJECT]

{ ----------------------------------------------------------------------



                TAction and TActionList



----------------------------------------------------------------------- }

type

  PControlRec = ^TControlRec;

  TOnUpdateCtrlEvent = procedure(Sender: PControlRec) of object;



  TCtrlKind = (ckControl, ckMenu, ckToolbar);

  TControlRec = record

    Ctrl: PObj;

    CtrlKind: TCtrlKind;

    ItemID: integer;

    UpdateProc: TOnUpdateCtrlEvent;

  end;



  {++}(* TAction = class;*){--}

  PAction = {-}^{+}TAction;



  {++}(* TActionList = class;*){--}

  PActionList = {-}^{+}TActionList;



//[TAction DEFINITION]

  TAction = {-} object( TObj ) {+}{++}(*class*){--}

  {*! Use action objects, in conjunction with action lists, to centralize the response

      to user commands (actions).

      Use AddControl, AddMenuItem, AddToolbarButton methods to link controls to an action.

      See also TActionList.

      }

  protected

    FControls: PList;

    FCaption: string;

    FChecked: boolean;

    FVisible: boolean;

    FEnabled: boolean;

    FHelpContext: integer;

    FHint: string;

    FOnExecute: TOnEvent;

    FAccelerator: TMenuAccelerator;

    FShortCut: string;

    procedure DoOnMenuItem(Sender: PMenu; Item: Integer);

    procedure DoOnToolbarButtonClick(Sender: PControl; BtnID: Integer);

    procedure DoOnControlClick(Sender: PObj);



    procedure SetCaption(const Value: string);

    procedure SetChecked(const Value: boolean);

    procedure SetEnabled(const Value: boolean);

    procedure SetHelpContext(const Value: integer);

    procedure SetHint(const Value: string);

    procedure SetVisible(const Value: boolean);

    procedure SetAccelerator(const Value: TMenuAccelerator);

    procedure UpdateControls;



    procedure LinkCtrl(ACtrl: PObj; ACtrlKind: TCtrlKind; AItemID: integer; AUpdateProc: TOnUpdateCtrlEvent);

    procedure SetOnExecute(const Value: TOnEvent);



    procedure UpdateCtrl(Sender: PControlRec);

    procedure UpdateMenu(Sender: PControlRec);

    procedure UpdateToolbar(Sender: PControlRec);



  public

    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}

    procedure LinkControl(Ctrl: PControl);

    {* Add a link to a TControl or descendant control. }

    procedure LinkMenuItem(Menu: PMenu; MenuItemIdx: integer);

    {* Add a link to a menu item. }

    procedure LinkToolbarButton(Toolbar: PControl; ButtonIdx: integer);

    {* Add a link to a toolbar button. }

    procedure Execute;

    {* Executes a OnExecute event handler. }

    property Caption: string read FCaption write SetCaption;

    {* Text caption. }

    property Hint: string read FHint write SetHint;

    {* Hint (tooltip). Currently used for toolbar buttons only. }

    property Checked: boolean read FChecked write SetChecked;

    {* Checked state. }

    property Enabled: boolean read FEnabled write SetEnabled;

    {* Enabled state. }

    property Visible: boolean read FVisible write SetVisible;

    {* Visible state. }

    property HelpContext: integer read FHelpContext write SetHelpContext;

    {* Help context. }

    property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator;

    {* Accelerator for menu items. }

    property OnExecute: TOnEvent read FOnExecute write SetOnExecute;

    {* This event is executed when user clicks on a linked object or Execute method was called. }

  end;

//[END OF TAction DEFINITION]



//[TActionList DEFINITION]

  TActionList = {-} object( TObj ) {+}{++}(*class*){--}

  {*! TActionList maintains a list of actions used with components and controls,

     such as menu items and buttons.

     Action lists are used, in conjunction with actions, to centralize the response

     to user commands (actions).

     Write an OnUpdateActions handler to update actions state.

     Created using function NewActionList.

     See also TAction.

  }

  protected

    FOwner: PControl;

    FActions: PList;

    FOnUpdateActions: TOnEvent;

    function GetActions(Idx: integer): PAction;

    function GetCount: integer;

  protected

    procedure DoUpdateActions(Sender: PObj);

  public

    destructor Destroy; {-}virtual;{+}{++}(*override;*){--}

    function Add(const ACaption, AHint: string; OnExecute: TOnEvent): PAction;

    {* Add a new action to the list. Returns pointer to action object. }

    procedure Delete(Idx: integer);

    {* Delete action by index from list. }

    procedure Clear;

    {* Clear all actions in the list. }

    property Actions[Idx: integer]: PAction read GetActions;

    {* Access to actions in the list. }

    property Count: integer read GetCount;

    {* Number of actions in the list.. }

    property OnUpdateActions: TOnEvent read FOnUpdateActions write FOnUpdateActions;

    {* Event handler to update actions state. This event is called each time when application

      goes in the idle state (no messages in the queue). }

  end;

//[END OF TActionList DEFINITION]



//[NewActionList DECLARATION]

function NewActionList(AOwner: PControl): PActionList;

{* Action list constructor. AOwner - owner form. }





implementation



type

  PCrackList = ^TCrackList;

  TCrackList = object( TList )

  end;



{------------------------------------------------------------------------------)

|                                                                              |

|                                  T L i s t E x                               |

|                                                                              |

(------------------------------------------------------------------------------}

{ TListEx }



//[function NewListEx]

function NewListEx: PListEx;

begin

  {-}

  new( Result, Create );

  {+}{++}(*Result := PListEx.Create;*){--}

  Result.fList := NewList;

  Result.fObjects := NewList;

end;

//[END NewListEx]



//[procedure TListEx.Add]

procedure TListEx.Add(Value: Pointer);

begin

  AddObj( Value, nil );

end;



//[procedure TListEx.AddObj]

procedure TListEx.AddObj(Value, Obj: Pointer);

var C: Integer;

begin

  C := Count;

  fList.Add( Value );

  fObjects.Insert( C, Obj );

end;



//[procedure TListEx.Clear]

procedure TListEx.Clear;

begin

  fList.Clear;

  fObjects.Clear;

end;



//[procedure TListEx.Delete]

procedure TListEx.Delete(Idx: Integer);

begin

  DeleteRange( Idx, 1 );

end;



//[procedure TListEx.DeleteRange]

procedure TListEx.DeleteRange(Idx, Len: Integer);

begin

  fList.DeleteRange( Idx, Len );

  fObjects.DeleteRange( Idx, Len );

end;



//[destructor TListEx.Destroy]

destructor TListEx.Destroy;

begin

  fList.Free;

  fObjects.Free;

  inherited;

end;



//[function TListEx.GetAddBy]

function TListEx.GetAddBy: Integer;

begin

  Result := fList.AddBy;

end;



//[function TListEx.GetCount]

function TListEx.GetCount: Integer;

begin

  Result := fList.Count;

end;



//[function TListEx.GetEx]

function TListEx.GetEx(Idx: Integer): Pointer;

begin

  Result := fList.Items[ Idx ];

end;



//[function TListEx.IndexOf]

function TListEx.IndexOf(Value: Pointer): Integer;

begin

  Result := fList.IndexOf( Value );

end;



//[function TListEx.IndexOfObj]

function TListEx.IndexOfObj(Obj: Pointer): Integer;

begin

  Result := fObjects.IndexOf( Obj );

end;



//[procedure TListEx.Insert]

procedure TListEx.Insert(Idx: Integer; Value: Pointer);

begin

  InsertObj( Idx, Value, nil );

end;



//[procedure TListEx.InsertObj]

procedure TListEx.InsertObj(Idx: Integer; Value, Obj: Pointer);

begin

  fList.Insert( Idx, Value );

  fObjects.Insert( Idx, Obj );

end;



//[function TListEx.Last]

function TListEx.Last: Pointer;

begin

  Result := fList.Last;

end;



//[function TListEx.LastObj]

function TListEx.LastObj: Pointer;

begin

  Result := fObjects.Last;

end;



//[procedure TListEx.MoveItem]

procedure TListEx.MoveItem(OldIdx, NewIdx: Integer);

begin

  fList.MoveItem( OldIdx, NewIdx );

  fObjects.MoveItem( OldIdx, NewIdx );

end;



//[procedure TListEx.PutEx]

procedure TListEx.PutEx(Idx: Integer; const Value: Pointer);

begin

  fList.Items[ Idx ] := Value;

end;



//[procedure TListEx.Set_AddBy]

procedure TListEx.Set_AddBy(const Value: Integer);

begin

  fList.AddBy := Value;

  fObjects.AddBy := Value;

end;



//[procedure TListEx.Swap]

procedure TListEx.Swap(Idx1, Idx2: Integer);

begin

  fList.Swap( Idx1, Idx2 );

  fObjects.Swap( Idx1, Idx2 );

end;



{------------------------------------------------------------------------------)

|                                                                              |

|                                  T B i t s                                   |

|                                                                              |

(------------------------------------------------------------------------------}

{ TBits }



//[function NewBits]

function NewBits: PBits;

begin

  {-}

  new( Result, Create );

  {+}{++}(*Result := PBits.Create;*){--}

  Result.fList := NewList;

  //Result.fList.fAddBy := 1;

end;



//[procedure TBits.AssignBits]

procedure TBits.AssignBits(ToIdx: Integer; FromBits: PBits; FromIdx,

  N: Integer);

var i: Integer;

    NewCount: Integer;

begin

  if FromIdx >= FromBits.Count then Exit;

  if FromIdx + N > FromBits.Count then

    N := FromBits.Count - FromIdx;

  Capacity := (ToIdx + N + 8) div 8;

  NewCount := Max( Count, ToIdx + N - 1 );

  fCount := Max( NewCount, fCount );

  PCrackList( fList ).fCount := (Capacity + 3) div 4;

  while ToIdx and $1F <> 0 do

  begin

    Bits[ ToIdx ] := FromBits.Bits[ FromIdx ];

    Inc( ToIdx );

    Inc( FromIdx );

    Dec( N );

    if N = 0 then Exit;

  end;

  Move( PByte( Integer( PCrackList( FromBits.fList ).fItems ) + (FromIdx + 31) div 32 )^,

        PByte( Integer( PCrackList( fList ).fItems ) + ToIdx div 32 )^, (N + 31) div 32 );

  FromIdx := FromIdx and $1F;

  if FromIdx <> 0 then

  begin // shift data by (Idx and $1F) bits right

    for i := ToIdx div 32 to fList.Count-2 do

      fList.Items[ i ] := Pointer(

        (DWORD( fList.Items[ i ] ) shr FromIdx) or

        (DWORD( fList.Items[ i+1 ] ) shl (32 - FromIdx))

        );

    fList.Items[ fList.Count-1 ] := Pointer(

      DWORD( fList.Items[ fList.Count-1 ] ) shr FromIdx

      );

  end;

end;



//[function TBits.Copy]

procedure TBits.Clear;

begin

  fCount := 0;

  fList.Clear;

end;



function TBits.Copy(From, BitsCount: Integer): PBits;

var Shift, N: Integer;

    FirstItemPtr: Pointer;

begin

  Result := NewBits;

  if BitsCount = 0 then Exit;

  Result.Capacity := BitsCount + 32;

  Result.fCount := BitsCount;

  Move( PCrackList( fList ).fItems[ From shr 5 ],

        PCrackList( Result.fList ).fItems[ 0 ], (Count + 31) div 32 );

  Shift := From and $1F;

  if Shift <> 1 then

  begin

    N := (BitsCount + 31) div 32;

    FirstItemPtr := @ PCrackList( Result.fList ).fItems[ N - 1 ];

    asm

          PUSH  ESI

          PUSH  EDI

          MOV   ESI, FirstItemPtr

          MOV   EDI, ESI

          STD

          MOV   ECX, N

          XOR   EAX, EAX

          CDQ

    @@1:

          PUSH  ECX

          LODSD

          MOV   ECX, Shift

          SHRD  EAX, EDX, CL

          STOSD

          SUB   ECX, 32

          NEG   ECX

          SHR   EDX, CL

          POP   ECX



          LOOP  @@1



          CLD

          POP   EDI

          POP   ESI

    end {$IFDEF F_P} ['EAX','EDX','ECX'] {$ENDIF};

  end;

end;



//[destructor TBits.Destroy]

destructor TBits.Destroy;

begin

  fList.Free;

  inherited;

end;



//[function TBits.GetBit]

{$IFDEF ASM_VERSION}

function TBits.GetBit(Idx: Integer): Boolean;

asm

  CMP  EDX, [EAX].FCount

  JL   @@1

  XOR  EAX, EAX

  RET

@@1:

  MOV  EAX, [EAX].fList

  {TEST EAX, EAX

  JZ   @@exit}

  MOV  EAX, [EAX].TList.fItems

  BT   [EAX], EDX

  SETC AL

@@exit:

end;

{$ELSE}

function TBits.GetBit(Idx: Integer): Boolean;

begin

  if (Idx >= Count) {or (PCrackList( fList ).fItems = nil)} then Result := FALSE else

  Result := ( ( DWORD( PCrackList( fList ).fItems[ Idx shr 5 ] ) shr (Idx and $1F)) and 1 ) <> 0;

end;

{$ENDIF}



//[function TBits.GetCapacity]

function TBits.GetCapacity: Integer;

begin

  Result := fList.Capacity * 32;

end;



//[function TBits.GetSize]

function TBits.GetSize: Integer;

begin

  Result := ( PCrackList( fList ).fCount + 3) div 4;

end;



{$IFDEF ASM_noVERSION}

//[function TBits.IndexOf]

function TBits.IndexOf(Value: Boolean): Integer;

asm     //cmd    //opd

        PUSH     EDI

        MOV      EDI, [EAX].fList

        MOV      ECX, [EDI].TList.fCount

@@ret_1:

        OR       EAX, -1

        JECXZ    @@ret_EAX

        MOV      EDI, [EDI].TList.fItems

        TEST     DL, DL

        MOV      EDX, EDI

        JE       @@of_false

        INC      EAX

        REPZ     SCASD

        JE       @@ret_1

        MOV      EAX, [EDI-4]

        NOT      EAX

        JMP      @@calc_offset

        BSF      EAX, EAX

        SUB      EDI, EDX

        SHR      EDI, 2

        ADD      EAX, EDI

        JMP      @@ret_EAX

@@of_false:

        REPE     SCASD

        JE       @@ret_1

        MOV      EAX, [EDI-4]

@@calc_offset:

        BSF      EAX, EAX

        DEC      EAX

        SUB      EDI, 4

        SUB      EDI, EDX

        SHL      EDI, 3

        ADD      EAX, EDI

@@ret_EAX:

        POP      EDI

end;

{$ELSE ASM_VERSION} //Pascal

function TBits.IndexOf(Value: Boolean): Integer;

var I: Integer;

    D: DWORD;

begin

  Result := -1;

  if Value then

  begin

    for I := 0 to fList.Count-1 do

    begin

      D := DWORD( PCrackList( fList ).fItems[ I ] );

      if D <> 0 then

      begin

        asm

          MOV  EAX, D

          BSF  EAX, EAX

          MOV  D, EAX

        end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};

        Result := I * 32 + Integer( D );

        break;

      end;

    end;

  end

    else

  begin

    for I := 0 to PCrackList( fList ).fCount-1 do

    begin

      D := DWORD( PCrackList( fList ).fItems[ I ] );

      if D <> $FFFFFFFF then

      begin

        asm

          MOV  EAX, D

          NOT  EAX

          BSF  EAX, EAX

          MOV  D, EAX

        end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};

        Result := I * 32 + Integer( D );

        break;

      end;

    end;

  end;

end;

{$ENDIF ASM_VERSION}



//[function TBits.LoadFromStream]

function TBits.LoadFromStream(strm: PStream): Integer;

var

 i: Integer;

begin

 Result := strm.Read( i, 4 );

 if Result < 4 then Exit;

 

 bits[ i]:= false; //by miek

 fcount:= i;



 i := (i + 7) div 8;

 Inc( Result, strm.Read( PCrackList( fList ).fItems^, i ) );

end;



//[function TBits.OpenBit]

function TBits.OpenBit: Integer;

begin

  Result := IndexOf( FALSE );

  if Result < 0 then Result := Count;

end;



//[function TBits.Range]

function TBits.Range(Idx, N: Integer): PBits;

begin

  Result := NewBits;

  Result.AssignBits( 0, @ Self, Idx, N );

end;



//[function TBits.SaveToStream]

function TBits.SaveToStream(strm: PStream): Integer;

begin

  Result := strm.Write( fCount, 4 );

  if fCount = 0 then Exit;

  Inc( Result, strm.Write( PCrackList( fList ).fItems^, (fCount + 7) div 8 ) );

end;



//[procedure TBits.SetBit]

{$IFDEF ASM_VERSION}

procedure TBits.SetBit(Idx: Integer; const Value: Boolean);

asm

  PUSH ECX

  MOV  ECX, [EAX].fList

  MOV  ECX, [ECX].TList.fCapacity

  SHL  ECX, 5

  CMP  EDX, ECX

  JLE  @@1



  PUSH EDX

  INC  EDX

  PUSH EAX

  CALL SetCapacity

  POP  EAX

  POP  EDX



@@1:

  CMP  EDX, [EAX].FCount

  JL   @@2

  INC  EDX

  MOV  [EAX].fCount, EDX

  DEC  EDX

@@2:

  POP  ECX

  MOV  EAX, [EAX].fList

  MOV  EAX, [EAX].TList.fItems

  SHR  ECX, 1

  JC   @@2set

  BTR  [EAX], EDX

  JMP  @@exit

@@2set:

  BTS  [EAX], EDX

@@exit:

end;

{$ELSE}

procedure TBits.SetBit(Idx: Integer; const Value: Boolean);

var Msk: DWORD;

begin

  if Idx >= Capacity then

    Capacity := Idx + 1;

  Msk := 1 shl (Idx and $1F);

  if Value then

    PCrackList( fList ).fItems[ Idx shr 5 ] := Pointer(

                  DWORD(PCrackList( fList ).fItems[ Idx shr 5 ]) or Msk)

  else

    PCrackList( fList ).fItems[ Idx shr 5 ] := Pointer(

                  DWORD(PCrackList( fList ).fItems[ Idx shr 5 ]) and not Msk);

  if Idx >= fCount then

    fCount := Idx + 1;

end;

{$ENDIF}



//[procedure TBits.SetCapacity]

procedure TBits.SetCapacity(const Value: Integer);

var OldCap: Integer;

begin

  OldCap := fList.Capacity;

  fList.Capacity := (Value + 31) div 32;

  if OldCap < fList.Capacity then

    FillChar( PChar( Integer( PCrackList( fList ).fItems ) + OldCap * Sizeof( Pointer ) )^,

              (fList.Capacity - OldCap) * sizeof( Pointer ), 0 );

end;



{------------------------------------------------------------------------------)

|                                                                              |

|                         T F a s t S t r L i s t                              |

|                                                                              |

(------------------------------------------------------------------------------}



function NewFastStrListEx: PFastStrListEx;

begin

  new( Result, Create );

end;



procedure InitUpper;

var c: Char;

begin

  for c := #0 to #255 do

    Upper[ c ] := AnsiUpperCase( c + #0 )[ 1 ];

  Upper_Initialized := TRUE;

end;



{ TFastStrListEx }



function TFastStrListEx.AddAnsi(const S: String): Integer;

begin

  Result := AddObjectLen( PChar( S ), Length( S ), 0 );

end;



function TFastStrListEx.AddAnsiObject(const S: String; Obj: DWORD): Integer;

begin

  Result := AddObjectLen( PChar( S ), Length( S ), Obj );

end;



function TFastStrListEx.Add(S: PChar): integer;

begin

  Result := AddObjectLen( S, StrLen( S ), 0 )

end;



function TFastStrListEx.AddLen(S: PChar; Len: Integer): integer;

begin

  Result := AddObjectLen( S, Len, 0 )

end;



function TFastStrListEx.AddObject(S: PChar; Obj: DWORD): Integer;

begin

  Result := AddObjectLen( S, StrLen( S ), Obj )

end;



function TFastStrListEx.AddObjectLen(S: PChar; Len: Integer; Obj: DWORD): Integer;

var Dest: PChar;

begin

  ProvideSpace( Len + 9 );

  Dest := PChar( DWORD( fTextBuf ) + fUsedSiz );

  Result := fCount;

  Inc( fCount );

  fList.Add( Pointer( DWORD(Dest)-DWORD(fTextBuf) ) );

  PDWORD( Dest )^ := Obj;

  Inc( Dest, 4 );

  PDWORD( Dest )^ := Len;

  Inc( Dest, 4 );

  if S <> nil then

    System.Move( S^, Dest^, Len );

  Inc( Dest, Len );

  Dest^ := #0;

  Inc( fUsedSiz, Len+9 );

end;



function TFastStrListEx.AppendToFile(const FileName: string): Boolean;

var F: HFile;

    Txt: String;

begin

  Txt := Text;

  F := FileCreate( FileName, ofOpenAlways or ofOpenReadWrite or ofShareDenyWrite );

  if F = INVALID_HANDLE_VALUE then Result := FALSE

  else begin

         FileSeek( F, 0, spEnd );

         Result := FileWrite( F, PChar( Txt )^, Length( Txt ) ) = DWORD( Length( Txt ) );

         FileClose( F );

       end;

end;



procedure TFastStrListEx.Clear;

begin

  if FastClear then

  begin

    if fList.Count > 0 then

      PCrackList(fList).FCount := 0;

  end

    else

  begin

    fList.Clear;

    if fTextBuf <> nil then

      FreeMem( fTextBuf );

    fTextBuf := nil;

  end;

  fTextSiz := 0;

  fUsedSiz := 0;

  fCount := 0;

end;



procedure TFastStrListEx.Delete(Idx: integer);

begin

  if (Idx < 0) or (Idx >= Count) then Exit;

  if Idx = Count-1 then

    Dec( fUsedSiz, ItemLen[ Idx ]+9 );

  fList.Delete( Idx );

  Dec( fCount );

end;



destructor TFastStrListEx.Destroy;

begin

  FastClear := FALSE;

  Clear;

  fList.Free;

  inherited;

end;



function TFastStrListEx.Find(const S: String; var Index: Integer): Boolean;

var i: Integer;

begin

  for i := 0 to Count-1 do

    if (ItemLen[ i ] = Length( S )) and

       ((S = '') or CompareMem( ItemPtrs[ i ], @ S[ 1 ], Length( S ) )) then

       begin

         Index := i;

         Result := TRUE;

         Exit;

       end;

  Result := FALSE;

end;



function TFastStrListEx.Get(Idx: integer): string;

begin

  if (Idx >= 0) and (Idx <= Count) then

    SetString( Result, PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 8 ),

               ItemLen[ Idx ] )

  else

    Result := '';

end;



function TFastStrListEx.GetItemLen(Idx: Integer): Integer;

var Src: PDWORD;

begin

  if (Idx >= 0) and (Idx <= Count) then

  begin

    Src := PDWORD( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 4 );

    Result := Src^

  end

    else Result := 0;

end;



function TFastStrListEx.GetObject(Idx: Integer): DWORD;

var Src: PDWORD;

begin

  if (Idx >= 0) and (Idx <= Count) then

  begin

    Src := PDWORD( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) );

    Result := Src^

  end

    else Result := 0;

end;



function TFastStrListEx.GetPChars(Idx: Integer): PChar;

begin

  if (Idx >= 0) and (Idx <= Count) then

    Result := PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 8 )

  else Result := nil;

end;



function TFastStrListEx.GetTextStr: string;

var L, i: Integer;

    p: PChar;

begin

  L := 0;

  for i := 0 to Count-1 do

    Inc( L, ItemLen[ i ] + 2 );

  SetLength( Result, L );

  p := PChar( Result );

  for i := 0 to Count-1 do

  begin

    L := ItemLen[ i ];

    if L > 0 then

    begin

      System.Move( ItemPtrs[ i ]^, p^, L );

      Inc( p, L );

    end;

    p^ := #13; Inc( p );

    p^ := #10; Inc( p );

  end;

end;



function TFastStrListEx.IndexOf(const S: string): integer;

begin

  if not Find( S, Result ) then Result := -1;

end;



function TFastStrListEx.IndexOf_NoCase(const S: string): integer;

begin

  Result := IndexOfStrL_NoCase( PChar( S ), Length( S ) );

end;



function TFastStrListEx.IndexOfStrL_NoCase(Str: PChar;

  L: Integer): integer;

var i: Integer;

begin

  for i := 0 to Count-1 do

    if (ItemLen[ i ] = L) and

       ((L = 0) or (StrLComp_NoCase( ItemPtrs[ i ], Str, L ) = 0)) then

       begin

         Result := i;

         Exit;

       end;

  Result := -1;

end;



procedure TFastStrListEx.Init;

begin

  fList := NewList;

  FastClear := TRUE;

end;



procedure TFastStrListEx.InsertAnsi(Idx: integer; const S: String);

begin

  InsertObjectLen( Idx, PChar( S ), Length( S ), 0 );

end;



procedure TFastStrListEx.InsertAnsiObject(Idx: integer; const S: String;

  Obj: DWORD);

begin

  InsertObjectLen( Idx, PChar( S ), Length( S ), Obj );

end;



procedure TFastStrListEx.Insert(Idx: integer; S: PChar);

begin

  InsertObjectLen( Idx, S, StrLen( S ), 0 )

end;



procedure TFastStrListEx.InsertLen(Idx: Integer; S: PChar; Len: Integer);

begin

  InsertObjectLen( Idx, S, Len, 0 )

end;



procedure TFastStrListEx.InsertObject(Idx: Integer; S: PChar; Obj: DWORD);

begin

  InsertObjectLen( Idx, S, StrLen( S ), Obj );

end;



procedure TFastStrListEx.InsertObjectLen(Idx: Integer; S: PChar;

  Len: Integer; Obj: DWORD);

var Dest: PChar;

begin

  ProvideSpace( Len+9 );

  Dest := PChar( DWORD( fTextBuf ) + fUsedSiz );

  fList.Insert( Idx, Pointer( DWORD(Dest)-DWORD(fTextBuf) ) );

  PDWORD( Dest )^ := Obj;

  Inc( Dest, 4 );

  PDWORD( Dest )^ := Len;

  Inc( Dest, 4 );

  if S <> nil then

    System.Move( S^, Dest^, Len );

  Inc( Dest, Len );

  Dest^ := #0;

  Inc( fUsedSiz, Len+9 );

  Inc( fCount );

end;



function TFastStrListEx.Last: String;

begin

  if Count > 0 then

    Result := Items[ Count-1 ]

  else

    Result := '';

end;



function TFastStrListEx.LoadFromFile(const FileName: string): Boolean;

var Strm: PStream;

begin

  Strm := NewReadFileStream( FileName );

  TRY

    Result := Strm.Handle <> INVALID_HANDLE_VALUE;

    if Result then

      LoadFromStream( Strm, FALSE )

    else

      Clear;

  FINALLY

    Strm.Free;

  END;

end;



procedure TFastStrListEx.LoadFromStream(Stream: PStream;

  Append2List: boolean);

var Txt: String;

begin

  SetLength( Txt, Stream.Size - Stream.Position );

  Stream.Read( Txt[ 1 ], Stream.Size - Stream.Position );

  SetText( Txt, Append2List );

end;



procedure TFastStrListEx.MergeFromFile(const FileName: string);

var Strm: PStream;

begin

  Strm := NewReadFileStream( FileName );

  TRY

    LoadFromStream( Strm, TRUE );

  FINALLY

    Strm.Free;

  END;

end;



procedure TFastStrListEx.Move(CurIndex, NewIndex: integer);

begin

  Assert( (CurIndex >= 0) and (CurIndex < Count) and (NewIndex >= 0) and

          (NewIndex < Count), 'Item indexes violates TFastStrListEx range' );

  fList.MoveItem( CurIndex, NewIndex );

end;



procedure TFastStrListEx.ProvideSpace(AddSize: DWORD);

var OldTextBuf: PChar;

begin

  Inc( AddSize, 9 );

  if AddSize > fTextSiz - fUsedSiz then

  begin // óâåëè÷åíèå ðàçìåðà áóôåðà

    fTextSiz := Max( 1024, (fUsedSiz + AddSize) * 2 );

    OldTextBuf := fTextBuf;

    GetMem( fTextBuf, fTextSiz );

    if OldTextBuf <> nil then

    begin

      System.Move( OldTextBuf^, fTextBuf^, fUsedSiz );

      FreeMem( OldTextBuf );

    end;

  end;

  if fList.Count >= fList.Capacity then

    fList.Capacity := Max( 100, fList.Count * 2 );

end;



procedure TFastStrListEx.Put(Idx: integer; const Value: string);

var Dest: PChar;

    OldLen: Integer;

    OldObj: DWORD;

begin

  OldLen := ItemLen[ Idx ];

  if Length( Value ) <= OldLen then

  begin

    Dest := PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 4 );

    PDWORD( Dest )^ := Length( Value );

    Inc( Dest, 4 );

    if Value <> '' then

      System.Move( Value[ 1 ], Dest^, Length( Value ) );

    Inc( Dest, Length( Value ) );

    Dest^ := #0;

    if Idx = Count-1 then

      Dec( fUsedSiz, OldLen - Length( Value ) );

  end

    else

  begin

    OldObj := 0;

    while Idx > Count do

      AddObjectLen( nil, 0, 0 );

    if Idx = Count-1 then

    begin

      OldObj := Objects[ Idx ];

      Delete( Idx );

    end;

    if Idx = Count then

      AddObjectLen( PChar( Value ), Length( Value ), OldObj )

    else

    begin

      ProvideSpace( Length( Value ) + 9 );

      Dest := PChar( DWORD( fTextBuf ) + fUsedSiz );

      fList.Items[ Idx ] := Pointer( DWORD(Dest)-DWORD(fTextBuf) );

      Inc( Dest, 4 );

      PDWORD( Dest )^ := Length( Value );

      Inc( Dest, 4 );

      if Value <> '' then

        System.Move( Value[ 1 ], Dest^, Length( Value ) );

      Inc( Dest, Length( Value ) );

      Dest^ := #0;

      Inc( fUsedSiz, Length( Value )+9 );

    end;

  end;

end;



function TFastStrListEx.SaveToFile(const FileName: string): Boolean;

var Strm: PStream;

begin

  Strm := NewWriteFileStream( FileName );

  TRY

    if Strm.Handle <> INVALID_HANDLE_VALUE then

    SaveToStream( Strm );

    Result := TRUE;

  FINALLY

    Strm.Free;

  END;

end;



procedure TFastStrListEx.SaveToStream(Stream: PStream);

var Txt: String;

begin

  Txt := Text;

  Stream.Write( PChar( Txt )^, Length( Txt ) );

end;



procedure TFastStrListEx.SetObject(Idx: Integer; const Value: DWORD);

var Dest: PDWORD;

begin

  if Idx < 0 then Exit;

  while Idx >= Count do

    AddObjectLen( nil, 0, 0 );

  Dest := PDWORD( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) );

  Dest^ := Value;

end;



procedure TFastStrListEx.SetText(const S: string; Append2List: boolean);

var Len2Add, NLines, L: Integer;

    p0, p: PChar;

begin

  if not Append2List then Clear;

  // ïîäñ÷åò òðåáóåìîãî ïðîñòðàíñòâà

  Len2Add := 0;

  NLines := 0;

  p := Pchar( S );

  p0 := p;

  L := Length( S );

  while L > 0 do

  begin

    if p^ = #13 then

    begin

      Inc( NLines );

      Inc( Len2Add, 9 + DWORD(p)-DWORD(p0) );

      REPEAT Inc( p ); Dec( L );

      UNTIL  (p^ <> #10) or (L = 0);

      p0 := p;

    end

      else

    begin

      Inc( p ); Dec( L );

    end;

  end;

  if DWORD(p) > DWORD(p0) then

  begin

    Inc( NLines );

    Inc( Len2Add, 9 + DWORD(p)-DWORD(p0) );

  end;

  if Len2Add = 0 then Exit;

  // äîáàâëåíèå

  ProvideSpace( Len2Add - 9 );

  if fList.Capacity <= fList.Count + NLines then

    fList.Capacity := Max( (fList.Count + NLines) * 2, 100 );

  p := PChar( S );

  p0 := p;

  L := Length( S );

  while L > 0 do

  begin

    if p^ = #13 then

    begin

      AddObjectLen( p0, DWORD(p)-DWORD(p0), 0 );

      REPEAT Inc( p ); Dec( L );

      UNTIL  (p^ <> #10) or (L = 0);

      p0 := p;

    end

      else

    begin

      Inc( p ); Dec( L );

    end;

  end;

  if DWORD(p) > DWORD(p0) then

    AddObjectLen( p0, DWORD(p)-DWORD(p0), 0 );

end;



procedure TFastStrListEx.SetTextStr(const Value: string);

begin

  SetText( Value, FALSE );

end;



function CompareFast(const Data: Pointer; const e1,e2 : Dword) : Integer;

var FSL: PFastStrListEx;

    L1, L2: Integer;

    S1, S2: PChar;

begin

  FSL := Data;

  S1 := FSL.ItemPtrs[ e1 ];

  S2 := FSL.ItemPtrs[ e2 ];

  L1 := FSL.ItemLen[ e1 ];

  L2 := FSL.ItemLen[ e2 ];

  if FSL.fCaseSensitiveSort then

    Result := StrLComp( S1, S2, Min( L1, L2 ) )

  else

    Result := StrLComp_NoCase( S1, S2, Min( L1, L2 ) );

  if Result = 0 then

    Result := L1 - L2;

  if Result = 0 then

    Result := e1 - e2;

end;



procedure SwapFast(const Data : Pointer; const e1,e2 : Dword);

var FSL: PFastStrListEx;

begin

  FSL := Data;

  FSL.Swap( e1, e2 );

end;



procedure TFastStrListEx.Sort(CaseSensitive: Boolean);

begin

  fCaseSensitiveSort := CaseSensitive;

  SortData( @ Self, Count, CompareFast, SwapFast );

end;



procedure TFastStrListEx.Swap(Idx1, Idx2: Integer);

begin

  Assert( (Idx1 >= 0) and (Idx1 <= Count-1) and (Idx2 >= 0) and (Idx2 <= Count-1),

          'Item indexes violates TFastStrListEx range' );

  fList.Swap( Idx1, Idx2 );

end;



function TFastStrListEx.GetValues(AName: PChar): PChar;

var i: Integer;

    s, n: PChar;

begin

  if not Upper_Initialized then

    InitUpper;

  for i := 0 to Count-1 do

  begin

    s := ItemPtrs[ i ];

    n := AName;

    while (Upper[ s^ ] = Upper[ n^ ]) and (s^ <> '=') and (s^ <> #0) and (n^ <> #0) do

    begin

      Inc( s );

      Inc( n );

    end;

    if (s^ = '=') and (n^ = #0) then

    begin

      Result := s;

      Inc( Result );

      Exit;

    end;

  end;

  Result := nil;

end;



function TFastStrListEx.IndexOfName(AName: PChar): Integer;

var i: Integer;

    s, n: PChar;

begin

  if not Upper_Initialized then

    InitUpper;

  for i := 0 to Count-1 do

  begin

    s := ItemPtrs[ i ];

    n := AName;

    while (Upper[ s^ ] = Upper[ n^ ]) and (s^ <> '=') and (s^ <> #0) and (n^ <> #0) do

    begin

      Inc( s );

      Inc( n );

    end;

    if (s^ = '=') and (n^ = #0) then

    begin

      Result := i;

      Exit;

    end;

  end;

  Result := -1;

end;



procedure TFastStrListEx.Append(S: PChar);

begin

  AppendLen( S, StrLen( S ) );

end;



procedure TFastStrListEx.AppendInt2Hex(N: DWORD; MinDigits: Integer);

var Buffer: array[ 0..9 ] of Char;

    Mask: DWORD;

    i, Len: Integer;

    B: Byte;

begin

  if MinDigits > 8 then

    MinDigits := 8;

  if MinDigits <= 0 then

    MinDigits := 1;

  Mask := $F0000000;

  for i := 8 downto MinDigits do

  begin

    if Mask and N <> 0 then

    begin

      MinDigits := i;

      break;

    end;

    Mask := Mask shr 4;

  end;

  i := 0;

  Len := MinDigits;

  Mask := $F shl ((Len - 1)*4);

  while MinDigits > 0 do

  begin

    Dec( MinDigits );

    B := (N and Mask) shr (MinDigits * 4);

    Mask := Mask shr 4;

    if B <= 9 then

      Buffer[ i ] := Char( B + Ord( '0' ) )

    else

      Buffer[ i ] := Char( B + Ord( 'A' ) - 10 );

    Inc( i );

  end;

  Buffer[ i ] := #0;

  AppendLen( @ Buffer[ 0 ], Len );

end;



procedure TFastStrListEx.AppendLen(S: PChar; Len: Integer);

var Dest: PChar;

begin

  if Count = 0 then

    AddLen( S, Len )

  else

  begin

    ProvideSpace( Len );

    Dest := PChar( DWORD( fTextBuf ) + fUsedSiz - 1 );

    System.Move( S^, Dest^, Len );

    Inc( Dest, Len );

    Dest^ := #0;

    Inc( fUsedSiz, Len );

    Dest := PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Count-1 ] ) );

    Inc( Dest, 4 );

    PDWORD( Dest )^ := PDWORD( Dest )^ + DWORD( Len );

  end;

end;



{-}

//[procedure WStrCopy]

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;



//[function WStrCmp]

function WStrCmp( W1, W2: PWideChar ): Integer;

asm

         PUSH     ESI

         PUSH     EDI

         XCHG     ESI, EAX

         MOV      EDI, EDX

         XOR      EAX, EAX

         CWDE

@@loop:  LODSW

         MOV      DX, [EDI]

         INC      EDI

         INC      EDI

         CMP      EAX, EDX

         JNE      @@exit

         TEST     EAX, EAX

         JNZ      @@loop

@@exit:  SUB      EAX, EDX

         POP      EDI

         POP      ESI

end;



{------------------------------------------------------------------------------)

|                                                                              |

|                         T W S t r L i s t                                    |

|                                                                              |

(------------------------------------------------------------------------------}



{$IFNDEF _D2}



//[function NewWStrList]

function NewWStrList: PWStrList;

begin

  new( Result, Create );

end;



{ TWStrList }



//[function TWStrList.Add]

function TWStrList.Add(const W: WideString): Integer;

begin

  Result := Count;

  Insert( Result, W );

end;



//[procedure TWStrList.AddWStrings]

procedure TWStrList.AddWStrings(WL: PWStrList);

begin

  Text := Text + WL.Text;

end;



//[function TWStrList.AppendToFile]

function TWStrList.AppendToFile(const Filename: String): 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]

procedure TWStrList.Assign(WL: PWStrList);

begin

  Text := WL.Text;

end;



//[procedure TWStrList.Clear]

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]

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]

destructor TWStrList.Destroy;

begin

  Clear;

  fList.Free;

  inherited;

end;



//[function TWStrList.GetCount]

function TWStrList.GetCount: Integer;

begin

  Result := fList.Count;

end;



//[function TWStrList.GetItems]

function TWStrList.GetItems(Idx: Integer): WideString;

begin

  Result := PWideChar( fList.Items[ Idx ] );

end;



//[function TWStrList.GetPtrs]

function TWStrList.GetPtrs(Idx: Integer): PWideChar;

begin

  Result := fList.Items[ Idx ];

end;



//[function TWStrList.GetText]

function TWStrList.GetText: WideString;

const

    EoL: array[ 0..5 ] of Char = ( #13, #0, #10, #0, #0, #0 );

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]

procedure TWStrList.Init;

begin

  fList := NewList;

end;



//[procedure TWStrList.Insert]

procedure TWStrList.Insert(Idx: Integer; const W: WideString);

var P: Pointer;

begin

  while Idx < Count-2 do

    fList.Add( nil );

  GetMem( P, (Length( W ) + 1) * 2 );

  fList.Insert( Idx, P );

  WStrCopy( P, PWideChar( W ) );

end;



//[function TWStrList.LoadFromFile]

function TWStrList.LoadFromFile(const Filename: String): Boolean;

begin

  Clear;

  Result := MergeFromFile( Filename );

end;



//[procedure TWStrList.LoadFromStream]

procedure TWStrList.LoadFromStream(Strm: PStream);

begin

  Clear;

  MergeFromStream( Strm );

end;



//[function TWStrList.MergeFromFile]

function TWStrList.MergeFromFile(const Filename: String): Boolean;

var Strm: PStream;

begin

  Strm := NewReadFileStream( Filename );

  Result := Strm.Handle <> INVALID_HANDLE_VALUE;

  if Result then

    MergeFromStream( Strm );

  Strm.Free;

end;



//[procedure TWStrList.MergeFromStream]

procedure TWStrList.MergeFromStream(Strm: PStream);

var Buf: WideString;

    L: Integer;

begin

  L := Strm.Size - Strm.Position;

  Assert( L mod 1 = 0, 'Wide strings streams must be of even length in bytes.' );

  if L = 0 then Exit;

  SetLength( Buf, L div 2 );

  Strm.Read( Buf[ 1 ], L );

  Text := Text + Buf;

end;



//[procedure TWStrList.Move]

procedure TWStrList.Move(IdxOld, IdxNew: Integer);

begin

  fList.MoveItem( IdxOld, IdxNew );

end;



//[function TWStrList.SaveToFile]

function TWStrList.SaveToFile(const Filename: String): Boolean;

var Strm: PStream;

begin

  Strm := NewWriteFileStream( Filename );

  Result := Strm.Handle <> INVALID_HANDLE_VALUE;

  if Result then

    SaveToStream( Strm );

  Strm.Free;

end;



//[procedure TWStrList.SaveToStream]

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]

procedure TWStrList.SetItems(Idx: Integer; const Value: WideString);

var P: Pointer;

begin

  while Idx > Count-1 do

    fList.Add( nil );

  if WStrLen( ItemPtrs[ Idx ] ) <= Length( Value ) then

    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) * 2 );

    fList.Items[ Idx ] := P;

    WStrCopy( P, PWideChar( Value ) );

  end;

end;



//[procedure TWStrList.SetText]

procedure TWStrList.SetText(const Value: WideString);

var L, N: Integer;

    P: PWideChar;

begin

  Clear;

  if Value = '' then Exit;

  L := (Length( Value ) + 1) * 2;

  GetMem( fText, L );

  System.Move( Value[ 1 ], fText^, L );

  fTextBufSz := Length( Value );

  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

        Inc( P );

    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]

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]

function CompareWStrListItems_UpperCase( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;

var WL: PWStrList;

    L1, L2: Integer;

begin

  WL := Sender;

  L1 := WStrLen( WL.fList.Items[ Idx1 ] );

  L2 := WStrLen( WL.fList.Items[ Idx2 ] );

  if Length( WL.fTmp1 ) < L1 then

    SetLength( WL.fTmp1, L1 + 1 );

  if Length( WL.fTmp2 ) < 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]

procedure SwapWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD );

var WL: PWStrList;

begin

  WL := Sender;

  WL.Swap( Idx1, Idx2 );

end;



//[procedure TWStrList.Sort]

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]

procedure TWStrList.Swap(Idx1, Idx2: Integer);

begin

  fList.Swap( Idx1, Idx2 );

end;



//[function NewWStrListEx]

function NewWStrListEx: PWStrListEx;

begin

  new( Result, Create );

end;



{ TWStrListEx }



//[function TWStrListEx.AddObject]

function TWStrListEx.AddObject(const S: WideString; Obj: DWORD): Integer;

begin

  Result := Count;

  InsertObject( Count, S, Obj );

end;



//[procedure TWStrListEx.AddWStrings]

procedure TWStrListEx.AddWStrings(WL: PWStrListEx);

var I: Integer;

begin

  I := Count;

  if WL.FObjects.Count > 0 then

    ProvideObjectsCapacity( Count );

  inherited AddWStrings( WL );

  if WL.FObjects.Count > 0 then

  begin

    ProvideObjectsCapacity( I + WL.FObjects.Count );

    System.Move( PCrackList( WL.FObjects ).FItems[ 0 ],

                 PCrackList( FObjects ).FItems[ I ],

                 Sizeof( Pointer ) * WL.FObjects.Count );

  end;

end;



//[procedure TWStrListEx.Assign]

procedure TWStrListEx.Assign(WL: PWStrListEx);

begin

  inherited Assign( WL );

  FObjects.Assign( WL.FObjects );

end;



//[procedure TWStrListEx.Clear]

procedure TWStrListEx.Clear;

begin

  inherited Clear;

  FObjects.Clear;

end;



//[procedure TWStrListEx.Delete]

procedure TWStrListEx.Delete(Idx: Integer);

begin

  inherited Delete( Idx );

  if PCrackList( FObjects ).FCount >= Idx then

    FObjects.Delete( Idx );

end;



//[destructor TWStrListEx.Destroy]

destructor TWStrListEx.Destroy;

begin

  fObjects.Free;

  inherited;

end;



//[function TWStrListEx.GetObjects]

function TWStrListEx.GetObjects(Idx: Integer): DWORD;

begin

  Result := DWORD( fObjects.Items[ Idx ] );

end;



//[function TWStrListEx.IndexOfObj]

function TWStrListEx.IndexOfObj(Obj: Pointer): Integer;

begin

  Result := FObjects.IndexOf( Obj );

end;



//[procedure TWStrListEx.Init]

procedure TWStrListEx.Init;

begin

  inherited;

  fObjects := NewList;

end;



//[procedure TWStrListEx.InsertObject]

procedure TWStrListEx.InsertObject(Before: Integer; const S: WideString;

  Obj: DWORD);

begin

  Insert( Before, S );

  FObjects.Insert( Before, Pointer( Obj ) );

end;



//[procedure TWStrListEx.Move]

procedure TWStrListEx.Move(IdxOld, IdxNew: Integer);

begin

  fList.MoveItem( IdxOld, IdxNew );

  if PCrackList( FObjects ).FCount >= Min( IdxOld, IdxNew ) then

  begin

    ProvideObjectsCapacity( Max( IdxOld, IdxNew ) + 1 );

    FObjects.MoveItem( IdxOld, IdxNew );

  end;

end;



//[procedure TWStrListEx.ProvideObjectsCapacity]

procedure TWStrListEx.ProvideObjectsCapacity(NewCap: Integer);

begin

  if fObjects.Capacity >= NewCap then Exit;

  fObjects.Capacity := NewCap;

  FillChar( PCrackList( FObjects ).FItems[ FObjects.Count ],

            (FObjects.Capacity - FObjects.Count) * Sizeof( Pointer ), 0 );

  PCrackList( FObjects ).FCount := NewCap;

end;



//[procedure TWStrListEx.SetObjects]

procedure TWStrListEx.SetObjects(Idx: Integer; const Value: DWORD);

begin

  ProvideObjectsCapacity( Idx + 1 );

  fObjects.Items[ Idx ] := Pointer( Value );

end;



{$ENDIF}

{+}



{ TCABFile }



//[function OpenCABFile]

function OpenCABFile( const APaths: array of String ): PCABFile;

var I: Integer;

begin

  {-}

  New( Result, Create );

  {+}{++}(*Result := PCABFile.Create;*){--}

  Result.FSetupapi := LoadLibrary( 'setupapi.dll' );

  Result.FNames := NewStrList;

  Result.FPaths := NewStrList;

  for I := 0 to High( APaths ) do

    Result.FPaths.Add( APaths[ I ] );

end;



//[destructor TCABFile.Destroy]

destructor TCABFile.Destroy;

begin

  FNames.Free;

  FPaths.Free;

  FTargetPath := '';

  if FSetupapi <> 0 then

    FreeLibrary( FSetupapi );

  inherited;

end;



const

  SPFILENOTIFY_FILEINCABINET  = $11;

  SPFILENOTIFY_NEEDNEWCABINET = $12;



type

  PSP_FILE_CALLBACK = function( Context: Pointer; Notification, Param1, Param2: DWORD ): DWORD;

  stdcall;



  TSetupIterateCabinet = function ( CabinetFile: PChar; Reserved: DWORD;

         MsgHandler: PSP_FILE_CALLBACK; Context: Pointer ): Boolean; stdcall;

         //external 'setupapi.dll' name 'SetupIterateCabinetA';



  TSetupPromptDisk = function (

    hwndParent: HWND; 	// parent window of the dialog box

    DialogTitle: PChar;	// optional, title of the dialog box

    DiskName: PChar;	// optional, name of disk to insert

    PathToSource: PChar;// optional, expected source path

    FileSought: PChar;	// name of file needed

    TagFile: PChar;	// optional, source media tag file

    DiskPromptStyle: DWORD;	// specifies dialog box behavior

    PathBuffer: PChar;	// receives the source location

    PathBufferSize: DWORD;	// size of the supplied buffer

    PathRequiredSize: PDWORD	// optional, buffer size needed

   ): DWORD; stdcall;

   //external 'setupapi.dll' name 'SetupPromptForDiskA';



type

  TCabinetInfo = packed record

    CabinetPath: PChar;

    CabinetFile: PChar;

    DiskName: PChar;

    SetId: WORD;

    CabinetNumber: WORD;

  end;

  PCabinetInfo = ^TCabinetInfo;



  TFileInCabinetInfo = packed record

    NameInCabinet: PChar;

    FileSize: DWORD;

    Win32Error: DWORD;

    DosDate: WORD;

    DosTime: WORD;

    DosAttribs: WORD;

    FullTargetName: array[0..MAX_PATH-1] of Char;

  end;

  PFileInCabinetInfo = ^TFileInCabinetInfo;



//[function CABCallback]

function CABCallback( Context: Pointer; Notification, Param1, Param2: DWORD ): DWORD;

stdcall;

var CAB: PCABFile;

    CABPath, OldPath: String;

    CABInfo: PCabinetInfo;

    CABFileInfo: PFileInCabinetInfo;

    hr: Integer;

    SetupPromptProc: TSetupPromptDisk;

begin

  Result := 0;

  CAB := Context;

  case Notification of

  SPFILENOTIFY_NEEDNEWCABINET:

    begin

      OldPath := CAB.FPaths.Items[ CAB.FCurCAB ];

      Inc( CAB.FCurCAB );

      if CAB.FCurCAB = CAB.FPaths.Count then

        CAB.FPaths.Add( '?' );

      CABPath := CAB.FPaths.Items[ CAB.FCurCAB ];

      if CABPath = '?' then

      begin

        if Assigned( CAB.FOnNextCAB ) then

          CAB.FPaths.Items[CAB.FCurCAB ] := CAB.FOnNextCAB( CAB );

        CABPath := CAB.FPaths.Items[ CAB.FCurCAB ];

        if CABPath = '?' then

        begin

          SetLength( CABPath, MAX_PATH );

          CABInfo := Pointer( Param1 );

          if CAB.FSetupapi <> 0 then

            SetupPromptProc := GetProcAddress( CAB.FSetupapi, 'SetupPromptForDiskA' )

          else

            SetupPromptProc := nil;

          if Assigned( SetupPromptProc ) then

          begin

            hr := SetupPromptProc( 0, nil, nil, PChar( ExtractFilePath( OldPath ) ),

                 CABInfo.CabinetFile, nil, 2 {IDF_NOSKIP}, @CabPath[ 1 ], MAX_PATH, nil );

            case hr of

            0: // success

              begin

                StrCopy( PChar( Param2 ), PChar( CABPath ) );

                Result := 0;

              end;

            2: // skip file

              Result := 0;

            else // cancel

              Result := ERROR_FILE_NOT_FOUND;

            end;

          end;

        end

          else

        begin

          StrCopy( PChar( Param2 ), PChar( CABPath ) );

          Result := 0;

        end;

      end;

    end;

  SPFILENOTIFY_FILEINCABINET:

    begin

      CABFileInfo := Pointer( Param1 );

      if CAB.FGettingNames then

      begin

        CAB.FNames.Add( CABFileInfo.NameInCabinet );

        Result := 2; // FILEOP_SKIP

      end

        else

      begin

        CABPath := CABFileInfo.NameInCabinet;

        if Assigned( CAB.FOnFile ) then

        begin

          if CAB.FOnFile( CAB, CABPath ) then

          begin

            if ExtractFilePath( CABPath ) = '' then

            if CAB.FTargetPath <> '' then

              CABPath := CAB.TargetPath + CABPath;

            StrCopy( @CABFileInfo.FullTargetName[ 0 ], PChar( CABPath ) );

            Result := 1; // FILEOP_DOIT

          end

          else

            Result := 2

        end

        else

        begin

          if CAB.FTargetPath <> '' then

            StrCopy( @CABFileInfo.FullTargetName[ 0 ], PChar( CAB.TargetPath + CABPath ) );

          Result := 1;

        end;

      end;

    end;

  end;

end;



//[function TCABFile.Execute]

function TCABFile.Execute: Boolean;

var SetupIterateProc: TSetupIterateCabinet;

begin

  FCurCAB := 0;

  Result := FALSE;

  if FSetupapi = 0 then Exit;

  SetupIterateProc := GetProcAddress( FSetupapi, 'SetupIterateCabinetA' );

  if not Assigned( SetupIterateProc ) then Exit;

  Result := SetupIterateProc( PChar( FPaths.Items[ 0 ] ), 0, CABCallback, @Self );

end;



//[function TCABFile.GetCount]

function TCABFile.GetCount: Integer;

begin

  GetNames( 0 );

  Result := FNames.Count;

end;



//[function TCABFile.GetNames]

function TCABFile.GetNames(Idx: Integer): String;

begin

  if FNames.Count = 0 then

  begin

    FGettingNames := TRUE;

    Execute;

    FGettingNames := FALSE;

  end;

  Result := '';

  if Idx < FNames.Count then

    Result := FNames.Items[ Idx ];

end;



//[function TCABFile.GetPaths]

function TCABFile.GetPaths(Idx: Integer): String;

begin

  Result := FPaths.Items[ Idx ];

end;



//[function TCABFile.GetTargetPath]

function TCABFile.GetTargetPath: String;

begin

  Result := FTargetPath;

  if Result <> '' then

  if Result[ Length( Result ) ] <> '\' then

    Result := Result + '\';

end;



{ -- TDirChange -- }



const FilterFlags: array[ TFileChangeFilters ] of Integer = (

      FILE_NOTIFY_CHANGE_FILE_NAME, FILE_NOTIFY_CHANGE_DIR_NAME,

      FILE_NOTIFY_CHANGE_ATTRIBUTES, FILE_NOTIFY_CHANGE_SIZE,

      FILE_NOTIFY_CHANGE_LAST_WRITE, $20 {FILE_NOTIFY_CHANGE_LAST_ACCESS},

      $40 {FILE_NOTIFY_CHANGE_CREATION}, FILE_NOTIFY_CHANGE_SECURITY );



//[FUNCTION _NewDirChgNotifier]

{$IFDEF ASM_VERSION}

function _NewDirChgNotifier: PDirChange;

begin

  New( Result, Create );

end;

//[function NewDirChangeNotifier]

function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;

                               WatchSubtree: Boolean; ChangeProc: TOnDirChange )

                               : PDirChange;

const Dflt_Flags = FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or

      FILE_NOTIFY_CHANGE_ATTRIBUTES or FILE_NOTIFY_CHANGE_SIZE or

      FILE_NOTIFY_CHANGE_LAST_WRITE;

asm

        PUSH     EBX

        PUSH     ECX // [EBP-8] = WatchSubtree

        PUSH     EDX // [EBP-12] = Filter

        PUSH     EAX // [EBP-16] = Path

        CALL     _NewDirChgNotifier

        XCHG     EBX, EAX

        LEA      EAX, [EBX].TDirChange.FPath

        POP      EDX

        CALL     System.@LStrAsg

        MOV      EAX, [ChangeProc].TMethod.Code

        MOV      [EBX].TDirChange.FOnChange.TMethod.Code, EAX

        MOV      EAX, [ChangeProc].TMethod.Data

        MOV      [EBX].TDirChange.FOnChange.TMethod.Data, EAX

        POP      ECX

        MOV      EAX, Dflt_Flags

        MOVZX    ECX, CL

        JECXZ    @@flags_ready

        PUSH     ECX

        MOV      EAX, ESP

        MOV      EDX, offset[FilterFlags]

        XOR      ECX, ECX

        MOV      CL, 7

        CALL     MakeFlags

        POP      ECX

@@flags_ready:           // EAX = Flags

        POP      EDX

        MOVZX    EDX, DL // EDX = WatchSubtree

        PUSH     EAX

        PUSH     EDX

        PUSH     [EBX].TDirChange.FPath

        CALL     FindFirstChangeNotification

        MOV      [EBX].TDirChange.FHandle, EAX

        INC      EAX

        JZ       @@fault

        PUSH     EBX

        PUSH     offset[TDirChange.Execute]

        CALL     NewThreadEx

        MOV      [EBX].TDirChange.FMonitor, EAX

        JMP      @@exit

@@fault:

        XCHG     EAX, EBX

        CALL     TObj.Free

@@exit:

        XCHG     EAX, EBX

        POP      EBX

end;

{$ELSE ASM_VERSION} //Pascal

function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;

                               WatchSubtree: Boolean; ChangeProc: TOnDirChange )

                               : PDirChange;

var Flags: DWORD;

begin

  {-}

  New( Result, Create );

  {+}{++}(*Result := PDirChange.Create;*){--}



  Result.FPath := Path;

  Result.FOnChange := ChangeProc;

  if Filter = [ ] then

    Flags := FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or

      FILE_NOTIFY_CHANGE_ATTRIBUTES or FILE_NOTIFY_CHANGE_SIZE or

      FILE_NOTIFY_CHANGE_LAST_WRITE

  else

    Flags := MakeFlags( @Filter, FilterFlags );

  Result.FHandle := FindFirstChangeNotification(PChar(Result.FPath),

                    Bool( Integer( WatchSubtree ) ), Flags);

  if Result.FHandle <> INVALID_HANDLE_VALUE then

    Result.FMonitor := NewThreadEx( Result.Execute )

  else //MsgOK( 'Can not monitor ' + Result.FPath + #13'Error ' + Int2Str( GetLastError ) );

  begin

    Result.Free;

    Result := nil;

  end;

end;

{$ENDIF ASM_VERSION}

//[END _NewDirChgNotifier]



{ TDirChange }



{$IFDEF ASM_VERSION}

//[procedure TDirChange.Changed]

procedure TDirChange.Changed;

asm

        MOV      ECX, [EAX].FPath

        XCHG     EDX, EAX

        MOV      EAX, [EDX].FOnChange.TMethod.Data

        CALL     [EDX].FOnChange.TMethod.Code

end;

{$ELSE ASM_VERSION} //Pascal

procedure TDirChange.Changed;

begin

  FOnChange(@Self, FPath); // must be assigned always!!!

end;

{$ENDIF ASM_VERSION}



{$IFDEF ASM_VERSION}

//[destructor TDirChange.Destroy]

destructor TDirChange.Destroy;

asm

        PUSH     EBX

        XCHG     EBX, EAX

        MOV      ECX, [EBX].FMonitor

        JECXZ    @@no_monitor

        XCHG     EAX, ECX

        CALL     TObj.Free

@@no_monitor:

        MOV      ECX, [EBX].FHandle

        JECXZ    @@exit

        PUSH     ECX

        CALL     FindCloseChangeNotification

@@exit:

        LEA      EAX, [EBX].FPath

        CALL     System.@LStrClr

        XCHG     EAX, EBX

        CALL     TObj.Destroy

        POP      EBX

end;

{$ELSE ASM_VERSION} //Pascal

destructor TDirChange.Destroy;

begin

  if FMonitor <> nil then

     FMonitor.Free;

  if FHandle > 0 then // FHandle <> INVALID_HANDLE_VALUE AND FHandle <> 0

     FindCloseChangeNotification(FHandle);

  FPath := '';

  inherited;

end;

{$ENDIF ASM_VERSION}



{$IFDEF ASM_noVERSION}

//[function TDirChange.Execute]

function TDirChange.Execute(Sender: PThread): Integer;

asm

        PUSH     EBX

        PUSH     ESI

        XCHG     EBX, EAX

        MOV      ESI, EDX

@@loo:

        MOVZX    ECX, [ESI].TThread.FTerminated

        INC      ECX

        LOOP     @@e_loop



        MOV      ECX, [EBX].FHandle

        INC      ECX

        JZ       @@e_loop



        PUSH     INFINITE

        PUSH     ECX

        CALL     WaitForSingleObject

        OR       EAX, EAX

        JNZ      @@loo



        PUSH     [EBX].FHandle

        MOV      EAX, [EBX].FMonitor

        PUSH     EBX

        PUSH     offset[TDirChange.Changed]

        CALL     TThread.Synchronize

        CALL     FindNextChangeNotification

        JMP      @@loo

@@e_loop:



        POP      ESI

        POP      EBX

        XOR      EAX, EAX

end;

{$ELSE ASM_VERSION} //Pascal

function TDirChange.Execute(Sender: PThread): Integer;

begin

  while (not Sender.Terminated and (FHandle <> INVALID_HANDLE_VALUE)) do

    if (WaitForSingleObject(FHandle, INFINITE) = WAIT_OBJECT_0) then

    begin

      if AppletTerminated then break;

      Applet.GetWindowHandle;

      FMonitor.Synchronize( Changed );

      FindNextChangeNotification(FHandle);

    end;

  Result := 0;

end;

{$ENDIF ASM_VERSION}



////////////////////////////////////////////////////////////////////////

//

//

//                         M  E T A F I L E

//

//

////////////////////////////////////////////////////////////////////////



{++}(*

//[API SetEnhMetaFileBits]

function SetEnhMetaFileBits; external gdi32 name 'SetEnhMetaFileBits';

function PlayEnhMetaFile; external gdi32 name 'PlayEnhMetaFile';

*){--}



//[function NewMetafile]

function NewMetafile: PMetafile;

begin

  {-}

  new( Result, Create );

  {+}{++}(*Result := PMetafile.Create;*){--}

end;

//[END NewMetafile]



{ TMetafile }



//[procedure TMetafile.Clear]

procedure TMetafile.Clear;

begin

  if fHandle <> 0 then

    DeleteEnhMetaFile( fHandle );

  fHandle := 0;

end;



//[destructor TMetafile.Destroy]

destructor TMetafile.Destroy;

begin

  if fHeader <> nil then

    FreeMem( fHeader );

  Clear;

  inherited;

end;



//[procedure TMetafile.Draw]

procedure TMetafile.Draw(DC: HDC; X, Y: Integer);

begin

  StretchDraw( DC, MakeRect( X, Y, X + Width, Y + Height ) );

end;



//[function TMetafile.Empty]

function TMetafile.Empty: Boolean;

begin

  Result := fHandle = 0;

end;



//[function TMetafile.GetHeight]

function TMetafile.GetHeight: Integer;

begin

  Result := 0;

  if Empty then Exit;

  RetrieveHeader;

  Result := fHeader.rclBounds.Bottom - fHeader.rclBounds.Top;

end;



//[function TMetafile.GetWidth]

function TMetafile.GetWidth: Integer;

begin

  Result := 0;

  if Empty then Exit;

  RetrieveHeader;

  Result := fHeader.rclBounds.Right - fHeader.rclBounds.Left;

end;



//[function TMetafile.LoadFromFile]

function TMetafile.LoadFromFile(const Filename: String): Boolean;

var Strm: PStream;

begin

  Strm := NewReadFileStream( FileName );

  Result := LoadFromStream( Strm );

  Strm.Free;

end;



//[function ComputeAldusChecksum]

function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;

type

  PWord = ^Word;

var

  pW: PWord;

  pEnd: PWord;

begin

  Result := 0;

  pW := @WMF;

  pEnd := @WMF.CheckSum;

  while Longint(pW) < Longint(pEnd) do

  begin

    Result := Result xor pW^;

    Inc(Longint(pW), SizeOf(Word));

  end;

end;



//[function TMetafile.LoadFromStream]

function TMetafile.LoadFromStream(Strm: PStream): Boolean;

var WMF: TMetaFileHeader;

    WmfHdr: TMetaHeader;

    EnhHdr: TEnhMetaHeader;

    Pos, Pos1: Integer;

    Sz: Integer;

    MemStrm: PStream;

    MFP: TMetafilePict;

begin

  Result := FALSE;

  Pos := Strm.Position;



  if Strm.Read( WMF, Sizeof( WMF ) ) <> Sizeof( WMF ) then

  begin

    Strm.Position := Pos;

    Exit;

  end;



  MemStrm := NewMemoryStream;



  if WMF.Key = WMFKey then

  begin // Windows metafile



    if WMF.CheckSum <> ComputeAldusChecksum( WMF ) then

    begin

      Strm.Position := Pos;

      Exit;

    end;



    Pos1 := Strm.Position;

    if Strm.Read( WmfHdr, Sizeof( WmfHdr ) ) <> Sizeof( WmfHdr ) then

    begin

      Strm.Position := Pos;

      Exit;

    end;



    Strm.Position := Pos1;

    Sz := WMFHdr.mtSize * 2;

    Stream2Stream( MemStrm, Strm, Sz );

    FillChar( MFP, Sizeof( MFP ), 0 );

    MFP.mm := MM_ANISOTROPIC;

    fHandle := SetWinMetafileBits( Sz, MemStrm.Memory, 0, MFP );



  end

    else

  begin // may be enchanced?



    Strm.Position := Pos;

    if Strm.Read( EnhHdr, Sizeof( EnhHdr ) ) < 8 then

    begin

      Strm.Position := Pos;

      Exit;

    end;

    // yes, enchanced

    Strm.Position := Pos;

    Sz := EnhHdr.nBytes;

    Stream2Stream( MemStrm, Strm, Sz );

    fHandle := SetEnhMetaFileBits( Sz, MemStrm.Memory );



  end;



  MemStrm.Free;

  Result := fHandle <> 0;

  if not Result then

    Strm.Position := Pos;



end;



//[procedure TMetafile.RetrieveHeader]

procedure TMetafile.RetrieveHeader;

var SzHdr: Integer;

begin

  if fHeader <> nil then

    FreeMem( fHeader );

  SzHdr := GetEnhMetaFileHeader( fHandle, 0, nil );

  GetMem( fHeader, SzHdr );

  GetEnhMetaFileHeader( fHandle, SzHdr, fHeader );

end;



//[procedure TMetafile.SetHandle]

procedure TMetafile.SetHandle(const Value: THandle);

begin

  Clear;

  fHandle := Value;

end;



//[procedure TMetafile.StretchDraw]

procedure TMetafile.StretchDraw(DC: HDC; const R: TRect);

begin

  if Empty then Exit;

  PlayEnhMetaFile( DC, fHandle, R );

end;



{ ----------------------------------------------------------------------



                TAction and TActionList



----------------------------------------------------------------------- }

//[function NewActionList]

function NewActionList(AOwner: PControl): PActionList;

begin

  {-}

  New( Result, Create );

  {+} {++}(* Result := PActionList.Create; *){--}

  with Result{-}^{+} do begin

    FActions:=NewList;

    FOwner:=AOwner;

    RegisterIdleHandler(DoUpdateActions);

  end;

end;

//[END NewActionList]



//[function NewAction]

function NewAction(const ACaption, AHint: string; AOnExecute: TOnEvent): PAction;

begin

  {-}

  New( Result, Create );

  {+} {++}(* Result := PAction.Create; *){--}

  with Result{-}^{+} do begin

    FControls:=NewList;

    Enabled:=True;

    Visible:=True;

    Caption:=ACaption;

    Hint:=AHint;

    OnExecute:=AOnExecute;

  end;

end;

//[END NewAction]



{ TAction }



//[procedure TAction.LinkCtrl]

procedure TAction.LinkCtrl(ACtrl: PObj; ACtrlKind: TCtrlKind; AItemID: integer; AUpdateProc: TOnUpdateCtrlEvent);

var

  cr: PControlRec;

begin

  New(cr);

  with cr^ do begin

    Ctrl:=ACtrl;

    CtrlKind:=ACtrlKind;

    ItemID:=AItemID;

    UpdateProc:=AUpdateProc;

  end;

  FControls.Add(cr);

  AUpdateProc(cr);

end;



//[procedure TAction.LinkControl]

procedure TAction.LinkControl(Ctrl: PControl);

begin

  LinkCtrl(Ctrl, ckControl, 0, UpdateCtrl);

  Ctrl.OnClick:=DoOnControlClick;

end;



//[procedure TAction.LinkMenuItem]

procedure TAction.LinkMenuItem(Menu: PMenu; MenuItemIdx: integer);

{$IFDEF _FPC}

var

  arr1_DoOnMenuItem: array[ 0..0 ] of TOnMenuItem;

{$ENDIF _FPC}

begin

  LinkCtrl(Menu, ckMenu, MenuItemIdx, UpdateMenu);

  {$IFDEF _FPC}

  arr1_DoOnMenuItem[ 0 ] := DoOnMenuItem;

  Menu.AssignEvents(MenuItemIdx, arr1_DoOnMenuItem);

  {$ELSE}

  Menu.AssignEvents(MenuItemIdx, [ DoOnMenuItem ]);

  {$ENDIF}

end;



//[procedure TAction.LinkToolbarButton]

procedure TAction.LinkToolbarButton(Toolbar: PControl; ButtonIdx: integer);

{$IFDEF _FPC}

var

  arr1_DoOnToolbarButtonClick: array[ 0..0 ] of TOnToolbarButtonClick;

{$ENDIF _FPC}

begin

  LinkCtrl(Toolbar, ckToolbar, ButtonIdx, UpdateToolbar);

  {$IFDEF _FPC}

  arr1_DoOnToolbarButtonClick[ 0 ] := DoOnToolbarButtonClick;

  Toolbar.TBAssignEvents(ButtonIdx, arr1_DoOnToolbarButtonClick);

  {$ELSE}

  Toolbar.TBAssignEvents(ButtonIdx, [DoOnToolbarButtonClick]);

  {$ENDIF}

end;



//[destructor TAction.Destroy]

destructor TAction.Destroy;

begin

  FControls.Release;

  FCaption:='';

  FShortCut:='';

  FHint:='';

  inherited;

end;



//[procedure TAction.DoOnControlClick]

procedure TAction.DoOnControlClick(Sender: PObj);

begin

  Execute;

end;



//[procedure TAction.DoOnMenuItem]

procedure TAction.DoOnMenuItem(Sender: PMenu; Item: Integer);

begin

  Execute;

end;



//[procedure TAction.DoOnToolbarButtonClick]

procedure TAction.DoOnToolbarButtonClick(Sender: PControl; BtnID: Integer);

begin

  Execute;

end;



//[procedure TAction.Execute]

procedure TAction.Execute;

begin

  if Assigned(FOnExecute) and FEnabled then

    FOnExecute(PObj( @Self ));

end;



//[procedure TAction.SetCaption]

procedure TAction.SetCaption(const Value: string);

var

  i: integer;

  c, ss: string;



begin

  i:=Pos(#9, Value);

  if i <> 0 then begin

    c:=Copy(Value, 1, i - 1);

    ss:=Copy(Value, i + 1, MaxInt);

  end

  else begin

    c:=Value;

    ss:='';

  end;

  if (FCaption = c) and (FShortCut = ss) then exit;

  FCaption:=c;

  FShortCut:=ss;

  UpdateControls;

end;



//[procedure TAction.SetChecked]

procedure TAction.SetChecked(const Value: boolean);

begin

  if FChecked = Value then exit;

  FChecked := Value;

  UpdateControls;

end;



//[procedure TAction.SetEnabled]

procedure TAction.SetEnabled(const Value: boolean);

begin

  if FEnabled = Value then exit;

  FEnabled := Value;

  UpdateControls;

end;



//[procedure TAction.SetHelpContext]

procedure TAction.SetHelpContext(const Value: integer);

begin

  if FHelpContext = Value then exit;

  FHelpContext := Value;

  UpdateControls;

end;



//[procedure TAction.SetHint]

procedure TAction.SetHint(const Value: string);

begin

  if FHint = Value then exit;

  FHint := Value;

  UpdateControls;

end;



//[procedure TAction.SetOnExecute]

procedure TAction.SetOnExecute(const Value: TOnEvent);

begin

  if @FOnExecute = @Value then exit;

  FOnExecute:=Value;

  UpdateControls;

end;



//[procedure TAction.SetVisible]

procedure TAction.SetVisible(const Value: boolean);

begin

  if FVisible = Value then exit;

  FVisible := Value;

  UpdateControls;

end;



//[procedure TAction.UpdateControls]

procedure TAction.UpdateControls;

var

  i: integer;

begin

  with FControls{-}^{+} do

    for i:=0 to Count - 1 do

      PControlRec(Items[i]).UpdateProc(Items[i]);

end;



//[procedure TAction.UpdateCtrl]

procedure TAction.UpdateCtrl(Sender: PControlRec);

begin

  with Sender^, PControl(Ctrl){-}^{+} do begin

    if Caption <> Self.FCaption then

      Caption:=Self.FCaption;

    if Enabled <> Self.FEnabled then

      Enabled:=Self.FEnabled;

    if Checked <> Self.FChecked then

      Checked:=Self.FChecked;

    if Visible <> Self.FVisible then

      Visible:=Self.FVisible;

  end;

end;



//[procedure TAction.UpdateMenu]

procedure TAction.UpdateMenu(Sender: PControlRec);

var

  s: string;

begin

  with Sender^, PMenu(Ctrl).Items[ItemID]{-}^{+} do begin

    s:=Self.FCaption;

    if Self.FShortCut <> '' then

      s:=s + #9 + Self.FShortCut;

    if Caption <> s then

      Caption:=s;

    if Enabled <> Self.FEnabled then

      Enabled:=Self.FEnabled;

    if Checked <> Self.FChecked then

      Checked:=Self.FChecked;

    if Visible <> Self.FVisible then

      Visible:=Self.FVisible;

    if HelpContext <> Self.FHelpContext then

      HelpContext:=Self.FHelpContext;

    if Self.FAccelerator.Key <> 0 then {YS}  // Äîáàâèòü

      Accelerator:=Self.FAccelerator;

  end;

end;



//[procedure TAction.UpdateToolbar]

procedure TAction.UpdateToolbar(Sender: PControlRec);

var

  i: integer;

  s: string;

begin

  with Sender^, PControl(Ctrl){-}^{+} do begin

    i:=TBIndex2Item(ItemID);

    s:=TBButtonText[i];

    if (s <> '') and (s <> Self.FCaption) then

      TBButtonText[i]:=Self.FCaption;

    TBSetTooltips(i, [PChar(Self.FHint)]);

    if TBButtonEnabled[ItemID] <> Self.FEnabled then

      TBButtonEnabled[ItemID]:=Self.FEnabled;

    if TBButtonVisible[ItemID] <> Self.FVisible then

      TBButtonVisible[ItemID]:=Self.FVisible;

    if TBButtonChecked[ItemID] <> Self.FChecked then

      TBButtonChecked[ItemID]:=Self.FChecked;

  end;

end;



//[procedure TAction.SetAccelerator]

procedure TAction.SetAccelerator(const Value: TMenuAccelerator);

begin

  if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then exit;

  FAccelerator := Value;

  FShortCut:=GetAcceleratorText(FAccelerator);  // {YS}

  UpdateControls;

end;



{ TActionList }



//[function TActionList.Add]

function TActionList.Add(const ACaption, AHint: string; OnExecute: TOnEvent): PAction;

begin

  Result:=NewAction(ACaption, AHint, OnExecute);

  FActions.Add(Result);

end;



//[procedure TActionList.Clear]

procedure TActionList.Clear;

begin

  while FActions.Count > 0 do

    Delete(0);

  FActions.Clear;  

end;



//[procedure TActionList.Delete]

procedure TActionList.Delete(Idx: integer);

begin

  Actions[Idx].Free;

  FActions.Delete(Idx);

end;



//[destructor TActionList.Destroy]

destructor TActionList.Destroy;

begin

  UnRegisterIdleHandler(DoUpdateActions);

  Clear;

  FActions.Free;

  inherited;

end;



//[procedure TActionList.DoUpdateActions]

procedure TActionList.DoUpdateActions(Sender: PObj);

begin

  if Assigned(FOnUpdateActions) and (GetActiveWindow = FOwner.Handle) then

    FOnUpdateActions(PObj( @Self ));

end;



//[function TActionList.GetActions]

function TActionList.GetActions(Idx: integer): PAction;

begin

  Result:=FActions.Items[Idx];

end;



//[function TActionList.GetCount]

function TActionList.GetCount: integer;

begin

  Result:=FActions.Count;

end;



end.