3636 lines
105 KiB
ObjectPascal
3636 lines
105 KiB
ObjectPascal
//[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.82
|
|
****************************************************************
|
|
//[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 DEFINES]
|
|
{$I KOLDEF.inc}
|
|
{$IFDEF EXTERNAL_KOLDEFS}
|
|
{$INCLUDE PROJECT_KOL_DEFS.INC}
|
|
{$ENDIF}
|
|
{$IFDEF EXTERNAL_DEFINES}
|
|
{$INCLUDE EXTERNAL_DEFINES.INC}
|
|
{$ENDIF EXTERNAL_DEFINES}
|
|
|
|
unit KOLadd;
|
|
|
|
{
|
|
Define symbol TREE_NONAME to disallow using Name in TTree object.
|
|
Define symbol TREE_WIDE to use WideString for Name in TTree object.
|
|
}
|
|
|
|
interface
|
|
|
|
{$I KOLDEF.INC}
|
|
|
|
uses Windows, Messages, 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. }
|
|
procedure InstallBits( FromIdx, N: Integer; Value: Boolean );
|
|
{* Sets new Value for all bits in range [ FromIdx, FromIdx+Count-1 ]. }
|
|
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: PAnsiChar): PAnsiChar;
|
|
protected
|
|
procedure Init; virtual;
|
|
protected
|
|
fList: PList;
|
|
fCount: Integer;
|
|
fCaseSensitiveSort: Boolean;
|
|
fTextBuf: PAnsiChar;
|
|
fTextSiz: DWORD;
|
|
fUsedSiz: DWORD;
|
|
protected
|
|
procedure ProvideSpace( AddSize: DWORD );
|
|
function Get(Idx: integer): AnsiString;
|
|
function GetTextStr: AnsiString;
|
|
procedure Put(Idx: integer; const Value: AnsiString);
|
|
procedure SetTextStr(const Value: AnsiString);
|
|
function GetPChars( Idx: Integer ): PAnsiChar;
|
|
{++}(*public*){--}
|
|
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
|
|
public
|
|
function AddAnsi( const S: AnsiString ): Integer;
|
|
{* Adds Ansi AnsiString to a list. }
|
|
function AddAnsiObject( const S: AnsiString; Obj: DWORD ): Integer;
|
|
{* Adds Ansi AnsiString and correspondent object to a list. }
|
|
function Add(S: PAnsiChar): integer;
|
|
{* Adds a AnsiString to list. }
|
|
function AddLen(S: PAnsiChar; Len: Integer): integer;
|
|
{* Adds a AnsiString to list. The AnsiString can contain #0 characters. }
|
|
public
|
|
FastClear: Boolean;
|
|
{* }
|
|
procedure Clear;
|
|
{* Makes AnsiString list empty. }
|
|
procedure Delete(Idx: integer);
|
|
{* Deletes AnsiString with given index (it *must* exist). }
|
|
function IndexOf(const S: AnsiString): integer;
|
|
{* Returns index of first AnsiString, equal to given one. }
|
|
function IndexOf_NoCase(const S: AnsiString): integer;
|
|
{* Returns index of first AnsiString, equal to given one (while comparing it
|
|
without case sensitivity). }
|
|
function IndexOfStrL_NoCase( Str: PAnsiChar; L: Integer ): integer;
|
|
{* Returns index of first AnsiString, equal to given one (while comparing it
|
|
without case sensitivity). }
|
|
function Find(const S: AnsiString; var Index: Integer): Boolean;
|
|
{* Returns Index of the first AnsiString, equal or greater to given pattern, but
|
|
works only for sorted TFastStrListEx object. Returns TRUE if exact AnsiString found,
|
|
otherwise nearest (greater then a pattern) AnsiString index is returned,
|
|
and the result is FALSE. }
|
|
procedure InsertAnsi(Idx: integer; const S: AnsiString);
|
|
{* Inserts ANSI AnsiString before one with given index. }
|
|
procedure InsertAnsiObject(Idx: integer; const S: AnsiString; Obj: DWORD);
|
|
{* Inserts ANSI AnsiString before one with given index. }
|
|
procedure Insert(Idx: integer; S: PAnsiChar);
|
|
{* Inserts AnsiString before one with given index. }
|
|
procedure InsertLen( Idx: Integer; S: PAnsiChar; Len: Integer );
|
|
{* Inserts AnsiString from given PChar. It can contain #0 characters. }
|
|
function LoadFromFile(const FileName: AnsiString): Boolean;
|
|
{* Loads AnsiString 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 AnsiString list from a stream (from current position to the end of
|
|
a stream). Very fast even for huge text. }
|
|
procedure MergeFromFile(const FileName: AnsiString);
|
|
{* Merges AnsiString list with strings in a file. Fast. }
|
|
procedure Move(CurIndex, NewIndex: integer);
|
|
{* Moves AnsiString to another location. }
|
|
procedure SetText(const S: AnsiString; Append2List: boolean);
|
|
{* Allows to set strings of AnsiString list from given AnsiString (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: AnsiString): Boolean;
|
|
{* Stores AnsiString list to a file. }
|
|
procedure SaveToStream(Stream: PStream);
|
|
{* Saves AnsiString list to a stream (from current position). }
|
|
function AppendToFile(const FileName: AnsiString): Boolean;
|
|
{* Appends strings of AnsiString list to the end of a file. }
|
|
property Count: integer read fCount;
|
|
{* Number of strings in a AnsiString list. }
|
|
property Items[Idx: integer]: AnsiString read Get write Put; default;
|
|
{* Strings array items. If item does not exist, empty AnsiString is returned.
|
|
But for assign to property, AnsiString with given index *must* exist. }
|
|
property ItemPtrs[ Idx: Integer ]: PAnsiChar read GetPChars;
|
|
{* Fast access to item strings as PChars. }
|
|
property ItemLen[ Idx: Integer ]: Integer read GetItemLen;
|
|
{* Length of AnsiString item. }
|
|
function Last: AnsiString;
|
|
{* Last item (or '', if AnsiString list is empty). }
|
|
property Text: AnsiString read GetTextStr write SetTextStr;
|
|
{* Content of AnsiString list as a single AnsiString (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 AnsiString list. }
|
|
public
|
|
function AddObject( S: PAnsiChar; Obj: DWORD ): Integer;
|
|
{* Adds AnsiString S (null-terminated) with associated object Obj. }
|
|
function AddObjectLen( S: PAnsiChar; Len: Integer; Obj: DWORD ): Integer;
|
|
{* Adds AnsiString S of length Len with associated object Obj. }
|
|
procedure InsertObject( Idx: Integer; S: PAnsiChar; Obj: DWORD );
|
|
{* Inserts AnsiString S (null-terminated) at position Idx in the list,
|
|
associating it with object Obj. }
|
|
procedure InsertObjectLen( Idx: Integer; S: PAnsiChar; Len: Integer; Obj: DWORD );
|
|
{* Inserts AnsiString 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: PAnsiChar );
|
|
{* Appends S (null-terminated) to the last AnsiString in FastStrListEx object, very fast. }
|
|
procedure AppendLen( S: PAnsiChar; Len: Integer );
|
|
{* Appends S of length Len to the last AnsiString in FastStrListEx object, very fast. }
|
|
procedure AppendInt2Hex( N: DWORD; MinDigits: Integer );
|
|
{* Converts N to hexadecimal and appends resulting AnsiString to the last
|
|
AnsiString, very fast. }
|
|
public
|
|
property Values[ Name: PAnsiChar ]: PAnsiChar read GetValues;
|
|
{* Returns a value correspondent to the Name an ini-file-like AnsiString list
|
|
(having Name1=Value1 Name2=Value2 etc. in each AnsiString). }
|
|
function IndexOfName( AName: PAnsiChar ): Integer;
|
|
{* Searches AnsiString starting from 'AName=' in AnsiString list like ini-file. }
|
|
end;
|
|
|
|
function NewFastStrListEx: PFastStrListEx;
|
|
{* Creates FastStrListEx object. }
|
|
|
|
var Upper: array[ Char ] of AnsiChar;
|
|
{* 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. }
|
|
|
|
//[CABINET FILES OBJECT]
|
|
type
|
|
{++}(*TCabFile = class;*){--}
|
|
PCABFile = {-}^{+}TCABFile;
|
|
|
|
TOnNextCAB = function( Sender: PCABFile ): KOLString of object;
|
|
TOnCABFile = function( Sender: PCABFile; var FileName: KOLString ): 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: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
|
|
FNames: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
|
|
FOnNextCAB: TOnNextCAB;
|
|
FOnFile: TOnCABFile;
|
|
FTargetPath: KOLString;
|
|
FSetupapi: THandle;
|
|
function GetNames(Idx: Integer): KOLString;
|
|
function GetCount: Integer;
|
|
function GetPaths(Idx: Integer): KOLString;
|
|
function GetTargetPath: KOLString;
|
|
protected
|
|
FGettingNames: Boolean;
|
|
FCurCAB: Integer;
|
|
public
|
|
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
|
|
{* }
|
|
property Paths[ Idx: Integer ]: KOLString read GetPaths;
|
|
{* A list of CAB-files. It is stored, when constructing function
|
|
OpenCABFile called. }
|
|
property Names[ Idx: Integer ]: KOLString 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 AnsiString '?' ), 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 '?' AnsiString).
|
|
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: KOLString 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 AnsiString ): 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 '?'
|
|
AnsiString 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: KOLString) 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, FinEvent: THandle;
|
|
FPath: KOLString;
|
|
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: KOLString read FPath; //write SetPath;
|
|
{* Path to monitored folder (to a root, if tree of folders
|
|
is under monitoring). }
|
|
property OnChange: TOnDirChange read FOnChange write FOnChange;
|
|
end;
|
|
//[END OF TDirChange DEFINITION]
|
|
|
|
//[NewDirChangeNotifier DECLARATION]
|
|
function NewDirChangeNotifier( const Path: KOLString; Filter: TFileChangeFilter;
|
|
WatchSubtree: Boolean; ChangeProc: TOnDirChange ): PDirChange;
|
|
{* Creates notification object TDirChange. 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: AnsiString ): 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: PAnsiChar): 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: KOLString;
|
|
FChecked: boolean;
|
|
FVisible: boolean;
|
|
FEnabled: boolean;
|
|
FHelpContext: integer;
|
|
FHint: KOLString;
|
|
FOnExecute: TOnEvent;
|
|
FAccelerator: TMenuAccelerator;
|
|
FShortCut: KOLString;
|
|
procedure DoOnMenuItem(Sender: PMenu; Item: Integer);
|
|
procedure DoOnToolbarButtonClick(Sender: PControl; BtnID: Integer);
|
|
procedure DoOnControlClick(Sender: PObj);
|
|
|
|
procedure SetCaption(const Value: KOLString);
|
|
procedure SetChecked(const Value: boolean);
|
|
procedure SetEnabled(const Value: boolean);
|
|
procedure SetHelpContext(const Value: integer);
|
|
procedure SetHint(const Value: KOLString);
|
|
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: KOLString read FCaption write SetCaption;
|
|
{* Text caption. }
|
|
property Hint: KOLString 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: KOLString; 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. }
|
|
|
|
{ -- tree (non-visual) -- }
|
|
|
|
type
|
|
//[TTree DEFINITION]
|
|
{++}(*TTree = class;*){--}
|
|
PTree = {-}^{+}TTree;
|
|
TTree = object( TObj )
|
|
{* Object to store tree-like data in memory (non-visual). }
|
|
protected
|
|
fParent: PTree;
|
|
fChildren: PList;
|
|
fPrev: PTree;
|
|
fNext: PTree;
|
|
{$IFDEF TREE_NONAME}
|
|
{$ELSE}
|
|
{$IFDEF TREE_WIDE}
|
|
fNodeName: WideString;
|
|
{$ELSE}
|
|
fNodeName: AnsiString;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
fData: Pointer;
|
|
function GetCount: Integer;
|
|
function GetItems(Idx: Integer): PTree;
|
|
procedure Unlink;
|
|
function GetRoot: PTree;
|
|
function GetLevel: Integer;
|
|
function GetTotal: Integer;
|
|
function GetIndexAmongSiblings: Integer;
|
|
protected
|
|
{$IFDEF USE_CONSTRUCTORS}
|
|
constructor CreateTree( AParent: PTree; const AName: AnsiString );
|
|
{* }
|
|
{$ENDIF}
|
|
{++}(*public*){--}
|
|
destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
|
|
{* }
|
|
{++}(*protected*){--}
|
|
procedure Init; {-}virtual;{+}{++}(*override;*){--}
|
|
public
|
|
procedure Clear;
|
|
{* Destoyes all child nodes. }
|
|
{$IFDEF TREE_NONAME}
|
|
{$ELSE}
|
|
{$IFDEF TREE_WIDE}
|
|
property Name: WideString read fNodeName write fNodeName;
|
|
{$ELSE}
|
|
property Name: AnsiString read fNodeName write fNodeName;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{* Optional node name. }
|
|
property Data: Pointer read fData write fData;
|
|
{* Optional user-defined pointer. }
|
|
property Count: Integer read GetCount;
|
|
{* Number of child nodes of given node. }
|
|
property Items[ Idx: Integer ]: PTree read GetItems;
|
|
{* Child nodes list items. }
|
|
procedure Add( Node: PTree );
|
|
{* Adds another node as a child of given tree node. This operation
|
|
as well as Insert can be used to move node together with its children
|
|
to another location of the same tree or even from another tree.
|
|
Anyway, added Node first correctly removed from old place (if it is
|
|
defined for it). But for simplest task, such as filling of tree with
|
|
nodes, code should looking as follows:
|
|
! Node := NewTree( nil, 'test of creating node without parent' );
|
|
! RootOfMyTree.Add( Node );
|
|
Though, this code gives the same result as:
|
|
! Node := NewTree( RootOfMyTree, 'test of creatign node as a child' ); }
|
|
procedure Insert( Before, Node: PTree );
|
|
{* Inserts earlier created 'Node' just before given child node 'Before'
|
|
as a child of given tree node. See also Add method. }
|
|
property Parent: PTree read fParent;
|
|
{* Returns parent node (or nil, if there is no parent). }
|
|
property Index: Integer read GetIndexAmongSiblings;
|
|
{* Returns an index of the node in a list of nodes of the same parent
|
|
(or -1, if Parent is not defined). }
|
|
property PrevSibling: PTree read fPrev;
|
|
{* Returns previous node in a list of children of the Parent. Nil is
|
|
returned, if given node is the first child of the Parent or has
|
|
no Parent. }
|
|
property NextSibling: PTree read fNext;
|
|
{* Returns next node in a list of children of the Parent. Nil is returned,
|
|
if given node is the last child of the Parent or has no Parent at all. }
|
|
property Root: PTree read GetRoot;
|
|
{* Returns root node (i.e. the last Parent, enumerating parents recursively). }
|
|
property Level: Integer read GetLevel;
|
|
{* Returns level of the node, i.e. integer value, equal to 0 for root
|
|
of a tree, 1 for its children, etc. }
|
|
property Total: Integer read GetTotal;
|
|
{* Returns total number of children of the node and all its children
|
|
counting its recursively (but node itself is not considered, i.e.
|
|
Total for node without children is equal to 0). }
|
|
procedure SortByName;
|
|
{* Sorts children of the node in ascending order. Sorting is not
|
|
recursive, i.e. only immediate children are sorted. }
|
|
procedure SwapNodes( i1, i2: Integer );
|
|
{* Swaps two child nodes. }
|
|
function IsParentOfNode( Node: PTree ): Boolean;
|
|
{* Returns true, if Node is the tree itself or is a parent of the given node
|
|
on any level. }
|
|
function IndexOf( Node: PTree ): Integer;
|
|
{* Total index of the child node (on any level under this node). }
|
|
|
|
end;
|
|
//[END OF TTree DEFINITION]
|
|
|
|
//[NewTree DECLARATION]
|
|
{$IFDEF TREE_NONAME}
|
|
function NewTree( AParent: PTree ): PTree;
|
|
{* Nameless version (for case when TREE_NONAME symbol is defined).
|
|
Constructs tree node, adding it to the end of children list of
|
|
the AParent. If AParent is nil, new root tree node is created. }
|
|
{$ELSE}
|
|
{$IFDEF TREE_WIDE}
|
|
function NewTree( AParent: PTree; const AName: WideString ): PTree;
|
|
{* WideString version (for case when TREE_WIDE symbol is defined).
|
|
Constructs tree node, adding it to the end of children list of
|
|
the AParent. If AParent is nil, new root tree node is created. }
|
|
{$ELSE}
|
|
function NewTree( AParent: PTree; const AName: AnsiString ): PTree;
|
|
{* Constructs tree node, adding it to the end of children list of
|
|
the AParent. If AParent is nil, new root tree node is created. }
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
|
|
{-------------------------------------------------------------------------------
|
|
ADDITIONAL UTILITIES
|
|
}
|
|
|
|
function MapFileRead( const Filename: AnsiString; var hFile, hMap: THandle ): Pointer;
|
|
{* Opens file for read only (with share deny none attribute) and maps its
|
|
entire content using memory mapped files technique. The address of the
|
|
first byte of file mapped into the application address space is returned.
|
|
When mapping no more needed, it must be closed calling UnmapFile (see below).
|
|
Maximum file size which can be mapped at a time is 1/4 Gigabytes. If file size
|
|
exceeding this value only 1/4 Gigabytes starting from the beginning of the
|
|
file is mapped therefore. }
|
|
|
|
function MapFile( const Filename: AnsiString; var hFile, hMap: THandle ): Pointer;
|
|
{* Opens file for read/write (in exlusive mode) and maps its
|
|
entire content using memory mapped files technique. The address of the
|
|
first byte of file mapped into the application address space is returned.
|
|
When mapping no more needed, it must be closed calling UnmapFile (see below). }
|
|
|
|
procedure UnmapFile( BasePtr: Pointer; hFile, hMap: THandle );
|
|
{* Closes mapping opened via MapFile or MapFileRead call. }
|
|
|
|
//------------------------ for MCK projects:
|
|
{$IFDEF KOL_MCK}
|
|
type
|
|
TKOLAction = PAction;
|
|
TKOLActionList = PActionList;
|
|
{$ENDIF}
|
|
|
|
function ShowQuestion( const S: KOLString; Answers: KOLString ): Integer;
|
|
{* Modal dialog like ShowMsgModal. It is based on KOL form, so it can
|
|
be called also out of message loop, e.g. after finishing the
|
|
application. Also, this function *must* be used in MDI applications
|
|
in place of any dialog functions, based on MessageBox.
|
|
|<br>
|
|
The second parameter should be empty AnsiString or several possible
|
|
answers separated by '/', e.g.: 'Yes/No/Cancel'. Result is
|
|
a number answered, starting from 1. For example, if 'Cancel'
|
|
was pressed, 3 will be returned.
|
|
|<br>
|
|
User can also press ESCAPE key, or close modal dialog. In such case
|
|
-1 is returned. }
|
|
function ShowQuestionEx( S: KOLString; Answers: KOLString; CallBack: TOnEvent ): Integer;
|
|
{* Like ShowQuestion, but with CallBack function, called just before showing
|
|
the dialog. }
|
|
procedure ShowMsgModal( const S: KOLString );
|
|
{* This message function can be used out of a message loop (e.g., after
|
|
finishing the application). It is always modal.
|
|
Actually, a form with word-wrap label (decorated as borderless edit
|
|
box with btnFace color) and with OK button is created and shown modal.
|
|
When a dialog is called from outside message loop, caption 'Information'
|
|
is always displayed.
|
|
Dialog form is automatically resized vertically to fit message text
|
|
(but until screen height is achieved) and shown always centered on
|
|
screen. The width is fixed (400 pixels).
|
|
|<br>
|
|
Do not use this function outside the message loop for case, when the
|
|
Applet variable is not used in an application. }
|
|
|
|
implementation
|
|
|
|
//uses
|
|
//ShellAPI,
|
|
//shlobj,
|
|
//{$IFNDEF _D2}ActiveX,{$ENDIF}
|
|
// CommDlg
|
|
{$IFDEF USE_GRUSH}uses ToGrush; {$ENDIF}
|
|
|
|
{------------------------------------------------------------------------------)
|
|
| |
|
|
| 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 }
|
|
|
|
type
|
|
PBitsList = ^TBitsList;
|
|
TBitsList = object( TList )
|
|
end;
|
|
|
|
|
|
//[function NewBits]
|
|
function NewBits: PBits;
|
|
begin
|
|
{-}
|
|
new( Result, Create );
|
|
{+}{++}(*Result := PBits.Create;*){--}
|
|
Result.fList := NewList;
|
|
{$IFDEF TLIST_FAST} Result.fList.UseBlocks:= False; {$ENDIF}
|
|
//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 );
|
|
PBitsList( 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( PBitsList( FromBits.fList ).fItems ) + (FromIdx + 31) div 32 )^,
|
|
PByte( Integer( PBitsList( 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( PBitsList( fList ).fItems[ From shr 5 ],
|
|
PBitsList( Result.fList ).fItems[ 0 ], (Count + 31) div 32 );
|
|
Shift := From and $1F;
|
|
if Shift <> 1 then
|
|
begin
|
|
N := (BitsCount + 31) div 32;
|
|
FirstItemPtr := @ PBitsList( 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].TBitsList.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( PBitsList( 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 := ( PBitsList( 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( PBitsList( 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 PBitsList( fList ).fCount-1 do
|
|
begin
|
|
D := DWORD( PBitsList( 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]
|
|
procedure TBits.InstallBits(FromIdx, N: Integer; Value: Boolean);
|
|
var NewCount: Integer;
|
|
begin
|
|
if FromIdx + N > fCount then
|
|
begin
|
|
Capacity := (FromIdx + N + 8) div 8;
|
|
fCount := FromIdx + N - 1;
|
|
end;
|
|
NewCount := Max( Count, FromIdx + N - 1 );
|
|
fCount := Max( NewCount, fCount );
|
|
PBitsList( fList ).fCount := (Capacity + 3) div 4;
|
|
while FromIdx and $1F <> 0 do
|
|
begin
|
|
Bits[ FromIdx ] := Value;
|
|
Inc( FromIdx );
|
|
Dec( N );
|
|
if N = 0 then Exit;
|
|
end;
|
|
FillChar( PByte( Integer( PBitsList( fList ).fItems ) + FromIdx div 32 )^,
|
|
(N + 7) div 8, Char( -Integer( Value ) ) );
|
|
end;
|
|
|
|
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( PBitsList( 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( PBitsList( 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].TBitsList.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].TBitsList.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
|
|
PBitsList( fList ).fItems[ Idx shr 5 ] := Pointer(
|
|
DWORD(PBitsList( fList ).fItems[ Idx shr 5 ]) or Msk)
|
|
else
|
|
PBitsList( fList ).fItems[ Idx shr 5 ] := Pointer(
|
|
DWORD(PBitsList( 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( PAnsiChar( Integer( PBitsList( 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: AnsiChar;
|
|
begin
|
|
for c := #0 to #255 do
|
|
Upper[ c ] := AnsiUpperCase( AnsiString(c + #0) )[ 1 ];
|
|
Upper_Initialized := TRUE;
|
|
end;
|
|
|
|
{ TFastStrListEx }
|
|
|
|
function TFastStrListEx.AddAnsi(const S: AnsiString): Integer;
|
|
begin
|
|
Result := AddObjectLen( PAnsiChar( S ), Length( S ), 0 );
|
|
end;
|
|
|
|
function TFastStrListEx.AddAnsiObject(const S: AnsiString; Obj: DWORD): Integer;
|
|
begin
|
|
Result := AddObjectLen( PAnsiChar( S ), Length( S ), Obj );
|
|
end;
|
|
|
|
function TFastStrListEx.Add(S: PAnsiChar): integer;
|
|
begin
|
|
Result := AddObjectLen( S, StrLen( S ), 0 )
|
|
end;
|
|
|
|
function TFastStrListEx.AddLen(S: PAnsiChar; Len: Integer): integer;
|
|
begin
|
|
Result := AddObjectLen( S, Len, 0 )
|
|
end;
|
|
|
|
function TFastStrListEx.AddObject(S: PAnsiChar; Obj: DWORD): Integer;
|
|
begin
|
|
Result := AddObjectLen( S, StrLen( S ), Obj )
|
|
end;
|
|
|
|
function TFastStrListEx.AddObjectLen(S: PAnsiChar; Len: Integer; Obj: DWORD): Integer;
|
|
var Dest: PAnsiChar;
|
|
begin
|
|
ProvideSpace( Len + 9 );
|
|
Dest := PAnsiChar( 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: AnsiString): Boolean;
|
|
var F: HFile;
|
|
Txt: AnsiString;
|
|
begin
|
|
Txt := Text;
|
|
F := FileCreate( KOLString(FileName), ofOpenAlways or ofOpenReadWrite or ofShareDenyWrite );
|
|
if F = INVALID_HANDLE_VALUE then Result := FALSE
|
|
else begin
|
|
FileSeek( F, 0, spEnd );
|
|
Result := FileWrite( F, PAnsiChar( Txt )^, Length( Txt ) ) = DWORD( Length( Txt ) );
|
|
FileClose( F );
|
|
end;
|
|
end;
|
|
|
|
procedure TFastStrListEx.Clear;
|
|
begin
|
|
if FastClear then
|
|
begin
|
|
if fList.Count > 0 then
|
|
fList.Count := 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: AnsiString; 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): AnsiString;
|
|
begin
|
|
if (Idx >= 0) and (Idx <= Count) then
|
|
SetString( Result, PAnsiChar( 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): PAnsiChar;
|
|
begin
|
|
if (Idx >= 0) and (Idx <= Count) then
|
|
Result := PAnsiChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 8 )
|
|
else Result := nil;
|
|
end;
|
|
|
|
function TFastStrListEx.GetTextStr: AnsiString;
|
|
var L, i: Integer;
|
|
p: PAnsiChar;
|
|
begin
|
|
L := 0;
|
|
for i := 0 to Count-1 do
|
|
Inc( L, ItemLen[ i ] + 2 );
|
|
SetLength( Result, L );
|
|
p := PAnsiChar( 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: AnsiString): integer;
|
|
begin
|
|
if not Find( S, Result ) then Result := -1;
|
|
end;
|
|
|
|
function TFastStrListEx.IndexOf_NoCase(const S: AnsiString): integer;
|
|
begin
|
|
Result := IndexOfStrL_NoCase( PAnsiChar( S ), Length( S ) );
|
|
end;
|
|
|
|
function TFastStrListEx.IndexOfStrL_NoCase(Str: PAnsiChar;
|
|
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: AnsiString);
|
|
begin
|
|
InsertObjectLen( Idx, PAnsiChar( S ), Length( S ), 0 );
|
|
end;
|
|
|
|
procedure TFastStrListEx.InsertAnsiObject(Idx: integer; const S: AnsiString;
|
|
Obj: DWORD);
|
|
begin
|
|
InsertObjectLen( Idx, PAnsiChar( S ), Length( S ), Obj );
|
|
end;
|
|
|
|
procedure TFastStrListEx.Insert(Idx: integer; S: PAnsiChar);
|
|
begin
|
|
InsertObjectLen( Idx, S, StrLen( S ), 0 )
|
|
end;
|
|
|
|
procedure TFastStrListEx.InsertLen(Idx: Integer; S: PAnsiChar; Len: Integer);
|
|
begin
|
|
InsertObjectLen( Idx, S, Len, 0 )
|
|
end;
|
|
|
|
procedure TFastStrListEx.InsertObject(Idx: Integer; S: PAnsiChar; Obj: DWORD);
|
|
begin
|
|
InsertObjectLen( Idx, S, StrLen( S ), Obj );
|
|
end;
|
|
|
|
procedure TFastStrListEx.InsertObjectLen(Idx: Integer; S: PAnsiChar;
|
|
Len: Integer; Obj: DWORD);
|
|
var Dest: PAnsiChar;
|
|
begin
|
|
ProvideSpace( Len+9 );
|
|
Dest := PAnsiChar( 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: AnsiString;
|
|
begin
|
|
if Count > 0 then
|
|
Result := Items[ Count-1 ]
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
function TFastStrListEx.LoadFromFile(const FileName: AnsiString): Boolean;
|
|
var Strm: PStream;
|
|
begin
|
|
Strm := NewReadFileStream( KOLString(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: AnsiString;
|
|
begin
|
|
SetLength( Txt, Stream.Size - Stream.Position );
|
|
Stream.Read( Txt[ 1 ], Stream.Size - Stream.Position );
|
|
SetText( Txt, Append2List );
|
|
end;
|
|
|
|
procedure TFastStrListEx.MergeFromFile(const FileName: AnsiString);
|
|
var Strm: PStream;
|
|
begin
|
|
Strm := NewReadFileStream( KOLString(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: PAnsiChar;
|
|
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: AnsiString);
|
|
var Dest: PAnsiChar;
|
|
OldLen: Integer;
|
|
OldObj: DWORD;
|
|
begin
|
|
OldLen := ItemLen[ Idx ];
|
|
if Length( Value ) <= OldLen then
|
|
begin
|
|
Dest := PAnsiChar( 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( PAnsiChar( Value ), Length( Value ), OldObj )
|
|
else
|
|
begin
|
|
ProvideSpace( Length( Value ) + 9 );
|
|
Dest := PAnsiChar( 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: AnsiString): Boolean;
|
|
var Strm: PStream;
|
|
begin
|
|
Strm := NewWriteFileStream( KOLString(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: AnsiString;
|
|
begin
|
|
Txt := Text;
|
|
Stream.Write( PAnsiChar( 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: AnsiString; Append2List: boolean);
|
|
var Len2Add, NLines, L: Integer;
|
|
p0, p: PAnsiChar;
|
|
begin
|
|
if not Append2List then Clear;
|
|
// ������?���������� ������������
|
|
Len2Add := 0;
|
|
NLines := 0;
|
|
p := PAnsichar( 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 := PAnsiChar( 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: AnsiString);
|
|
begin
|
|
SetText( Value, FALSE );
|
|
end;
|
|
|
|
function CompareFast(const Data: Pointer; const e1,e2 : Dword) : Integer;
|
|
var FSL: PFastStrListEx;
|
|
L1, L2: Integer;
|
|
S1, S2: PAnsiChar;
|
|
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: PAnsiChar): PAnsiChar;
|
|
var i: Integer;
|
|
s, n: PAnsiChar;
|
|
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: PAnsiChar): Integer;
|
|
var i: Integer;
|
|
s, n: PAnsiChar;
|
|
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: PAnsiChar);
|
|
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: PAnsiChar; Len: Integer);
|
|
var Dest: PAnsiChar;
|
|
begin
|
|
if Count = 0 then
|
|
AddLen( S, Len )
|
|
else
|
|
begin
|
|
ProvideSpace( Len );
|
|
Dest := PAnsiChar( DWORD( fTextBuf ) + fUsedSiz - 1 );
|
|
System.Move( S^, Dest^, Len );
|
|
Inc( Dest, Len );
|
|
Dest^ := #0;
|
|
Inc( fUsedSiz, Len );
|
|
Dest := PAnsiChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Count-1 ] ) );
|
|
Inc( Dest, 4 );
|
|
PDWORD( Dest )^ := PDWORD( Dest )^ + DWORD( Len );
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TCABFile }
|
|
|
|
//[function OpenCABFile]
|
|
function OpenCABFile( const APaths: array of AnsiString ): PCABFile;
|
|
var I: Integer;
|
|
begin
|
|
{-}
|
|
New( Result, Create );
|
|
{+}{++}(*Result := PCABFile.Create;*){--}
|
|
Result.FSetupapi := LoadLibrary( 'setupapi.dll' );
|
|
Result.FNames := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
|
|
Result.FPaths := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
|
|
for I := 0 to High( APaths ) do
|
|
Result.FPaths.Add( KOLString(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: PKOLChar; 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: PKOLChar; // optional, title of the dialog box
|
|
DiskName: PKOLChar; // optional, name of disk to insert
|
|
PathToSource: PKOLChar;// optional, expected source path
|
|
FileSought: PKOLChar; // name of file needed
|
|
TagFile: PKOLChar; // optional, source media tag file
|
|
DiskPromptStyle: DWORD; // specifies dialog box behavior
|
|
PathBuffer: PKOLChar; // 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: PKOLChar;
|
|
CabinetFile: PKOLChar;
|
|
DiskName: PKOLChar;
|
|
SetId: WORD;
|
|
CabinetNumber: WORD;
|
|
end;
|
|
PCabinetInfo = ^TCabinetInfo;
|
|
|
|
TFileInCabinetInfo = packed record
|
|
NameInCabinet: PKOLChar;
|
|
FileSize: DWORD;
|
|
Win32Error: DWORD;
|
|
DosDate: WORD;
|
|
DosTime: WORD;
|
|
DosAttribs: WORD;
|
|
FullTargetName: array[0..MAX_PATH-1] of KOLChar;
|
|
end;
|
|
PFileInCabinetInfo = ^TFileInCabinetInfo;
|
|
|
|
//[function CABCallback]
|
|
function CABCallback( Context: Pointer; Notification, Param1, Param2: DWORD ): DWORD;
|
|
stdcall;
|
|
var CAB: PCABFile;
|
|
CABPath, OldPath: KOLString;
|
|
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, PKOLChar( ExtractFilePath( OldPath ) ),
|
|
CABInfo.CabinetFile, nil, 2 {IDF_NOSKIP}, @CabPath[ 1 ], MAX_PATH, nil );
|
|
case hr of
|
|
0: // success
|
|
begin
|
|
{$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
|
|
( PKOLChar( Param2 ), PKOLChar( CABPath ) );
|
|
Result := 0;
|
|
end;
|
|
2: // skip file
|
|
Result := 0;
|
|
else // cancel
|
|
Result := ERROR_FILE_NOT_FOUND;
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
|
|
( PKOLChar( Param2 ), PKOLChar( 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;
|
|
{$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
|
|
( @CABFileInfo.FullTargetName[ 0 ], PKOLChar( CABPath ) );
|
|
Result := 1; // FILEOP_DOIT
|
|
end
|
|
else
|
|
Result := 2
|
|
end
|
|
else
|
|
begin
|
|
if CAB.FTargetPath <> '' then
|
|
{$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
|
|
( @CABFileInfo.FullTargetName[ 0 ],
|
|
PKOLChar( 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( PKOLChar( KOLString( 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): KOLString;
|
|
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): KOLString;
|
|
begin
|
|
Result := FPaths.Items[ Idx ];
|
|
end;
|
|
|
|
//[function TCABFile.GetTargetPath]
|
|
function TCABFile.GetTargetPath: KOLString;
|
|
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: AnsiString; 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.Destroy
|
|
@@exit:
|
|
XCHG EAX, EBX
|
|
POP EBX
|
|
end;
|
|
{$ELSE ASM_VERSION} //Pascal
|
|
function NewDirChangeNotifier( const Path: KOLString; 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.FinEvent := CreateEvent( nil, TRUE, FALSE, nil );
|
|
Result.FHandle := FindFirstChangeNotification(PKOLChar(Result.FPath),
|
|
Bool( Integer( WatchSubtree ) ), Flags);
|
|
if Result.FHandle <> INVALID_HANDLE_VALUE then
|
|
Result.FMonitor := NewThreadAutoFree( 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].FOnChange.TMethod.Code
|
|
JECXZ @@exit
|
|
MOV ECX, [EAX].FPath
|
|
XCHG EDX, EAX
|
|
MOV EAX, [EDX].FOnChange.TMethod.Data
|
|
CALL [EDX].FOnChange.TMethod.Code
|
|
@@exit:
|
|
end;
|
|
{$ELSE ASM_VERSION} //Pascal
|
|
procedure TDirChange.Changed;
|
|
begin
|
|
if Assigned( FOnChange ) then
|
|
FOnChange(@Self, FPath);
|
|
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.Destroy
|
|
@@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 FHandle > 0 then // FHandle <> INVALID_HANDLE_VALUE AND FHandle <> 0
|
|
begin
|
|
OnChange := nil;
|
|
SetEvent( FinEvent );
|
|
end;
|
|
//if FMonitor <> nil then
|
|
// FMonitor.Free;
|
|
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;
|
|
var Handles: array[ 0..1 ] of THandle;
|
|
//i: Integer;
|
|
begin
|
|
Handles[ 0 ] := FHandle;
|
|
Handles[ 1 ] := FinEvent;
|
|
while TRUE do
|
|
case WaitForMultipleObjects(2, @ Handles[ 0 ], FALSE, INFINITE) of
|
|
WAIT_OBJECT_0:
|
|
begin
|
|
if AppletTerminated then break;
|
|
Applet.GetWindowHandle;
|
|
Sender.Synchronize( Changed );
|
|
FindNextChangeNotification(Handles[ 0 ]);
|
|
{for i := 1 to 10 do
|
|
begin
|
|
Sleep( 10 );
|
|
if AppletTerminated then break;
|
|
end;}
|
|
end;
|
|
else break;
|
|
end;
|
|
{$IFDEF SAFE_CODE}
|
|
TRY
|
|
{$ENDIF}
|
|
FindCloseChangeNotification( Handles[ 0 ] );
|
|
CloseHandle( Handles[ 1 ] );
|
|
{$IFDEF SAFE_CODE}
|
|
EXCEPT
|
|
END;
|
|
{$ENDIF}
|
|
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;
|
|
//Result := fHeader.rclFrame.Bottom - fHeader.rclFrame.Top;
|
|
end;
|
|
|
|
//[function TMetafile.GetWidth]
|
|
function TMetafile.GetWidth: Integer;
|
|
begin
|
|
Result := 0;
|
|
if Empty then Exit;
|
|
RetrieveHeader;
|
|
Result := fHeader.rclBounds.Right - fHeader.rclBounds.Left;
|
|
//Result := fHeader.rclFrame.Right - fHeader.rclFrame.Left;
|
|
end;
|
|
|
|
//[function TMetafile.LoadFromFile]
|
|
function TMetafile.LoadFromFile(const Filename: AnsiString): Boolean;
|
|
var Strm: PStream;
|
|
begin
|
|
Strm := NewReadFileStream( KOLString(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
|
|
begin
|
|
SzHdr := GetEnhMetaFileHeader( fHandle, 0, nil );
|
|
fHeader := AllocMem( { SzHeader } Sizeof( fHeader^ ) );
|
|
fHeader.iType := EMR_HEADER;
|
|
fHeader.nSize := Sizeof( fHeader^ ) { SzHdr };
|
|
GetEnhMetaFileHeader( fHandle, SzHdr, fHeader );
|
|
end;
|
|
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 );
|
|
{if not PlayEnhMetaFile( DC, fHandle, R ) then
|
|
begin
|
|
ShowMessage( SysErrorMessage( GetLastError ) );
|
|
end;}
|
|
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: KOLString; 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: KOLstring);
|
|
var
|
|
i: integer;
|
|
c, ss: KOLstring;
|
|
|
|
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: KOLString);
|
|
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: KOLstring;
|
|
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: KOLString;
|
|
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, [PKOLChar(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: KOLstring; 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;
|
|
|
|
{ -- TTree -- }
|
|
|
|
{$IFDEF USE_CONSTRUCTORS}
|
|
//[function NewTree]
|
|
function NewTree( AParent: PTree; const AName: AnsiString ): PTree;
|
|
begin
|
|
New( Result, CreateTree( AParent, AName ) );
|
|
end;
|
|
//[END NewTree]
|
|
{$ELSE not_USE_CONSTRUCTORS}
|
|
//[function NewTree]
|
|
{$IFDEF TREE_NONAME}
|
|
function NewTree( AParent: PTree ): PTree;
|
|
begin
|
|
{-}
|
|
New( Result, Create );
|
|
{+}{++}(*Result := PTree.Create;*){--}
|
|
if AParent <> nil then
|
|
AParent.Add( Result );
|
|
Result.fParent := AParent;
|
|
end;
|
|
{$ELSE}
|
|
{$IFDEF TREE_WIDE}
|
|
function NewTree( AParent: PTree; const AName: WideString ): PTree;
|
|
begin
|
|
{-}
|
|
New( Result, Create );
|
|
{+}{++}(*Result := PTree.Create;*){--}
|
|
if AParent <> nil then
|
|
AParent.Add( Result );
|
|
Result.fParent := AParent;
|
|
Result.fNodeName := AName;
|
|
end;
|
|
{$ELSE}
|
|
function NewTree( AParent: PTree; const AName: AnsiString ): PTree;
|
|
begin
|
|
{-}
|
|
New( Result, Create );
|
|
{+}{++}(*Result := PTree.Create;*){--}
|
|
if AParent <> nil then
|
|
AParent.Add( Result );
|
|
Result.fParent := AParent;
|
|
Result.fNodeName := AName;
|
|
end;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
//[END NewTree]
|
|
{$ENDIF USE_CONSTRUCTORS}
|
|
|
|
{ TTree }
|
|
|
|
//[procedure TTree.Add]
|
|
procedure TTree.Add(Node: PTree);
|
|
var Previous: PTree;
|
|
begin
|
|
Node.Unlink;
|
|
if fChildren = nil then begin
|
|
fChildren := NewList;
|
|
end;
|
|
Previous := nil;
|
|
if fChildren.Count > 0 then
|
|
Previous := fChildren.Items[ fChildren.Count - 1 ];
|
|
if Previous <> nil then
|
|
begin
|
|
Previous.fNext := Node;
|
|
Node.fPrev := Previous;
|
|
end;
|
|
fChildren.Add( Node );
|
|
Node.fParent := @Self;
|
|
end;
|
|
|
|
//[procedure TTree.Clear]
|
|
procedure TTree.Clear;
|
|
var I: Integer;
|
|
begin
|
|
if fChildren = nil then Exit;
|
|
for I := fChildren.Count - 1 downto 0 do
|
|
PTree( fChildren.Items[ I ] ).Free;
|
|
end;
|
|
|
|
{$IFDEF USE_CONSTRUCTORS}
|
|
//[constructor TTree.CreateTree]
|
|
constructor TTree.CreateTree(AParent: PTree; const AName: AnsiString);
|
|
begin
|
|
inherited Create;
|
|
if AParent <> nil then
|
|
AParent.Add( @Self );
|
|
fParent := AParent;
|
|
fName := AName;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
//[destructor TTree.Destroy]
|
|
destructor TTree.Destroy;
|
|
begin
|
|
Unlink;
|
|
Clear;
|
|
{$IFDEF TREE_NONAME}
|
|
{$ELSE}
|
|
fNodeName := '';
|
|
{$ENDIF}
|
|
inherited;
|
|
end;
|
|
|
|
//[function TTree.GetCount]
|
|
function TTree.GetCount: Integer;
|
|
begin
|
|
Result := 0;
|
|
if fChildren = nil then Exit;
|
|
Result := fChildren.Count;
|
|
end;
|
|
|
|
//[function TTree.GetIndexAmongSiblings]
|
|
function TTree.GetIndexAmongSiblings: Integer;
|
|
begin
|
|
Result := -1;
|
|
if fParent = nil then Exit;
|
|
Result := fParent.fChildren.IndexOf( @Self );
|
|
end;
|
|
|
|
//[function TTree.GetItems]
|
|
function TTree.GetItems(Idx: Integer): PTree;
|
|
begin
|
|
Result := nil;
|
|
if fChildren = nil then Exit;
|
|
Result := fChildren.Items[ Idx ];
|
|
end;
|
|
|
|
//[function TTree.GetLevel]
|
|
function TTree.GetLevel: Integer;
|
|
var Node: PTree;
|
|
begin
|
|
Result := 0;
|
|
Node := fParent;
|
|
while Node <> nil do
|
|
begin
|
|
Inc( Result );
|
|
Node := Node.fParent;
|
|
end;
|
|
end;
|
|
|
|
//[function TTree.GetRoot]
|
|
function TTree.GetRoot: PTree;
|
|
begin
|
|
Result := @Self;
|
|
while Result.fParent <> nil do
|
|
Result := Result.fParent;
|
|
end;
|
|
|
|
//[function TTree.GetTotal]
|
|
function TTree.GetTotal: Integer;
|
|
var I: Integer;
|
|
begin
|
|
Result := Count;
|
|
if Result <> 0 then
|
|
begin
|
|
for I := 0 to Count - 1 do
|
|
Result := Result + Items[ I ].Total;
|
|
end;
|
|
end;
|
|
|
|
//[procedure TTree.Init]
|
|
procedure TTree.Init;
|
|
begin
|
|
if FParent <> nil then
|
|
FParent.Add( @Self );
|
|
end;
|
|
|
|
//[procedure TTree.Insert]
|
|
procedure TTree.Insert(Before, Node: PTree);
|
|
var Previous: PTree;
|
|
begin
|
|
Node.Unlink;
|
|
if fChildren = nil then begin
|
|
fChildren := NewList;
|
|
end;
|
|
Previous := nil;
|
|
if Before <> nil then
|
|
Previous := Before.fPrev;
|
|
if Previous <> nil then
|
|
begin
|
|
Previous.fNext := Node;
|
|
Node.fPrev := Previous;
|
|
end;
|
|
if Before <> nil then
|
|
begin
|
|
Node.fNext := Before;
|
|
Before.fPrev := Node;
|
|
fChildren.Insert( fChildren.IndexOf( Before ), Node );
|
|
end
|
|
else
|
|
fChildren.Add( Node );
|
|
Node.fParent := @Self;
|
|
end;
|
|
|
|
//[function CompareTreeNodes]
|
|
function CompareTreeNodes( const Data: Pointer; const e1, e2: DWORD ): Integer;
|
|
var List: PList;
|
|
begin
|
|
List := Data;
|
|
{$IFDEF TREE_NONAME}
|
|
Result := DWORD( PTree( List.Items[ e1 ] ).fData ) -
|
|
DWORD( PTree( List.Items[ e2 ] ).fData );
|
|
{$ELSE}
|
|
Result := AnsiCompareStr( KOLString(PTree( List.Items[ e1 ] ).fNodeName),
|
|
KOLString(PTree( List.Items[ e2 ] ).fNodeName) );
|
|
{$ENDIF}
|
|
end;
|
|
|
|
//[procedure SwapTreeNodes]
|
|
procedure SwapTreeNodes( const Data: Pointer; const e1, e2: DWORD );
|
|
var List: PList;
|
|
begin
|
|
List := Data;
|
|
List.Swap( e1, e2 );
|
|
end;
|
|
|
|
//[procedure TTree.SwapNodes]
|
|
procedure TTree.SwapNodes( i1, i2: Integer );
|
|
begin
|
|
fChildren.Swap( i1, i2 );
|
|
end;
|
|
|
|
//[procedure TTree.SortByName]
|
|
procedure TTree.SortByName;
|
|
begin
|
|
if Count <= 1 then Exit;
|
|
SortData( fChildren, fChildren.Count, CompareTreeNodes, SwapTreeNodes );
|
|
end;
|
|
|
|
//[procedure TTree.Unlink]
|
|
procedure TTree.Unlink;
|
|
var I: Integer;
|
|
begin
|
|
if fPrev <> nil then
|
|
fPrev.fNext := fNext;
|
|
if fNext <> nil then
|
|
fNext.fPrev := fPrev;
|
|
if (fParent <> nil) then
|
|
begin
|
|
I := fParent.fChildren.IndexOf( @Self );
|
|
fParent.fChildren.Delete( I );
|
|
if fParent.fChildren.Count = 0 then
|
|
begin
|
|
fParent.fChildren.Free;
|
|
fParent.fChildren := nil;
|
|
end;
|
|
end;
|
|
fPrev := nil;
|
|
fNext := nil;
|
|
fParent := nil;
|
|
end;
|
|
|
|
//[function TTree.IsParentOfNode]
|
|
function TTree.IsParentOfNode(Node: PTree): Boolean;
|
|
begin
|
|
Result := TRUE;
|
|
while Node <> nil do
|
|
begin
|
|
if Node = @ Self then Exit;
|
|
Node := Node.Parent;
|
|
end;
|
|
Result := FALSE;
|
|
end;
|
|
|
|
//[function TTree.IndexOf]
|
|
function TTree.IndexOf(Node: PTree): Integer;
|
|
begin
|
|
Result := -1;
|
|
if not IsParentOfNode( Node ) then Exit;
|
|
while Node <> @ Self do
|
|
begin
|
|
Inc( Result );
|
|
while Node.PrevSibling <> nil do
|
|
begin
|
|
Node := Node.PrevSibling;
|
|
Inc( Result, 1 + Node.Total );
|
|
end;
|
|
Node := Node.Parent;
|
|
end;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
ADDITIONAL UTILITIES
|
|
}
|
|
|
|
function MapFileRead( const Filename: AnsiString; var hFile, hMap: THandle ): Pointer;
|
|
var Sz, Hi: DWORD;
|
|
begin
|
|
Result := nil;
|
|
hFile := FileCreate( KOLString(Filename), ofOpenRead or ofOpenExisting or ofShareDenyNone );
|
|
hMap := 0;
|
|
if hFile = INVALID_HANDLE_VALUE then Exit;
|
|
Sz := GetFileSize( hFile, @ Hi );
|
|
hMap := CreateFileMapping( hFile, nil, PAGE_READONLY, Hi, Sz, nil );
|
|
if hMap = 0 then Exit;
|
|
if (Hi <> 0) or (Sz > $0FFFFFFF) then Sz := $0FFFFFFF;
|
|
Result := MapViewOfFile( hMap, FILE_MAP_READ, 0, 0, Sz );
|
|
end;
|
|
|
|
function MapFile( const Filename: AnsiString; var hFile, hMap: THandle ): Pointer;
|
|
var Sz, Hi: DWORD;
|
|
begin
|
|
Result := nil;
|
|
hFile := FileCreate( KOLString(Filename), ofOpenRead or ofOpenWrite or ofOpenExisting
|
|
or ofShareExclusive );
|
|
hMap := 0;
|
|
if hFile = INVALID_HANDLE_VALUE then Exit;
|
|
Sz := GetFileSize( hFile, @ Hi );
|
|
hMap := CreateFileMapping( hFile, nil, PAGE_READWRITE, Hi, Sz, nil );
|
|
if hMap = 0 then Exit;
|
|
if (Hi <> 0) or (Sz > $0FFFFFFF) then Sz := $0FFFFFFF;
|
|
Result := MapViewOfFile( hMap, FILE_MAP_READ, 0, 0, Sz );
|
|
end;
|
|
|
|
procedure UnmapFile( BasePtr: Pointer; hFile, hMap: THandle );
|
|
begin
|
|
if BasePtr <> nil then
|
|
UnmapViewOfFile( BasePtr );
|
|
if hMap <> 0 then
|
|
CloseHandle( hMap );
|
|
if hFile <> INVALID_HANDLE_VALUE then
|
|
CloseHandle( hFile );
|
|
end;
|
|
|
|
//[procedure CloseMsg]
|
|
procedure CloseMsg( Dummy, Dialog: PControl; var Accept: Boolean );
|
|
begin
|
|
Accept := FALSE;
|
|
Dialog.ModalResult := -1;
|
|
end;
|
|
//[END CloseMsg]
|
|
|
|
//[procedure OKClick]
|
|
procedure OKClick( Dialog, Btn: PControl );
|
|
var Rslt: Integer;
|
|
begin
|
|
Rslt := -1;
|
|
if Btn <> nil then
|
|
Rslt := Btn.Tag;
|
|
Dialog.ModalResult := Rslt;
|
|
Dialog.Close;
|
|
end;
|
|
//[END OKClick]
|
|
|
|
//[procedure KeyClick]
|
|
procedure KeyClick( Dialog, Btn: PControl; var Key: Longint; Shift: DWORD );
|
|
begin
|
|
if (Key = VK_RETURN) or (Key = VK_ESCAPE) then
|
|
begin
|
|
if Key = VK_ESCAPE then
|
|
Btn := nil;
|
|
OKClick( Dialog, Btn );
|
|
end;
|
|
end;
|
|
//[END KeyClick]
|
|
|
|
function WndProcDlg( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
|
|
var F, B: PControl;
|
|
R: TRect;
|
|
P: TPoint;
|
|
begin
|
|
Result := FALSE;
|
|
if Msg.message = WM_PAINT then
|
|
begin
|
|
F := Pointer( Sender );
|
|
B := Pointer( F.Tag );
|
|
if B <> nil then
|
|
begin
|
|
R := B.ClientRect;
|
|
P.X := (R.Left + R.Right) div 2;
|
|
P.Y := (R.Top + R.Bottom) div 2;
|
|
P := B.Client2Screen( P );
|
|
SetCursorPos( P.X, P.Y );
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//[function ShowQuestionEx]
|
|
function ShowQuestionEx( S: KOLString; Answers: KOLString; CallBack: TOnEvent ): Integer;
|
|
{$IFDEF F_P105ORBELOW}
|
|
type POnEvent = ^TOnEvent;
|
|
PONKey = ^TOnKey;
|
|
var M: TMethod;
|
|
{$ENDIF F_P105ORBELOW}
|
|
var Dialog: PControl;
|
|
DlgPrnt: PControl;
|
|
Buttons: PList;
|
|
Btn: PControl;
|
|
AppTermFlag: Boolean;
|
|
Lab: PControl;
|
|
{$IFNDEF USE_GRUSH} Y, {$ELSE} {$IFDEF TOGRUSH_OPTIONAL} Y, {$ENDIF} {$ENDIF} W, X, I: Integer;
|
|
Title: KOLString;
|
|
DlgWnd: HWnd;
|
|
AppCtl: PControl;
|
|
{$IFDEF USE_GRUSH}
|
|
Sz: TSize;
|
|
H: Integer;
|
|
Bmp: PBitmap;
|
|
{$ENDIF}
|
|
{$IFNDEF NO_CHECK_STAYONTOP}
|
|
CurForm: PControl;
|
|
DoStayOnTop: Boolean;
|
|
{$ENDIF}
|
|
{$IFDEF SNAPMOUSE2DFLTBTN}
|
|
SnapMouse: Integer;
|
|
{$ENDIF}
|
|
begin
|
|
AppTermFlag := AppletTerminated;
|
|
AppCtl := Applet;
|
|
AppletTerminated := FALSE;
|
|
Title := 'Information';
|
|
if pos( '/', Answers ) > 0 then
|
|
Title := 'Question';
|
|
{$IFNDEF NO_CHECK_STAYONTOP}
|
|
DoStayOnTop := FALSE;
|
|
{$ENDIF NO_CHECK_STAYONTOP}
|
|
if Applet <> nil then
|
|
begin
|
|
Title := Applet.Caption;
|
|
{$IFNDEF NO_CHECK_STAYONTOP}
|
|
CurForm := Applet.ActiveControl;
|
|
DoStayOnTop := CurForm.StayOnTop;
|
|
{$ENDIF NO_CHECK_STAYONTOP}
|
|
end;
|
|
{$IFNDEF NOT_ALLOW_EXTRACT_TITLE}
|
|
if (Length( S ) > 2) and (S[ 1 ] = '!') then
|
|
begin
|
|
Delete( S, 1, 1 );
|
|
if S[ 1 ] = '!' then Delete( S, 1, 1 )
|
|
else Title := Parse( S, '!' );
|
|
end;
|
|
{$ENDIF}
|
|
Dialog := NewForm( Applet, KOLString(Title) ).SetSize( 300, 40 );
|
|
{$IFNDEF NO_CHECK_STAYONTOP}
|
|
if DoStayOnTop then
|
|
Dialog.StayOnTop := TRUE;
|
|
{$ENDIF NO_CHECK_STAYONTOP}
|
|
Dialog.Style := Dialog.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX);
|
|
Dialog.OnClose := TOnEventAccept( MakeMethod( Dialog, @CloseMsg ) );
|
|
|
|
{$IFDEF USE_GRUSH}
|
|
Bmp := NewBitmap( 1, 1 );
|
|
{$IFDEF TOGRUSH_OPTIONAL}
|
|
if not NoGrush then
|
|
{$ENDIF TOGRUSH_OPTIONAL}
|
|
begin
|
|
Dialog.Color := clGRushLight;
|
|
Dialog.Font.FontName := 'Arial';
|
|
Dialog.Font.FontHeight := 16;
|
|
DlgPrnt := NewPanel( Dialog, esNone ); //.SetAlign( caClient );
|
|
end
|
|
{$IFDEF TOGRUSH_OPTIONAL}
|
|
else
|
|
DlgPrnt := Dialog;
|
|
{$ENDIF TOGRUSH_OPTIONAL}
|
|
;
|
|
{$ELSE}
|
|
DlgPrnt := Dialog;
|
|
{$ENDIF USE_GRUSH}
|
|
|
|
DlgPrnt.Margin := 8;
|
|
|
|
{$IFDEF USE_GRUSH}
|
|
{$IFDEF TOGRUSH_OPTIONAL}
|
|
if not NoGrush then
|
|
{$ENDIF TOGRUSH_OPTIONAL}
|
|
begin
|
|
Lab := NewWordWrapLabel( DlgPrnt, S ).SetSize( 278, 20 );
|
|
Lab.AutoSize( TRUE );
|
|
Lab.Transparent := TRUE;
|
|
end
|
|
{$IFDEF TOGRUSH_OPTIONAL}
|
|
else
|
|
begin
|
|
Lab := NewEditbox( DlgPrnt, [ eoMultiline, eoReadonly, eoNoHScroll, eoNoVScroll ] ).SetSize( 278, 20 );
|
|
Lab.HasBorder := FALSE;
|
|
Lab.Color := clBtnFace;
|
|
Lab.Caption := S;
|
|
Lab.Style := Lab.Style and not WS_TABSTOP;
|
|
Lab.TabStop := FALSE;
|
|
while TRUE do
|
|
begin
|
|
Y := HiWord( Lab.Perform( EM_POSFROMCHAR, Length( S ) - 1, 0 ) );
|
|
if Y < Lab.Height - 20 then break;
|
|
Lab.Height := Lab.Height + 4;
|
|
if Lab.Height + 40 > GetSystemMetrics( SM_CYSCREEN ) then break;
|
|
end;
|
|
end
|
|
{$ENDIF TOGRUSH_OPTIONAL}
|
|
;
|
|
{$ELSE}
|
|
Lab := NewEditbox( DlgPrnt, [ eoMultiline, eoReadonly, eoNoHScroll, eoNoVScroll ] ).SetSize( 278, 20 );
|
|
Lab.HasBorder := FALSE;
|
|
Lab.Color := clBtnFace;
|
|
Lab.Caption := S;
|
|
Lab.Style := Lab.Style and not WS_TABSTOP;
|
|
Lab.TabStop := FALSE;
|
|
|
|
//Lab.CreateWindow; //virtual!!! -- not needed, window created in Perform
|
|
while TRUE do
|
|
begin
|
|
Y := HiWord( Lab.Perform( EM_POSFROMCHAR, Length( S ) - 1, 0 ) );
|
|
if Y < Lab.Height - 20 then break;
|
|
Lab.Height := Lab.Height + 4;
|
|
if Lab.Height + 40 > GetSystemMetrics( SM_CYSCREEN ) then break;
|
|
end;
|
|
//Lab.LikeSpeedButton;
|
|
|
|
{$ENDIF USE_GRUSH}
|
|
|
|
Buttons := NewList;
|
|
W := 0;
|
|
|
|
{$IFDEF USE_GRUSH}
|
|
H := 0;
|
|
{$ENDIF}
|
|
|
|
if Answers = '' then
|
|
begin
|
|
Btn := NewButton( DlgPrnt, ' OK ' ).PlaceUnder;
|
|
|
|
{$IFDEF USE_GRUSH}
|
|
{$IFDEF TOGRUSH_OPTIONAL}
|
|
if not NoGrush then
|
|
{$ENDIF TOGRUSH_OPTIONAL}
|
|
begin
|
|
Sz := Bmp.Canvas.TextExtent( Btn.Caption );
|
|
if H = 0 then H := Sz.cy + 8;
|
|
Btn.SetSize( Sz.cx + 16, H );
|
|
end;
|
|
{$ENDIF}
|
|
|
|
W := Btn.BoundsRect.Right;
|
|
Buttons.Add( Btn );
|
|
end
|
|
else
|
|
while Answers <> '' do
|
|
begin
|
|
Btn := NewButton( DlgPrnt, ' ' + Parse( Answers, '/' ) + ' ' );
|
|
Buttons.Add( Btn );
|
|
if W = 0 then
|
|
Btn.PlaceUnder
|
|
else
|
|
Btn.PlaceRight;
|
|
|
|
{$IFDEF USE_GRUSH}
|
|
{$IFDEF TOGRUSH_OPTIONAL}
|
|
if not NoGrush then
|
|
{$ENDIF TOGRUSH_OPTIONAL}
|
|
begin
|
|
Sz := Bmp.Canvas.TextExtent( Btn.Caption );
|
|
if H = 0 then H := Sz.cy + 8;
|
|
Btn.SetSize( Sz.cx + 16, H );
|
|
end
|
|
{$IFDEF TOGRUSH_OPTIONAL}
|
|
else Btn.AutoSize( TRUE )
|
|
{$ENDIF TOGRUSH_OPTIONAL}
|
|
;
|
|
{$ELSE}
|
|
Btn.AutoSize( TRUE );
|
|
{$ENDIF USE_GRUSH}
|
|
|
|
if W > 0 then
|
|
begin
|
|
//Inc( W, 6 );
|
|
Btn.Left := Btn.Left + 6;
|
|
end;
|
|
W := Btn.BoundsRect.Right;
|
|
end;
|
|
DlgPrnt.Width := Max(
|
|
Max( DlgPrnt.Width, Lab.Left + Lab.Width + 4 ), W + 8 );
|
|
X := (DlgPrnt.ClientWidth - W) div 2;
|
|
for I := 0 to Buttons.Count-1 do
|
|
begin
|
|
Btn := Buttons.Items[ I ];
|
|
Btn.Tag := I + 1;
|
|
{$IFDEF F_P105ORBELOW}
|
|
M := MakeMethod( Dialog, @OKClick );
|
|
Btn.OnClick := POnEvent( @ M )^;
|
|
M := MakeMethod( Dialog, @KeyClick );
|
|
Btn.OnKeyDown := POnKey( @ M )^;
|
|
{$ELSE}
|
|
Btn.OnClick := TOnEvent( MakeMethod( Dialog, @OKClick ) );
|
|
Btn.OnKeyDown := TOnKey( MakeMethod( Dialog, @KeyClick ) );
|
|
{$ENDIF}
|
|
Btn.Left := Btn.Left + X;
|
|
if I = 0 then
|
|
begin
|
|
Btn.ResizeParentBottom;
|
|
Dialog.ActiveControl := Btn;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF USE_GRUSH}
|
|
{$IFDEF TOGRUSH_OPTIONAL}
|
|
if not NoGrush then
|
|
{$ENDIF TOGRUSH_OPTIONAL}
|
|
begin
|
|
DlgPrnt.ResizeParent;
|
|
DlgPrnt.Width := Max( DlgPrnt.Width, Dialog.Width - 14 );
|
|
end;
|
|
Bmp.Free;
|
|
{$ENDIF USE_GRUSH}
|
|
|
|
Dialog.CenterOnParent.Tabulate.CanResize := FALSE;
|
|
|
|
if Assigned( CallBack ) then
|
|
CallBack( Dialog );
|
|
Dialog.CreateWindow; // virtual!!!
|
|
|
|
if (Applet <> nil) and Applet.IsApplet then
|
|
begin
|
|
{$IFDEF SNAPMOUSE2DFLTBTN}
|
|
SnapMouse := 0;
|
|
if SystemParametersInfo( SPI_GETSNAPTODEFBUTTON, 0, @ SnapMouse, 0 ) then
|
|
if SnapMouse <> 0 then
|
|
begin
|
|
Dialog.Tag := DWORD( Buttons.Items[ 0 ] );
|
|
Dialog.AttachProc( WndProcDlg );
|
|
end;
|
|
{$ENDIF}
|
|
Dialog.ShowModal;
|
|
Result := Dialog.ModalResult;
|
|
Dialog.Free;
|
|
end
|
|
else
|
|
begin
|
|
DlgWnd := Dialog.Handle;
|
|
while IsWindow( DlgWnd ) and (Dialog.ModalResult = 0) do
|
|
Dialog.ProcessMessage;
|
|
Result := Dialog.ModalResult;
|
|
Dialog.Free;
|
|
CreatingWindow := nil;
|
|
Applet := AppCtl;
|
|
end;
|
|
Buttons.Free;
|
|
|
|
AppletTerminated := AppTermFlag;
|
|
end;
|
|
//[END ShowQuestionEx]
|
|
|
|
//[function ShowQuestion]
|
|
function ShowQuestion( const S: KOLString; Answers: KOLString ): Integer;
|
|
begin
|
|
Result := ShowQuestionEx( S, Answers, nil );
|
|
end;
|
|
//[END ShowQuestion]
|
|
|
|
//[procedure ShowMsgModal]
|
|
procedure ShowMsgModal( const S: KOLString );
|
|
begin
|
|
ShowQuestion( S, '' );
|
|
end;
|
|
//[END ShowMsgModal]
|
|
|
|
end.
|